From 4898ef32c639b1c7f4ee13a5ba566ce6debd03e6 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Thu, 14 Jul 2005 16:30:05 +0000 Subject: [PATCH] 0.9.2.43: another slice of whitespace canonicalization (Anyone who ends up here with "cvs annotate" probably wants to look at the "tabby" tagged version.) --- contrib/asdf-install/installer.lisp | 378 +- contrib/asdf-stub.lisp | 12 +- contrib/asdf/asdf.lisp | 864 +- contrib/code-extras.lisp | 14 +- contrib/compiler-extras.lisp | 172 +- contrib/sb-aclrepl/debug.lisp | 90 +- contrib/sb-aclrepl/inspect.lisp | 524 +- contrib/sb-aclrepl/repl.lisp | 678 +- contrib/sb-aclrepl/tests.lisp | 102 +- contrib/sb-aclrepl/toplevel.lisp | 50 +- contrib/sb-bsd-sockets/constants.lisp | 44 +- contrib/sb-bsd-sockets/defpackage.lisp | 28 +- contrib/sb-bsd-sockets/doc.lisp | 216 +- contrib/sb-bsd-sockets/inet.lisp | 8 +- contrib/sb-bsd-sockets/local.lisp | 2 +- contrib/sb-bsd-sockets/misc.lisp | 2 +- contrib/sb-bsd-sockets/name-service.lisp | 70 +- contrib/sb-bsd-sockets/sockets.lisp | 218 +- contrib/sb-bsd-sockets/sockopt.lisp | 64 +- contrib/sb-bsd-sockets/tests.lisp | 118 +- contrib/sb-cltl2/env.lisp | 14 +- contrib/sb-cltl2/tests.lisp | 44 +- contrib/sb-executable/sb-executable.lisp | 46 +- contrib/sb-grovel/def-to-lisp.lisp | 202 +- contrib/sb-grovel/example-constants.lisp | 26 +- contrib/sb-grovel/foreign-glue.lisp | 334 +- contrib/sb-introspect/sb-introspect.lisp | 94 +- contrib/sb-introspect/test-driver.lisp | 10 +- contrib/sb-md5/md5-tests.lisp | 40 +- contrib/sb-md5/md5.lisp | 392 +- contrib/sb-posix/constants.lisp | 60 +- contrib/sb-posix/defpackage.lisp | 20 +- contrib/sb-posix/designator.lisp | 18 +- contrib/sb-posix/interface.lisp | 210 +- contrib/sb-posix/macros.lisp | 86 +- contrib/sb-posix/posix-tests.lisp | 140 +- contrib/sb-rotate-byte/compiler.lisp | 26 +- contrib/sb-rotate-byte/ppc-vm.lisp | 46 +- contrib/sb-rotate-byte/rotate-byte-tests.lisp | 4 +- contrib/sb-rotate-byte/rotate-byte.lisp | 16 +- contrib/sb-rotate-byte/x86-vm.lisp | 52 +- contrib/sb-rt/rt.lisp | 180 +- contrib/sb-simple-streams/classes.lisp | 38 +- contrib/sb-simple-streams/direct.lisp | 2 +- contrib/sb-simple-streams/file.lisp | 252 +- contrib/sb-simple-streams/fndb.lisp | 40 +- contrib/sb-simple-streams/impl.lisp | 516 +- contrib/sb-simple-streams/internal.lisp | 664 +- contrib/sb-simple-streams/iodefs.lisp | 118 +- contrib/sb-simple-streams/null.lisp | 16 +- contrib/sb-simple-streams/simple-stream-tests.lisp | 10 +- contrib/sb-simple-streams/socket.lisp | 54 +- contrib/sb-simple-streams/strategy.lisp | 538 +- contrib/sb-simple-streams/string.lisp | 60 +- contrib/sb-simple-streams/terminal.lisp | 12 +- contrib/sb-sprof/sb-sprof.lisp | 902 +- contrib/stale-symbols.lisp | 76 +- doc/manual/docstrings.lisp | 458 +- src/assembly/alpha/arith.lisp | 306 +- src/assembly/alpha/array.lisp | 82 +- src/assembly/alpha/assem-rtns.lisp | 30 +- src/assembly/alpha/support.lisp | 68 +- src/assembly/assemfile.lisp | 224 +- src/assembly/hppa/arith.lisp | 126 +- src/assembly/hppa/array.lisp | 8 +- src/assembly/hppa/assem-rtns.lisp | 20 +- src/assembly/hppa/support.lisp | 78 +- src/assembly/mips/arith.lisp | 250 +- src/assembly/mips/array.lisp | 24 +- src/assembly/mips/assem-rtns.lisp | 26 +- src/assembly/mips/support.lisp | 64 +- src/assembly/ppc/arith.lisp | 224 +- src/assembly/ppc/array.lisp | 12 +- src/assembly/ppc/assem-rtns.lisp | 66 +- src/assembly/ppc/support.lisp | 64 +- src/assembly/sparc/arith.lisp | 468 +- src/assembly/sparc/array.lisp | 22 +- src/assembly/sparc/assem-rtns.lisp | 64 +- src/assembly/sparc/support.lisp | 84 +- src/assembly/x86-64/arith.lisp | 302 +- src/assembly/x86-64/array.lisp | 20 +- src/assembly/x86-64/assem-rtns.lisp | 62 +- src/assembly/x86-64/support.lisp | 18 +- src/assembly/x86/arith.lisp | 380 +- src/assembly/x86/assem-rtns.lisp | 58 +- src/assembly/x86/support.lisp | 6 +- src/code/alien-type.lisp | 24 +- src/code/alloc.lisp | 45 +- src/code/alpha-vm.lisp | 50 +- src/code/ansi-stream.lisp | 64 +- src/code/array.lisp | 1048 +- src/code/backq.lisp | 186 +- src/code/bignum.lisp | 2582 +- src/code/bit-bash.lisp | 46 +- src/code/bsd-os.lisp | 28 +- src/code/cl-specials.lisp | 158 +- src/code/class-init.lisp | 6 +- src/code/class.lisp | 870 +- src/code/coerce.lisp | 452 +- src/code/cold-error.lisp | 144 +- src/code/cold-init.lisp | 138 +- src/code/condition.lisp | 944 +- src/code/cross-byte.lisp | 28 +- src/code/cross-char.lisp | 8 +- src/code/cross-condition.lisp | 10 +- src/code/cross-float.lisp | 222 +- src/code/cross-make-load-form.lisp | 6 +- src/code/cross-misc.lisp | 14 +- src/code/cross-sap.lisp | 56 +- src/code/cross-type.lisp | 522 +- src/code/debug-info.lisp | 64 +- src/code/debug-int.lisp | 2756 +- src/code/debug-var-io.lisp | 58 +- src/code/debug.lisp | 1054 +- src/code/defbangconstant.lisp | 28 +- src/code/defbangmacro.lisp | 18 +- src/code/defbangstruct.lisp | 182 +- src/code/defbangtype.lisp | 26 +- src/code/defboot.lisp | 552 +- src/code/defmacro.lisp | 26 +- src/code/defpackage.lisp | 302 +- src/code/defsetfs.lisp | 4 +- src/code/defstruct.lisp | 1646 +- src/code/deftypes-for-target.lisp | 50 +- src/code/describe.lisp | 192 +- src/code/destructuring-bind.lisp | 10 +- src/code/dyncount.lisp | 426 +- src/code/early-cl.lisp | 2 +- src/code/early-defstructs.lisp | 4 +- src/code/early-extensions.lisp | 676 +- src/code/early-fasl.lisp | 70 +- src/code/early-float.lisp | 46 +- src/code/early-format.lisp | 10 +- src/code/early-impl.lisp | 70 +- src/code/early-package.lisp | 50 +- src/code/early-pcounter.lisp | 2 +- src/code/early-pprint.lisp | 208 +- src/code/early-print.lisp | 152 +- src/code/early-setf.lisp | 524 +- src/code/early-type.lisp | 406 +- src/code/error-error.lisp | 6 +- src/code/error.lisp | 46 +- src/code/eucjp.lisp |26374 ++++++++++---------- src/code/eval.lisp | 256 +- src/code/exhaust.lisp | 4 +- src/code/fd-stream.lisp | 2424 +- src/code/fdefinition.lisp | 120 +- src/code/filesys.lisp | 1286 +- src/code/final.lisp | 42 +- src/code/float-trap.lisp | 160 +- src/code/float.lisp | 810 +- src/code/fop.lisp | 322 +- src/code/force-delayed-defbangmethods.lisp | 32 +- src/code/foreign-load.lisp | 84 +- src/code/foreign.lisp | 70 +- src/code/format-time.lisp | 150 +- src/code/function-names.lisp | 22 +- src/code/funutils.lisp | 10 +- src/code/gc.lisp | 76 +- src/code/globals.lisp | 42 +- src/code/hash-table.lisp | 46 +- src/code/host-alieneval.lisp | 818 +- src/code/hppa-vm.lisp | 66 +- src/code/inspect.lisp | 272 +- src/code/interr.lisp | 434 +- src/code/irrat.lisp | 832 +- src/code/koi8-r.lisp | 10 +- src/code/late-extensions.lisp | 4 +- src/code/late-format.lisp | 1716 +- src/code/late-setf.lisp | 80 +- src/code/late-type.lisp | 2516 +- src/code/linkage-table.lisp | 28 +- src/code/linux-os.lisp | 20 +- src/code/list.lisp | 130 +- src/code/load.lisp | 306 +- src/code/loop.lisp | 2148 +- src/code/macroexpand.lisp | 68 +- src/code/macros.lisp | 348 +- src/code/mips-vm.lisp | 76 +- src/code/mipsstrops.lisp | 66 +- src/code/module.lisp | 60 +- src/code/ntrace.lisp | 472 +- src/code/numbers.lisp | 944 +- src/code/octets.lisp | 638 +- src/code/osf1-os.lisp | 20 +- src/code/package.lisp | 470 +- src/code/parse-body.lisp | 68 +- src/code/parse-defmacro-errors.lisp | 104 +- src/code/parse-defmacro.lisp | 262 +- src/code/pathname.lisp | 56 +- src/code/pcounter.lisp | 20 +- src/code/pp-backq.lisp | 40 +- src/code/ppc-vm.lisp | 116 +- src/code/pprint.lisp | 1376 +- src/code/pred.lisp | 228 +- src/code/primordial-extensions.lisp | 222 +- src/code/print.lisp | 1314 +- src/code/profile.lisp | 332 +- src/code/purify.lisp | 10 +- src/code/query.lisp | 26 +- src/code/random.lisp | 2 +- src/code/reader.lisp | 1364 +- src/code/readtable.lisp | 14 +- src/code/room.lisp | 878 +- src/code/run-program.lisp | 792 +- src/code/save.lisp | 18 +- src/code/sc-offset.lisp | 2 +- src/code/seq.lisp | 2054 +- src/code/serve-event.lisp | 224 +- src/code/setf-funs.lisp | 36 +- src/code/sharpm.lisp | 440 +- src/code/show.lisp | 108 +- src/code/signal.lisp | 10 +- src/code/sort.lisp | 400 +- src/code/sparc-vm.lisp | 100 +- src/code/specializable-array.lisp | 28 +- src/code/step.lisp | 10 +- src/code/stream.lisp | 1540 +- src/code/string.lisp | 288 +- src/code/stubs.lisp | 2 +- src/code/sunos-os.lisp | 20 +- src/code/sxhash.lisp | 152 +- src/code/symbol.lisp | 104 +- src/code/sysmacs.lisp | 88 +- src/code/target-alieneval.lisp | 688 +- src/code/target-allocate.lisp | 8 +- src/code/target-c-call.lisp | 10 +- src/code/target-char.lisp | 270 +- src/code/target-defstruct.lisp | 420 +- src/code/target-error.lisp | 106 +- src/code/target-extensions.lisp | 22 +- src/code/target-format.lisp | 1230 +- src/code/target-hash-table.lisp | 586 +- src/code/target-load.lisp | 244 +- src/code/target-misc.lisp | 80 +- src/code/target-package.lisp | 934 +- src/code/target-pathname.lisp | 1836 +- src/code/target-random.lisp | 142 +- src/code/target-sap.lisp | 84 +- src/code/target-signal.lisp | 54 +- src/code/target-stream.lisp | 84 +- src/code/target-sxhash.lisp | 292 +- src/code/target-thread.lisp | 20 +- src/code/target-type.lisp | 176 +- src/code/thread.lisp | 26 +- src/code/time.lisp | 308 +- src/code/toplevel.lisp | 658 +- src/code/type-class.lisp | 116 +- src/code/type-init.lisp | 8 +- src/code/typecheckfuns.lisp | 206 +- src/code/typedefs.lisp | 50 +- src/code/typep.lisp | 190 +- src/code/uncross.lisp | 116 +- src/code/unix.lisp | 732 +- src/code/unportable-float.lisp | 6 +- src/code/weak.lisp | 2 +- src/code/x86-64-vm.lisp | 236 +- src/code/x86-vm.lisp | 226 +- src/cold/ansify.lisp | 104 +- src/cold/compile-cold-sbcl.lisp | 10 +- src/cold/defun-load-or-cload-xcompiler.lisp | 234 +- src/cold/read-from-file.lisp | 6 +- src/cold/rename-package-carefully.lisp | 6 +- src/cold/set-up-cold-packages.lisp | 156 +- src/cold/shared.lisp | 156 +- src/cold/shebang.lisp | 100 +- src/cold/slam.lisp | 16 +- src/cold/snapshot.lisp | 164 +- src/cold/warm.lisp | 230 +- src/cold/with-stuff.lisp | 96 +- src/compiler/alpha/alloc.lisp | 90 +- src/compiler/alpha/arith.lisp | 300 +- src/compiler/alpha/array.lisp | 206 +- src/compiler/alpha/c-call.lisp | 98 +- src/compiler/alpha/call.lisp | 866 +- src/compiler/alpha/cell.lisp | 166 +- src/compiler/alpha/char.lisp | 28 +- src/compiler/alpha/debug.lisp | 18 +- src/compiler/alpha/float.lisp | 672 +- src/compiler/alpha/insts.lisp | 206 +- src/compiler/alpha/macros.lisp | 546 +- src/compiler/alpha/memory.lisp | 2 +- src/compiler/alpha/move.lisp | 38 +- src/compiler/alpha/nlx.lisp | 108 +- src/compiler/alpha/parms.lisp | 10 +- src/compiler/alpha/pred.lisp | 6 +- src/compiler/alpha/sanctify.lisp | 2 +- src/compiler/alpha/sap.lisp | 26 +- src/compiler/alpha/show.lisp | 6 +- src/compiler/alpha/static-fn.lisp | 131 - tests/alien.impure.lisp | 18 +- tests/arith.impure.lisp | 68 +- tests/arith.pure.lisp | 128 +- tests/array.pure.lisp | 126 +- tests/assertoid.lisp | 98 +- tests/backq.impure.lisp | 10 +- tests/bit-vector.impure-cload.lisp | 28 +- tests/bivalent-stream.impure.lisp | 10 +- tests/bug-doug-mcnaught-20030914.lisp | 2 +- tests/callback.impure.lisp | 28 +- tests/character.pure.lisp | 26 +- tests/clocc-ansi-test-known-bugs.lisp | 4 +- tests/clos-ignore.interactive.lisp | 2 +- tests/clos.impure-cload.lisp | 18 +- tests/clos.impure.lisp | 454 +- tests/clos.pure.lisp | 22 +- tests/compiler-1.impure-cload.lisp | 10 +- tests/compiler.impure-cload.lisp | 20 +- tests/compiler.impure.lisp | 378 +- tests/compiler.pure-cload.lisp | 12 +- tests/compiler.pure.lisp | 524 +- tests/compound-cons.impure.lisp | 4 +- tests/condition.impure.lisp | 2 +- tests/condition.pure.lisp | 16 +- tests/debug.impure.lisp | 44 +- tests/define-compiler-macro.impure.lisp | 34 +- tests/defstruct.impure.lisp | 272 +- tests/deftype.impure.lisp | 2 +- tests/dump.impure-cload.lisp | 10 +- tests/dynamic-extent.impure.lisp | 6 +- tests/eucjp-test.lisp-expr |26208 +++++++++---------- tests/eucjp.impure.lisp | 96 +- tests/eval.impure.lisp | 6 +- tests/exhaust.impure.lisp | 8 +- tests/external-format.impure.lisp | 90 +- tests/filesys.pure.lisp | 46 +- tests/float.impure.lisp | 32 +- tests/float.pure.lisp | 26 +- tests/gcd.pure.lisp | 24 +- tests/gray-streams.impure.lisp | 52 +- tests/hash.impure.lisp | 350 +- tests/info.before-xc.lisp | 4 +- tests/info.impure.lisp | 2 +- tests/interface.impure.lisp | 14 +- tests/interface.pure.lisp | 84 +- tests/lambda-list.pure.lisp | 2 +- tests/list.pure.lisp | 50 +- tests/load.impure.lisp | 2 +- tests/load.pure.lisp | 2 +- tests/loop.impure.lisp | 16 +- tests/loop.pure.lisp | 134 +- tests/map-tests.impure.lisp | 124 +- tests/mop-1.impure-cload.lisp | 12 +- tests/mop-2.impure-cload.lisp | 22 +- tests/mop.impure-cload.lisp | 8 +- tests/mop.impure.lisp | 160 +- tests/octets.pure.lisp | 196 +- tests/package-locks.impure.lisp | 94 +- tests/packages.impure.lisp | 2 +- tests/pathnames.impure.lisp | 120 +- tests/pprint.impure.lisp | 114 +- tests/print.impure.lisp | 78 +- tests/properties.impure.lisp | 2 +- tests/pure.lisp | 2 +- tests/reader.impure.lisp | 8 +- tests/reader.pure.lisp | 162 +- tests/seq.impure.lisp | 488 +- tests/seq.pure.lisp | 112 +- tests/setf.impure.lisp | 2 +- tests/smoke.impure.lisp | 6 +- tests/static-alloc.impure.lisp | 16 +- tests/stream.impure-cload.lisp | 48 +- tests/stream.impure.lisp | 72 +- tests/stream.pure.lisp | 124 +- tests/stress-gc.lisp | 263 +- tests/string.pure.lisp | 40 +- tests/threads.impure.lisp | 110 +- tests/time.pure.lisp | 28 +- tests/type.after-xc.lisp | 10 +- tests/type.before-xc.lisp | 136 +- tests/type.impure.lisp | 158 +- tests/type.pure.lisp | 244 +- tests/vector.pure.lisp | 52 +- tests/vm.before-xc.lisp | 12 +- tests/walk.impure.lisp | 183 +- version.lisp-expr | 2 +- 376 files changed, 67674 insertions(+), 67792 deletions(-) diff --git a/contrib/asdf-install/installer.lisp b/contrib/asdf-install/installer.lisp index 3acb93a..fbf1b32 100644 --- a/contrib/asdf-install/installer.lisp +++ b/contrib/asdf-install/installer.lisp @@ -10,32 +10,32 @@ ;; want a directory (let ((path (pathname name))) (if (pathname-name path) - (merge-pathnames - (make-pathname :directory `(:relative ,(pathname-name path))) - (make-pathname :directory (pathname-directory path) - :host (pathname-host path))) - path))) + (merge-pathnames + (make-pathname :directory `(:relative ,(pathname-name path))) + (make-pathname :directory (pathname-directory path) + :host (pathname-host path))) + path))) (defvar *sbcl-home* (directorify (posix-getenv "SBCL_HOME"))) (defvar *dot-sbcl* (merge-pathnames (make-pathname :directory '(:relative ".sbcl")) - (user-homedir-pathname))) + (user-homedir-pathname))) (defparameter *trusted-uids* nil) (defun verify-gpg-signatures-p (url) (labels ((prefixp (prefix string) - (let ((m (mismatch prefix string))) - (or (not m) (>= m (length prefix)))))) + (let ((m (mismatch prefix string))) + (or (not m) (>= m (length prefix)))))) (case *verify-gpg-signatures* (nil nil) (:unknown-locations (notany - (lambda (x) (prefixp x url)) - (cons *cclan-mirror* *safe-url-prefixes*))) + (lambda (x) (prefixp x url)) + (cons *cclan-mirror* *safe-url-prefixes*))) (t t)))) - + (defvar *locations* `((,(merge-pathnames "site/" *sbcl-home*) ,(merge-pathnames "site-systems/" *sbcl-home*) @@ -46,54 +46,54 @@ (let* ((*package* (find-package :asdf-install-customize)) (file (probe-file (merge-pathnames - (make-pathname :name ".asdf-install") - (user-homedir-pathname))))) + (make-pathname :name ".asdf-install") + (user-homedir-pathname))))) (when file (load file))) (define-condition download-error (error) ((url :initarg :url :reader download-url) (response :initarg :response :reader download-response)) (:report (lambda (c s) - (format s "Server responded ~A for GET ~A" - (download-response c) (download-url c))))) + (format s "Server responded ~A for GET ~A" + (download-response c) (download-url c))))) (define-condition signature-error (error) ((cause :initarg :cause :reader signature-error-cause)) (:report (lambda (c s) - (format s "Cannot verify package signature: ~A" - (signature-error-cause c))))) + (format s "Cannot verify package signature: ~A" + (signature-error-cause c))))) (define-condition gpg-error (error) ((message :initarg :message :reader gpg-error-message)) (:report (lambda (c s) - (format t "GPG failed with error status:~%~S" - (gpg-error-message c))))) + (format t "GPG failed with error status:~%~S" + (gpg-error-message c))))) (define-condition no-signature (gpg-error) ()) (define-condition key-not-found (gpg-error) ((key-id :initarg :key-id :reader key-id)) (:report (lambda (c s) - (format s "No key found for key id 0x~A. Try some command like ~% gpg --recv-keys 0x~A" - (key-id c) (key-id c))))) + (format s "No key found for key id 0x~A. Try some command like ~% gpg --recv-keys 0x~A" + (key-id c) (key-id c))))) (define-condition key-not-trusted (gpg-error) ((key-id :initarg :key-id :reader key-id) (key-user-name :initarg :key-user-name :reader key-user-name)) (:report (lambda (c s) - (format s "GPG warns that the key id 0x~A (~A) is not fully trusted" - (key-id c) (key-user-name c))))) + (format s "GPG warns that the key id 0x~A (~A) is not fully trusted" + (key-id c) (key-user-name c))))) (define-condition author-not-trusted (gpg-error) ((key-id :initarg :key-id :reader key-id) (key-user-name :initarg :key-user-name :reader key-user-name)) (:report (lambda (c s) - (format s "~A (key id ~A) is not on your package supplier list" - (key-user-name c) (key-id c))))) - + (format s "~A (key id ~A) is not on your package supplier list" + (key-user-name c) (key-id c))))) + (defun url-host (url) (assert (string-equal url "http://" :end1 7)) (let* ((port-start (position #\: url :start 7)) - (host-end (min (or (position #\/ url :start 7) (length url)) - (or port-start (length url))))) + (host-end (min (or (position #\/ url :start 7) (length url)) + (or port-start (length url))))) (subseq url 7 host-end))) (defun url-port (url) @@ -103,8 +103,8 @@ (defun url-connection (url) (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)) - (host (url-host url)) - (port (url-port url))) + (host (url-host url)) + (port (url-port url))) (declare (ignore port)) (socket-connect s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url))))) @@ -113,107 +113,107 @@ ;; we are exceedingly unportable about proper line-endings here. ;; Anyone wishing to run this under non-SBCL should take especial care (format stream "GET ~A HTTP/1.0~%Host: ~A~%Cookie: CCLAN-SITE=~A~%~%" - url host *cclan-mirror*) + url host *cclan-mirror*) (force-output stream) (list (let* ((l (read-line stream)) - (space (position #\Space l))) - (parse-integer l :start (1+ space) :junk-allowed t)) + (space (position #\Space l))) + (parse-integer l :start (1+ space) :junk-allowed t)) (loop for line = (read-line stream nil nil) - until (or (null line) (eql (elt line 0) (code-char 13))) - collect - (let ((colon (position #\: line))) - (cons (intern (string-upcase (subseq line 0 colon)) :keyword) - (string-trim (list #\Space (code-char 13)) - (subseq line (1+ colon)))))) + until (or (null line) (eql (elt line 0) (code-char 13))) + collect + (let ((colon (position #\: line))) + (cons (intern (string-upcase (subseq line 0 colon)) :keyword) + (string-trim (list #\Space (code-char 13)) + (subseq line (1+ colon)))))) stream)))) (defun download-files-for-package (package-name-or-url file-name) (let ((url - (if (= (mismatch package-name-or-url "http://") 7) - package-name-or-url - (format nil "http://www.cliki.net/~A?download" - package-name-or-url)))) + (if (= (mismatch package-name-or-url "http://") 7) + package-name-or-url + (format nil "http://www.cliki.net/~A?download" + package-name-or-url)))) (destructuring-bind (response headers stream) - (block got - (loop - (destructuring-bind (response headers stream) (url-connection url) - (unless (member response '(301 302)) - (return-from got (list response headers stream))) - (close stream) - (setf url (cdr (assoc :location headers)))))) + (block got + (loop + (destructuring-bind (response headers stream) (url-connection url) + (unless (member response '(301 302)) + (return-from got (list response headers stream))) + (close stream) + (setf url (cdr (assoc :location headers)))))) (if (>= response 400) - (error 'download-error :url url :response response)) + (error 'download-error :url url :response response)) (let ((length (parse-integer - (or (cdr (assoc :content-length headers)) "") - :junk-allowed t))) - (format t "Downloading ~A bytes from ~A ..." - (if length length "some unknown number of") url) - (force-output) - (with-open-file (o file-name :direction :output :external-format :iso-8859-1) - (if length - (let ((buf (make-array length - :element-type - (stream-element-type stream)))) - (read-sequence buf stream) - (write-sequence buf o)) - (sb-executable:copy-stream stream o)))) + (or (cdr (assoc :content-length headers)) "") + :junk-allowed t))) + (format t "Downloading ~A bytes from ~A ..." + (if length length "some unknown number of") url) + (force-output) + (with-open-file (o file-name :direction :output :external-format :iso-8859-1) + (if length + (let ((buf (make-array length + :element-type + (stream-element-type stream)))) + (read-sequence buf stream) + (write-sequence buf o)) + (sb-executable:copy-stream stream o)))) (close stream) (terpri) - (restart-case - (verify-gpg-signature/url url file-name) - (skip-gpg-check (&rest rest) - :report "Don't check GPG signature for this package" - nil))))) + (restart-case + (verify-gpg-signature/url url file-name) + (skip-gpg-check (&rest rest) + :report "Don't check GPG signature for this package" + nil))))) (defun read-until-eof (stream) (with-output-to-string (o) (sb-executable:copy-stream stream o))) - + (defun verify-gpg-signature/string (string file-name) (let* ((proc - (sb-ext:run-program - "gpg" - (list - "--status-fd" "1" "--verify" "-" - (namestring file-name)) - :output :stream :error :stream :search t - :input (make-string-input-stream string) :wait t)) - (ret (process-exit-code proc)) - (err (read-until-eof (process-error proc))) - tags) + (sb-ext:run-program + "gpg" + (list + "--status-fd" "1" "--verify" "-" + (namestring file-name)) + :output :stream :error :stream :search t + :input (make-string-input-stream string) :wait t)) + (ret (process-exit-code proc)) + (err (read-until-eof (process-error proc))) + tags) (loop for l = (read-line (process-output proc) nil nil) - while l - when (> (mismatch l "[GNUPG:]") 6) - do (destructuring-bind (_ tag &rest data) (asdf::split l) - (pushnew (cons (intern tag :keyword) - data) tags))) + while l + when (> (mismatch l "[GNUPG:]") 6) + do (destructuring-bind (_ tag &rest data) (asdf::split l) + (pushnew (cons (intern tag :keyword) + data) tags))) ;; test for obvious key/sig problems (let ((errsig (assoc :errsig tags))) (and errsig (error 'key-not-found :key-id (second errsig) :gpg-err err))) (let ((badsig (assoc :badsig tags))) (and badsig (error 'key-not-found :key-id (second badsig) :gpg-err err))) (let* ((good (assoc :goodsig tags)) - (id (second good)) - (name (format nil "~{~A~^ ~}" (nthcdr 2 good)))) + (id (second good)) + (name (format nil "~{~A~^ ~}" (nthcdr 2 good)))) ;; good signature, but perhaps not trusted (unless (or (assoc :trust_ultimate tags) - (assoc :trust_fully tags)) - (cerror "Install the package anyway" - 'key-not-trusted - :key-user-name name - :key-id id :gpg-err err)) + (assoc :trust_fully tags)) + (cerror "Install the package anyway" + 'key-not-trusted + :key-user-name name + :key-id id :gpg-err err)) (loop (when - (restart-case - (or (assoc id *trusted-uids* :test #'equal) - (error 'author-not-trusted - :key-user-name name - :key-id id :gpg-err nil)) - (add-key (&rest rest) - :report "Add to package supplier list" - (pushnew (list id name) *trusted-uids*))) - (return)))))) + (restart-case + (or (assoc id *trusted-uids* :test #'equal) + (error 'author-not-trusted + :key-user-name name + :key-id id :gpg-err nil)) + (add-key (&rest rest) + :report "Add to package supplier list" + (pushnew (list id name) *trusted-uids*))) + (return)))))) @@ -221,22 +221,22 @@ (destructuring-bind (response headers stream) (url-connection (concatenate 'string url ".asc")) (unwind-protect - (if (= response 200) - (let ((data (make-string (parse-integer - (cdr (assoc :content-length headers)) - :junk-allowed t)))) - (read-sequence data stream) - (verify-gpg-signature/string data file-name)) - (error 'download-error :url (concatenate 'string url ".asc") - :response response)) + (if (= response 200) + (let ((data (make-string (parse-integer + (cdr (assoc :content-length headers)) + :junk-allowed t)))) + (read-sequence data stream) + (verify-gpg-signature/string data file-name)) + (error 'download-error :url (concatenate 'string url ".asc") + :response response)) (close stream)))) -(defun where () +(defun where () (format t "Install where?~%") (loop for (source system name) in *locations* - for i from 1 - do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%" - i name system source)) + for i from 1 + do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%" + i name system source)) (format t " --> ") (force-output) (let ((response (read))) (when (> response 0) @@ -247,104 +247,104 @@ (ensure-directories-exist source ) (ensure-directories-exist system ) (let* ((tar - (with-output-to-string (o) - (or - (sb-ext:run-program #-darwin "tar" - #+darwin "gnutar" - (list "-C" (namestring source) - "-xzvf" (namestring packagename)) - :output o - :search t - :wait t) - (error "can't untar")))) - (dummy (princ tar)) - (pos-slash (position #\/ tar)) - (*default-pathname-defaults* - (merge-pathnames - (make-pathname :directory - `(:relative ,(subseq tar 0 pos-slash))) - source))) + (with-output-to-string (o) + (or + (sb-ext:run-program #-darwin "tar" + #+darwin "gnutar" + (list "-C" (namestring source) + "-xzvf" (namestring packagename)) + :output o + :search t + :wait t) + (error "can't untar")))) + (dummy (princ tar)) + (pos-slash (position #\/ tar)) + (*default-pathname-defaults* + (merge-pathnames + (make-pathname :directory + `(:relative ,(subseq tar 0 pos-slash))) + source))) (declare (ignore dummy)) (loop for asd in (directory - (make-pathname :name :wild :type "asd")) - do (let ((target (merge-pathnames - (make-pathname :name (pathname-name asd) - :type (pathname-type asd)) - system))) - (when (probe-file target) - (sb-posix:unlink target)) - (sb-posix:symlink asd target)) - collect (pathname-name asd)))) + (make-pathname :name :wild :type "asd")) + do (let ((target (merge-pathnames + (make-pathname :name (pathname-name asd) + :type (pathname-type asd)) + system))) + (when (probe-file target) + (sb-posix:unlink target)) + (sb-posix:symlink asd target)) + collect (pathname-name asd)))) (defvar *temporary-files*) (defun temp-file-name (p) (let* ((pos-slash (position #\/ p :from-end t)) - (pos-dot (position #\. p :start (or pos-slash 0)))) + (pos-dot (position #\. p :start (or pos-slash 0)))) (merge-pathnames (make-pathname :name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot) :type "asdf-install-tmp")))) - + ;; this is the external entry point (defun install (&rest packages) (let ((*temporary-files* nil) - (*trusted-uids* - (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*))) - (when (probe-file p) - (with-open-file (f p) (read f)))))) + (*trusted-uids* + (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*))) + (when (probe-file p) + (with-open-file (f p) (read f)))))) (unwind-protect - (destructuring-bind (source system name) (where) - (labels ((one-iter (packages) - (dolist (asd - (loop for p in (mapcar 'string packages) - unless (probe-file p) - do (let ((tmp (temp-file-name p))) - (pushnew tmp *temporary-files*) - (download-files-for-package p tmp) - (setf p tmp)) - end - do (format t "Installing ~A in ~A,~A~%" - p source system) - append (install-package source system p))) - (handler-bind - ((asdf:missing-dependency - (lambda (c) - (format t - "Downloading package ~A, required by ~A~%" - (asdf::missing-requires c) - (asdf:component-name - (asdf::missing-required-by c))) - (one-iter (list - (symbol-name - (asdf::missing-requires c)))) - (invoke-restart 'retry)))) - (loop - (multiple-value-bind (ret restart-p) - (with-simple-restart - (retry "Retry installation") - (asdf:operate 'asdf:load-op asd)) - (unless restart-p (return)))))))) - (one-iter packages))) + (destructuring-bind (source system name) (where) + (labels ((one-iter (packages) + (dolist (asd + (loop for p in (mapcar 'string packages) + unless (probe-file p) + do (let ((tmp (temp-file-name p))) + (pushnew tmp *temporary-files*) + (download-files-for-package p tmp) + (setf p tmp)) + end + do (format t "Installing ~A in ~A,~A~%" + p source system) + append (install-package source system p))) + (handler-bind + ((asdf:missing-dependency + (lambda (c) + (format t + "Downloading package ~A, required by ~A~%" + (asdf::missing-requires c) + (asdf:component-name + (asdf::missing-required-by c))) + (one-iter (list + (symbol-name + (asdf::missing-requires c)))) + (invoke-restart 'retry)))) + (loop + (multiple-value-bind (ret restart-p) + (with-simple-restart + (retry "Retry installation") + (asdf:operate 'asdf:load-op asd)) + (unless restart-p (return)))))))) + (one-iter packages))) (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*))) - (ensure-directories-exist p) - (with-open-file (out p :direction :output :if-exists :supersede) - (with-standard-io-syntax - (prin1 *trusted-uids* out)))) + (ensure-directories-exist p) + (with-open-file (out p :direction :output :if-exists :supersede) + (with-standard-io-syntax + (prin1 *trusted-uids* out)))) (dolist (l *temporary-files*) - (when (probe-file l) (delete-file l)))))) + (when (probe-file l) (delete-file l)))))) (defun uninstall (system &optional (prompt t)) (let* ((asd (asdf:system-definition-pathname system)) - (system (asdf:find-system system)) - (dir (asdf::pathname-sans-name+type - (asdf::resolve-symlinks asd)))) + (system (asdf:find-system system)) + (dir (asdf::pathname-sans-name+type + (asdf::resolve-symlinks asd)))) (when (or (not prompt) - (y-or-n-p - "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?" - system asd dir)) + (y-or-n-p + "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?" + system asd dir)) (delete-file asd) (asdf:run-shell-command "rm -r ~A" (namestring dir))))) - + ;;; some day we will also do UPGRADE, but we need to sort out version ;;; numbering a bit better first diff --git a/contrib/asdf-stub.lisp b/contrib/asdf-stub.lisp index 4864c69..d084d72 100644 --- a/contrib/asdf-stub.lisp +++ b/contrib/asdf-stub.lisp @@ -12,15 +12,15 @@ (with-open-file (s *system-stub* :direction :output :if-exists :error) (print '(unless (member "ASDF" *modules* :test #'string=) - (load (merge-pathnames "asdf/asdf.fasl" (truename (sb-ext:posix-getenv "SBCL_HOME"))))) - s) + (load (merge-pathnames "asdf/asdf.fasl" (truename (sb-ext:posix-getenv "SBCL_HOME"))))) + s) ;; This addition to *central-registry* allows us to find contribs ;; even if the user has frobbed the original contents. (print `(let ((asdf:*central-registry* (cons (merge-pathnames "systems/" - (truename (sb-ext:posix-getenv "SBCL_HOME"))) - asdf:*central-registry*))) - (asdf::module-provide-asdf ,*system*)) - s)) + (truename (sb-ext:posix-getenv "SBCL_HOME"))) + asdf:*central-registry*))) + (asdf::module-provide-asdf ,*system*)) + s)) (compile-file *system-stub*) (delete-file *system-stub*) diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp index a987d9f..f328354 100644 --- a/contrib/asdf/asdf.lisp +++ b/contrib/asdf/asdf.lisp @@ -39,67 +39,67 @@ (defpackage #:asdf (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command - #:system-definition-pathname #:find-component ; miscellaneous - #:hyperdocumentation #:hyperdoc - - #:compile-op #:load-op #:load-source-op #:test-system-version - #:test-op - #:operation ; operations - #:feature ; sort-of operation - #:version ; metaphorically sort-of an operation - - #:input-files #:output-files #:perform ; operation methods - #:operation-done-p #:explain - - #:component #:source-file - #:c-source-file #:cl-source-file #:java-source-file - #:static-file - #:doc-file - #:html-file - #:text-file - #:source-file-type - #:module ; components - #:system - #:unix-dso - - #:module-components ; component accessors - #:component-pathname - #:component-relative-pathname - #:component-name - #:component-version - #:component-parent - #:component-property - #:component-system - - #:component-depends-on - - #:system-description - #:system-long-description - #:system-author - #:system-maintainer - #:system-license - - #:operation-on-warnings - #:operation-on-failure - - ;#:*component-parent-pathname* - #:*system-definition-search-functions* - #:*central-registry* ; variables - #:*compile-file-warnings-behaviour* - #:*compile-file-failure-behaviour* - #:*asdf-revision* - - #:operation-error #:compile-failed #:compile-warned #:compile-error - #:error-component #:error-operation - #:system-definition-error - #:missing-component - #:missing-dependency - #:circular-dependency ; errors - - #:retry - #:accept ; restarts - - ) + #:system-definition-pathname #:find-component ; miscellaneous + #:hyperdocumentation #:hyperdoc + + #:compile-op #:load-op #:load-source-op #:test-system-version + #:test-op + #:operation ; operations + #:feature ; sort-of operation + #:version ; metaphorically sort-of an operation + + #:input-files #:output-files #:perform ; operation methods + #:operation-done-p #:explain + + #:component #:source-file + #:c-source-file #:cl-source-file #:java-source-file + #:static-file + #:doc-file + #:html-file + #:text-file + #:source-file-type + #:module ; components + #:system + #:unix-dso + + #:module-components ; component accessors + #:component-pathname + #:component-relative-pathname + #:component-name + #:component-version + #:component-parent + #:component-property + #:component-system + + #:component-depends-on + + #:system-description + #:system-long-description + #:system-author + #:system-maintainer + #:system-license + + #:operation-on-warnings + #:operation-on-failure + + ;#:*component-parent-pathname* + #:*system-definition-search-functions* + #:*central-registry* ; variables + #:*compile-file-warnings-behaviour* + #:*compile-file-failure-behaviour* + #:*asdf-revision* + + #:operation-error #:compile-failed #:compile-warned #:compile-error + #:error-component #:error-operation + #:system-definition-error + #:missing-component + #:missing-dependency + #:circular-dependency ; errors + + #:retry + #:accept ; restarts + + ) (:use :cl)) #+nil @@ -109,13 +109,13 @@ (in-package #:asdf) (defvar *asdf-revision* (let* ((v "$Revision$") - (colon (or (position #\: v) -1)) - (dot (position #\. v))) - (and v colon dot - (list (parse-integer v :start (1+ colon) - :junk-allowed t) - (parse-integer v :start (1+ dot) - :junk-allowed t))))) + (colon (or (position #\: v) -1)) + (dot (position #\. v))) + (and v colon dot + (list (parse-integer v :start (1+ colon) + :junk-allowed t) + (parse-integer v :start (1+ dot) + :junk-allowed t))))) (defvar *compile-file-warnings-behaviour* :warn) (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) @@ -133,8 +133,8 @@ and NIL NAME and TYPE components" (make-pathname :name nil :type nil :defaults pathname)) -(define-modify-macro appendf (&rest args) - append "Append onto list") +(define-modify-macro appendf (&rest args) + append "Append onto list") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; classes, condiitons @@ -152,7 +152,7 @@ and NIL NAME and TYPE components" ((format-control :initarg :format-control :reader format-control) (format-arguments :initarg :format-arguments :reader format-arguments)) (:report (lambda (c s) - (apply #'format s (format-control c) (format-arguments c))))) + (apply #'format s (format-control c) (format-arguments c))))) (define-condition circular-dependency (system-definition-error) ((components :initarg :components :reader circular-dependency-components))) @@ -169,15 +169,15 @@ and NIL NAME and TYPE components" ((component :reader error-component :initarg :component) (operation :reader error-operation :initarg :operation)) (:report (lambda (c s) - (format s "~@" - (error-operation c) (error-component c))))) + (format s "~@" + (error-operation c) (error-component c))))) (define-condition compile-error (operation-error) ()) (define-condition compile-failed (compile-error) ()) (define-condition compile-warned (compile-error) ()) (defclass component () ((name :accessor component-name :initarg :name :documentation - "Component name: designator for a string composed of portable pathname characters") + "Component name: designator for a string composed of portable pathname characters") (version :accessor component-version :initarg :version) (in-order-to :initform nil :initarg :in-order-to) ;;; XXX crap name @@ -191,17 +191,17 @@ and NIL NAME and TYPE components" ;; it to default in funky ways if not supplied (relative-pathname :initarg :pathname) (operation-times :initform (make-hash-table ) - :accessor component-operation-times) + :accessor component-operation-times) ;; XXX we should provide some atomic interface for updating the ;; component properties (properties :accessor component-properties :initarg :properties - :initform nil))) + :initform nil))) ;;;; methods: conditions (defmethod print-object ((c missing-dependency) s) (format s "~@<~A, required by ~A~@:>" - (call-next-method c nil) (missing-required-by c))) + (call-next-method c nil) (missing-required-by c))) (defun sysdef-error (format &rest arguments) (error 'formatted-system-definition-error :format-control format :format-arguments arguments)) @@ -212,14 +212,14 @@ and NIL NAME and TYPE components" (format s "~@" - (missing-requires c) - (missing-version c) - (when (missing-parent c) - (component-name (missing-parent c))))) + (missing-requires c) + (missing-version c) + (when (missing-parent c) + (component-name (missing-parent c))))) (defgeneric component-system (component) (:documentation "Find the top-level system containing COMPONENT")) - + (defmethod component-system ((component component)) (aif (component-parent component) (component-system it) @@ -235,8 +235,8 @@ and NIL NAME and TYPE components" ;; what to do if we can't satisfy a dependency of one of this module's ;; components. This allows a limited form of conditional processing (if-component-dep-fails :initform :fail - :accessor module-if-component-dep-fails - :initarg :if-component-dep-fails) + :accessor module-if-component-dep-fails + :initarg :if-component-dep-fails) (default-component-class :accessor module-default-component-class :initform 'cl-source-file :initarg :default-component-class))) @@ -250,7 +250,7 @@ and NIL NAME and TYPE components" (defgeneric component-relative-pathname (component) (:documentation "Extracts the relative pathname applicable for a particular component.")) - + (defmethod component-relative-pathname ((component module)) (or (slot-value component 'relative-pathname) (make-pathname @@ -271,9 +271,9 @@ and NIL NAME and TYPE components" (defmethod (setf component-property) (new-value (c component) property) (let ((a (assoc property (slot-value c 'properties) :test #'equal))) (if a - (setf (cdr a) new-value) - (setf (slot-value c 'properties) - (acons property new-value (slot-value c 'properties)))))) + (setf (cdr a) new-value) + (setf (slot-value c 'properties) + (acons property new-value (slot-value c 'properties)))))) (defclass system (module) ((description :accessor system-description :initarg :description) @@ -291,13 +291,13 @@ and NIL NAME and TYPE components" (nreverse (let ((list nil) (start 0) (words 0) end) (loop - (when (and max (>= words (1- max))) - (return (cons (subseq string start) list))) - (setf end (position-if #'is-ws string :start start)) - (push (subseq string start end) list) - (incf words) - (unless end (return list)) - (setf start (1+ end))))))) + (when (and max (>= words (1- max))) + (return (cons (subseq string start) list))) + (setf end (position-if #'is-ws string :start start)) + (push (subseq string start end) list) + (incf words) + (unless end (return list)) + (setf start (1+ end))))))) (defgeneric version-satisfies (component version)) @@ -305,17 +305,17 @@ and NIL NAME and TYPE components" (unless (and version (slot-boundp c 'version)) (return-from version-satisfies t)) (let ((x (mapcar #'parse-integer - (split (component-version c) nil '(#\.)))) - (y (mapcar #'parse-integer - (split version nil '(#\.))))) + (split (component-version c) nil '(#\.)))) + (y (mapcar #'parse-integer + (split version nil '(#\.))))) (labels ((bigger (x y) - (cond ((not y) t) - ((not x) nil) - ((> (car x) (car y)) t) - ((= (car x) (car y)) - (bigger (cdr x) (cdr y)))))) + (cond ((not y) t) + ((not x) nil) + ((> (car x) (car y)) t) + ((= (car x) (car y)) + (bigger (cdr x) (cdr y)))))) (and (= (car x) (car y)) - (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) + (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; finding systems @@ -336,8 +336,8 @@ and NIL NAME and TYPE components" (defun system-definition-pathname (system) (some (lambda (x) (funcall x system)) - *system-definition-search-functions*)) - + *system-definition-search-functions*)) + (defvar *central-registry* '(*default-pathname-defaults* #+nil "/home/dan/src/sourceforge/cclan/asdf/systems/" @@ -347,41 +347,41 @@ and NIL NAME and TYPE components" (let ((name (coerce-name system))) (block nil (dolist (dir *central-registry*) - (let* ((defaults (eval dir)) - (file (and defaults - (make-pathname - :defaults defaults :version :newest - :name name :type "asd" :case :local)))) - (if (and file (probe-file file)) - (return file))))))) + (let* ((defaults (eval dir)) + (file (and defaults + (make-pathname + :defaults defaults :version :newest + :name name :type "asd" :case :local)))) + (if (and file (probe-file file)) + (return file))))))) (defun find-system (name &optional (error-p t)) (let* ((name (coerce-name name)) - (in-memory (gethash name *defined-systems*)) - (on-disk (system-definition-pathname name))) + (in-memory (gethash name *defined-systems*)) + (on-disk (system-definition-pathname name))) (when (and on-disk - (or (not in-memory) - (< (car in-memory) (file-write-date on-disk)))) + (or (not in-memory) + (< (car in-memory) (file-write-date on-disk)))) (let ((*package* (make-package (gensym #.(package-name *package*)) - :use '(:cl :asdf)))) - (format *verbose-out* - "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" - ;; FIXME: This wants to be (ENOUGH-NAMESTRING - ;; ON-DISK), but CMUCL barfs on that. - on-disk - *package*) - (load on-disk))) + :use '(:cl :asdf)))) + (format *verbose-out* + "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" + ;; FIXME: This wants to be (ENOUGH-NAMESTRING + ;; ON-DISK), but CMUCL barfs on that. + on-disk + *package*) + (load on-disk))) (let ((in-memory (gethash name *defined-systems*))) (if in-memory - (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) - (cdr in-memory)) - (if error-p (error 'missing-component :requires name)))))) + (progn (if on-disk (setf (car in-memory) (file-write-date on-disk))) + (cdr in-memory)) + (if error-p (error 'missing-component :requires name)))))) (defun register-system (name system) (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) (setf (gethash (coerce-name name) *defined-systems*) - (cons (get-universal-time) system))) + (cons (get-universal-time) system))) (defun system-registered-p (name) (gethash (coerce-name name) *defined-systems*)) @@ -397,9 +397,9 @@ system.")) (defmethod find-component ((module module) name &optional version) (if (slot-boundp module 'components) (let ((m (find name (module-components module) - :test #'equal :key #'component-name))) - (if (and m (version-satisfies m version)) m)))) - + :test #'equal :key #'component-name))) + (if (and m (version-satisfies m version)) m)))) + ;;; a component with no parent is a system (defmethod find-component ((module (eql nil)) name &optional version) @@ -426,16 +426,16 @@ system.")) (defmethod component-relative-pathname ((component source-file)) (let* ((*default-pathname-defaults* (component-parent-pathname component)) - (name-type - (make-pathname - :name (component-name component) - :type (source-file-type component - (component-system component))))) + (name-type + (make-pathname + :name (component-name component) + :type (source-file-type component + (component-system component))))) (if (slot-value component 'relative-pathname) - (merge-pathnames - (slot-value component 'relative-pathname) - name-type) - name-type))) + (merge-pathnames + (slot-value component 'relative-pathname) + name-type) + name-type))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; operations @@ -445,7 +445,7 @@ system.")) (defclass operation () ((forced :initform nil :initarg :force :accessor operation-forced) (original-initargs :initform nil :initarg :original-initargs - :accessor operation-original-initargs) + :accessor operation-original-initargs) (visited-nodes :initform nil :accessor operation-visited-nodes) (visiting-nodes :initform nil :accessor operation-visiting-nodes) (parent :initform nil :initarg :parent :accessor operation-parent))) @@ -456,8 +456,8 @@ system.")) (prin1 (operation-original-initargs o) stream)))) (defmethod shared-initialize :after ((operation operation) slot-names - &key force - &allow-other-keys) + &key force + &allow-other-keys) (declare (ignore slot-names force)) ;; empty method to disable initarg validity checking ) @@ -482,22 +482,22 @@ system.")) (defun make-sub-operation (c o dep-c dep-o) (let* ((args (copy-list (operation-original-initargs o))) - (force-p (getf args :force))) + (force-p (getf args :force))) ;; note explicit comparison with T: any other non-NIL force value ;; (e.g. :recursive) will pass through (cond ((and (null (component-parent c)) - (null (component-parent dep-c)) - (not (eql c dep-c))) - (when (eql force-p t) - (setf (getf args :force) nil)) - (apply #'make-instance dep-o - :parent o - :original-initargs args args)) - ((subtypep (type-of o) dep-o) - o) - (t - (apply #'make-instance dep-o - :parent o :original-initargs args args))))) + (null (component-parent dep-c)) + (not (eql c dep-c))) + (when (eql force-p t) + (setf (getf args :force) nil)) + (apply #'make-instance dep-o + :parent o + :original-initargs args args)) + ((subtypep (type-of o) dep-o) + o) + (t + (apply #'make-instance dep-o + :parent o :original-initargs args args))))) (defgeneric visit-component (operation component data)) @@ -505,14 +505,14 @@ system.")) (defmethod visit-component ((o operation) (c component) data) (unless (component-visited-p o c) (push (cons (node-for o c) data) - (operation-visited-nodes (operation-ancestor o))))) + (operation-visited-nodes (operation-ancestor o))))) (defgeneric component-visited-p (operation component)) (defmethod component-visited-p ((o operation) (c component)) (assoc (node-for o c) - (operation-visited-nodes (operation-ancestor o)) - :test 'equal)) + (operation-visited-nodes (operation-ancestor o)) + :test 'equal)) (defgeneric (setf visiting-component) (new-value operation component)) @@ -522,69 +522,69 @@ system.")) (defmethod (setf visiting-component) (new-value (o operation) (c component)) (let ((node (node-for o c)) - (a (operation-ancestor o))) + (a (operation-ancestor o))) (if new-value - (pushnew node (operation-visiting-nodes a) :test 'equal) - (setf (operation-visiting-nodes a) - (remove node (operation-visiting-nodes a) :test 'equal))))) + (pushnew node (operation-visiting-nodes a) :test 'equal) + (setf (operation-visiting-nodes a) + (remove node (operation-visiting-nodes a) :test 'equal))))) (defgeneric component-visiting-p (operation component)) (defmethod component-visiting-p ((o operation) (c component)) (let ((node (cons o c))) (member node (operation-visiting-nodes (operation-ancestor o)) - :test 'equal))) + :test 'equal))) (defgeneric component-depends-on (operation component)) (defmethod component-depends-on ((o operation) (c component)) (cdr (assoc (class-name (class-of o)) - (slot-value c 'in-order-to)))) + (slot-value c 'in-order-to)))) (defgeneric component-self-dependencies (operation component)) (defmethod component-self-dependencies ((o operation) (c component)) (let ((all-deps (component-depends-on o c))) (remove-if-not (lambda (x) - (member (component-name c) (cdr x) :test #'string=)) - all-deps))) - + (member (component-name c) (cdr x) :test #'string=)) + all-deps))) + (defmethod input-files ((operation operation) (c component)) (let ((parent (component-parent c)) - (self-deps (component-self-dependencies operation c))) + (self-deps (component-self-dependencies operation c))) (if self-deps - (mapcan (lambda (dep) - (destructuring-bind (op name) dep - (output-files (make-instance op) - (find-component parent name)))) - self-deps) - ;; no previous operations needed? I guess we work with the - ;; original source file, then - (list (component-pathname c))))) + (mapcan (lambda (dep) + (destructuring-bind (op name) dep + (output-files (make-instance op) + (find-component parent name)))) + self-deps) + ;; no previous operations needed? I guess we work with the + ;; original source file, then + (list (component-pathname c))))) (defmethod input-files ((operation operation) (c module)) nil) (defmethod operation-done-p ((o operation) (c component)) (let ((out-files (output-files o c)) - (in-files (input-files o c))) + (in-files (input-files o c))) (cond ((and (not in-files) (not out-files)) - ;; arbitrary decision: an operation that uses nothing to - ;; produce nothing probably isn't doing much - t) - ((not out-files) - (let ((op-done - (gethash (type-of o) - (component-operation-times c)))) - (and op-done - (>= op-done - (or (apply #'max - (mapcar #'file-write-date in-files)) 0))))) - ((not in-files) nil) - (t - (and - (every #'probe-file out-files) - (> (apply #'min (mapcar #'file-write-date out-files)) - (apply #'max (mapcar #'file-write-date in-files)) )))))) + ;; arbitrary decision: an operation that uses nothing to + ;; produce nothing probably isn't doing much + t) + ((not out-files) + (let ((op-done + (gethash (type-of o) + (component-operation-times c)))) + (and op-done + (>= op-done + (or (apply #'max + (mapcar #'file-write-date in-files)) 0))))) + ((not in-files) nil) + (t + (and + (every #'probe-file out-files) + (> (apply #'min (mapcar #'file-write-date out-files)) + (apply #'max (mapcar #'file-write-date in-files)) )))))) ;;; So you look at this code and think "why isn't it a bunch of ;;; methods". And the answer is, because standard method combination @@ -596,81 +596,81 @@ system.")) (defmethod traverse ((operation operation) (c component)) (let ((forced nil)) (labels ((do-one-dep (required-op required-c required-v) - (let* ((dep-c (or (find-component - (component-parent c) - ;; XXX tacky. really we should build the - ;; in-order-to slot with canonicalized - ;; names instead of coercing this late - (coerce-name required-c) required-v) - (error 'missing-dependency :required-by c - :version required-v - :requires required-c))) - (op (make-sub-operation c operation dep-c required-op))) - (traverse op dep-c))) - (do-dep (op dep) - (cond ((eq op 'feature) - (or (member (car dep) *features*) - (error 'missing-dependency :required-by c - :requires (car dep) :version nil))) - (t - (dolist (d dep) + (let* ((dep-c (or (find-component + (component-parent c) + ;; XXX tacky. really we should build the + ;; in-order-to slot with canonicalized + ;; names instead of coercing this late + (coerce-name required-c) required-v) + (error 'missing-dependency :required-by c + :version required-v + :requires required-c))) + (op (make-sub-operation c operation dep-c required-op))) + (traverse op dep-c))) + (do-dep (op dep) + (cond ((eq op 'feature) + (or (member (car dep) *features*) + (error 'missing-dependency :required-by c + :requires (car dep) :version nil))) + (t + (dolist (d dep) (cond ((consp d) (assert (string-equal (symbol-name (first d)) "VERSION")) (appendf forced - (do-one-dep op (second d) (third d)))) + (do-one-dep op (second d) (third d)))) (t (appendf forced (do-one-dep op d nil))))))))) (aif (component-visited-p operation c) - (return-from traverse - (if (cdr it) (list (cons 'pruned-op c)) nil))) + (return-from traverse + (if (cdr it) (list (cons 'pruned-op c)) nil))) ;; dependencies (if (component-visiting-p operation c) - (error 'circular-dependency :components (list c))) + (error 'circular-dependency :components (list c))) (setf (visiting-component operation c) t) (loop for (required-op . deps) in (component-depends-on operation c) - do (do-dep required-op deps)) + do (do-dep required-op deps)) ;; constituent bits (let ((module-ops - (when (typep c 'module) - (let ((at-least-one nil) - (forced nil) - (error nil)) - (loop for kid in (module-components c) - do (handler-case - (appendf forced (traverse operation kid )) - (missing-dependency (condition) - (if (eq (module-if-component-dep-fails c) :fail) - (error condition)) - (setf error condition)) - (:no-error (c) - (declare (ignore c)) - (setf at-least-one t)))) - (when (and (eq (module-if-component-dep-fails c) :try-next) - (not at-least-one)) - (error error)) - forced)))) - ;; now the thing itself - (when (or forced module-ops - (not (operation-done-p operation c)) - (let ((f (operation-forced (operation-ancestor operation)))) - (and f (or (not (consp f)) - (member (component-name - (operation-ancestor operation)) - (mapcar #'coerce-name f) - :test #'string=))))) - (let ((do-first (cdr (assoc (class-name (class-of operation)) - (slot-value c 'do-first))))) - (loop for (required-op . deps) in do-first - do (do-dep required-op deps))) - (setf forced (append (delete 'pruned-op forced :key #'car) - (delete 'pruned-op module-ops :key #'car) - (list (cons operation c)))))) + (when (typep c 'module) + (let ((at-least-one nil) + (forced nil) + (error nil)) + (loop for kid in (module-components c) + do (handler-case + (appendf forced (traverse operation kid )) + (missing-dependency (condition) + (if (eq (module-if-component-dep-fails c) :fail) + (error condition)) + (setf error condition)) + (:no-error (c) + (declare (ignore c)) + (setf at-least-one t)))) + (when (and (eq (module-if-component-dep-fails c) :try-next) + (not at-least-one)) + (error error)) + forced)))) + ;; now the thing itself + (when (or forced module-ops + (not (operation-done-p operation c)) + (let ((f (operation-forced (operation-ancestor operation)))) + (and f (or (not (consp f)) + (member (component-name + (operation-ancestor operation)) + (mapcar #'coerce-name f) + :test #'string=))))) + (let ((do-first (cdr (assoc (class-name (class-of operation)) + (slot-value c 'do-first))))) + (loop for (required-op . deps) in do-first + do (do-dep required-op deps))) + (setf forced (append (delete 'pruned-op forced :key #'car) + (delete 'pruned-op module-ops :key #'car) + (list (cons operation c)))))) (setf (visiting-component operation c) nil) (visit-component operation c (and forced t)) forced))) - + (defmethod perform ((operation operation) (c source-file)) (sysdef-error @@ -689,43 +689,43 @@ system.")) (defclass compile-op (operation) ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) (on-warnings :initarg :on-warnings :accessor operation-on-warnings - :initform *compile-file-warnings-behaviour*) + :initform *compile-file-warnings-behaviour*) (on-failure :initarg :on-failure :accessor operation-on-failure - :initform *compile-file-failure-behaviour*))) + :initform *compile-file-failure-behaviour*))) (defmethod perform :before ((operation compile-op) (c source-file)) (map nil #'ensure-directories-exist (output-files operation c))) (defmethod perform :after ((operation operation) (c component)) (setf (gethash (type-of operation) (component-operation-times c)) - (get-universal-time))) + (get-universal-time))) ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy (defmethod perform ((operation compile-op) (c cl-source-file)) #-:broken-fasl-loader (let ((source-file (component-pathname c)) - (output-file (car (output-files operation c)))) + (output-file (car (output-files operation c)))) (multiple-value-bind (output warnings-p failure-p) - (compile-file source-file - :output-file output-file) + (compile-file source-file + :output-file output-file) ;(declare (ignore output)) (when warnings-p - (case (operation-on-warnings operation) - (:warn (warn - "~@" - operation c)) - (:error (error 'compile-warned :component c :operation operation)) - (:ignore nil))) + (case (operation-on-warnings operation) + (:warn (warn + "~@" + operation c)) + (:error (error 'compile-warned :component c :operation operation)) + (:ignore nil))) (when failure-p - (case (operation-on-failure operation) - (:warn (warn - "~@" - operation c)) - (:error (error 'compile-failed :component c :operation operation)) - (:ignore nil))) + (case (operation-on-failure operation) + (:warn (warn + "~@" + operation c)) + (:error (error 'compile-failed :component c :operation operation)) + (:ignore nil))) (unless output - (error 'compile-error :component c :operation operation))))) + (error 'compile-error :component c :operation operation))))) (defmethod output-files ((operation compile-op) (c cl-source-file)) #-:broken-fasl-loader (list (compile-file-pathname (component-pathname c))) @@ -784,8 +784,8 @@ system.")) (defmethod operation-done-p ((o load-source-op) (c source-file)) (if (or (not (component-property c 'last-loaded-as-source)) - (> (file-write-date (component-pathname c)) - (component-property c 'last-loaded-as-source))) + (> (file-write-date (component-pathname c)) + (component-property c 'last-loaded-as-source))) nil t)) (defclass test-op (operation) ()) @@ -798,35 +798,35 @@ system.")) (defun operate (operation-class system &rest args) (let* ((op (apply #'make-instance operation-class - :original-initargs args args)) - (*verbose-out* - (if (getf args :verbose t) - *trace-output* - (make-broadcast-stream))) - (system (if (typep system 'component) system (find-system system))) - (steps (traverse op system))) + :original-initargs args args)) + (*verbose-out* + (if (getf args :verbose t) + *trace-output* + (make-broadcast-stream))) + (system (if (typep system 'component) system (find-system system))) + (steps (traverse op system))) (with-compilation-unit () (loop for (op . component) in steps do - (loop - (restart-case - (progn (perform op component) - (return)) - (retry () - :report - (lambda (s) - (format s "~@" - op component))) - (accept () - :report - (lambda (s) - (format s - "~@" + op component))) + (accept () + :report + (lambda (s) + (format s + "~@" - op component)) - (setf (gethash (type-of op) - (component-operation-times component)) - (get-universal-time)) - (return)))))))) + op component)) + (setf (gethash (type-of op) + (component-operation-times component)) + (get-universal-time)) + (return)))))))) (defun oos (&rest args) "Alias of OPERATE function" @@ -837,169 +837,169 @@ system.")) (defun remove-keyword (key arglist) (labels ((aux (key arglist) - (cond ((null arglist) nil) - ((eq key (car arglist)) (cddr arglist)) - (t (cons (car arglist) (cons (cadr arglist) - (remove-keyword - key (cddr arglist)))))))) + (cond ((null arglist) nil) + ((eq key (car arglist)) (cddr arglist)) + (t (cons (car arglist) (cons (cadr arglist) + (remove-keyword + key (cddr arglist)))))))) (aux key arglist))) (defmacro defsystem (name &body options) (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options (let ((component-options (remove-keyword :class options))) `(progn - ;; system must be registered before we parse the body, otherwise - ;; we recur when trying to find an existing system of the same name - ;; to reuse options (e.g. pathname) from - (let ((s (system-registered-p ',name))) - (cond ((and s (eq (type-of (cdr s)) ',class)) - (setf (car s) (get-universal-time))) - (s - #+clisp - (sysdef-error "Cannot redefine the existing system ~A with a different class" s) - #-clisp - (change-class (cdr s) ',class)) - (t - (register-system (quote ,name) - (make-instance ',class :name ',name))))) - (parse-component-form nil (apply - #'list - :module (coerce-name ',name) - :pathname - (or ,pathname - (pathname-sans-name+type - (resolve-symlinks *load-truename*)) - *default-pathname-defaults*) - ',component-options)))))) - + ;; system must be registered before we parse the body, otherwise + ;; we recur when trying to find an existing system of the same name + ;; to reuse options (e.g. pathname) from + (let ((s (system-registered-p ',name))) + (cond ((and s (eq (type-of (cdr s)) ',class)) + (setf (car s) (get-universal-time))) + (s + #+clisp + (sysdef-error "Cannot redefine the existing system ~A with a different class" s) + #-clisp + (change-class (cdr s) ',class)) + (t + (register-system (quote ,name) + (make-instance ',class :name ',name))))) + (parse-component-form nil (apply + #'list + :module (coerce-name ',name) + :pathname + (or ,pathname + (pathname-sans-name+type + (resolve-symlinks *load-truename*)) + *default-pathname-defaults*) + ',component-options)))))) + (defun class-for-type (parent type) - (let ((class - (find-class - (or (find-symbol (symbol-name type) *package*) - (find-symbol (symbol-name type) #.(package-name *package*))) - nil))) + (let ((class + (find-class + (or (find-symbol (symbol-name type) *package*) + (find-symbol (symbol-name type) #.(package-name *package*))) + nil))) (or class - (and (eq type :file) - (or (module-default-component-class parent) - (find-class 'cl-source-file))) - (sysdef-error "~@" type)))) + (and (eq type :file) + (or (module-default-component-class parent) + (find-class 'cl-source-file))) + (sysdef-error "~@" type)))) (defun maybe-add-tree (tree op1 op2 c) "Add the node C at /OP1/OP2 in TREE, unless it's there already. Returns the new tree (which probably shares structure with the old one)" (let ((first-op-tree (assoc op1 tree))) (if first-op-tree - (progn - (aif (assoc op2 (cdr first-op-tree)) - (if (find c (cdr it)) - nil - (setf (cdr it) (cons c (cdr it)))) - (setf (cdr first-op-tree) - (acons op2 (list c) (cdr first-op-tree)))) - tree) - (acons op1 (list (list op2 c)) tree)))) - + (progn + (aif (assoc op2 (cdr first-op-tree)) + (if (find c (cdr it)) + nil + (setf (cdr it) (cons c (cdr it)))) + (setf (cdr first-op-tree) + (acons op2 (list c) (cdr first-op-tree)))) + tree) + (acons op1 (list (list op2 c)) tree)))) + (defun union-of-dependencies (&rest deps) (let ((new-tree nil)) (dolist (dep deps) (dolist (op-tree dep) - (dolist (op (cdr op-tree)) - (dolist (c (cdr op)) - (setf new-tree - (maybe-add-tree new-tree (car op-tree) (car op) c)))))) + (dolist (op (cdr op-tree)) + (dolist (c (cdr op)) + (setf new-tree + (maybe-add-tree new-tree (car op-tree) (car op) c)))))) new-tree)) (defun remove-keys (key-names args) (loop for ( name val ) on args by #'cddr - unless (member (symbol-name name) key-names - :key #'symbol-name :test 'equal) - append (list name val))) + unless (member (symbol-name name) key-names + :key #'symbol-name :test 'equal) + append (list name val))) (defvar *serial-depends-on*) (defun parse-component-form (parent options) (destructuring-bind - (type name &rest rest &key - ;; the following list of keywords is reproduced below in the - ;; remove-keys form. important to keep them in sync - components pathname default-component-class - perform explain output-files operation-done-p - depends-on serial in-order-to - ;; list ends - &allow-other-keys) options + (type name &rest rest &key + ;; the following list of keywords is reproduced below in the + ;; remove-keys form. important to keep them in sync + components pathname default-component-class + perform explain output-files operation-done-p + depends-on serial in-order-to + ;; list ends + &allow-other-keys) options (check-component-input type name depends-on components in-order-to) (let* ((other-args (remove-keys - '(components pathname default-component-class - perform explain output-files operation-done-p - depends-on serial in-order-to) - rest)) - (ret - (or (find-component parent name) - (make-instance (class-for-type parent type))))) + '(components pathname default-component-class + perform explain output-files operation-done-p + depends-on serial in-order-to) + rest)) + (ret + (or (find-component parent name) + (make-instance (class-for-type parent type))))) (when (boundp '*serial-depends-on*) - (setf depends-on - (concatenate 'list *serial-depends-on* depends-on))) + (setf depends-on + (concatenate 'list *serial-depends-on* depends-on))) (apply #'reinitialize-instance - ret - :name (coerce-name name) - :pathname pathname - :parent parent - other-args) + ret + :name (coerce-name name) + :pathname pathname + :parent parent + other-args) (when (typep ret 'module) - (setf (module-default-component-class ret) - (or default-component-class - (and (typep parent 'module) - (module-default-component-class parent)))) - (let ((*serial-depends-on* nil)) - (setf (module-components ret) - (loop for c-form in components - for c = (parse-component-form ret c-form) - collect c - if serial - do (push (component-name c) *serial-depends-on*))))) - + (setf (module-default-component-class ret) + (or default-component-class + (and (typep parent 'module) + (module-default-component-class parent)))) + (let ((*serial-depends-on* nil)) + (setf (module-components ret) + (loop for c-form in components + for c = (parse-component-form ret c-form) + collect c + if serial + do (push (component-name c) *serial-depends-on*))))) + (setf (slot-value ret 'in-order-to) - (union-of-dependencies - in-order-to - `((compile-op (compile-op ,@depends-on)) - (load-op (load-op ,@depends-on)))) - (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on)))) - + (union-of-dependencies + in-order-to + `((compile-op (compile-op ,@depends-on)) + (load-op (load-op ,@depends-on)))) + (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on)))) + (loop for (n v) in `((perform ,perform) (explain ,explain) - (output-files ,output-files) - (operation-done-p ,operation-done-p)) - do (map 'nil - ;; this is inefficient as most of the stored - ;; methods will not be for this particular gf n - ;; But this is hardly performance-critical - (lambda (m) (remove-method (symbol-function n) m)) - (component-inline-methods ret)) - when v - do (destructuring-bind (op qual (o c) &body body) v - (pushnew - (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret))) - ,@body)) - (component-inline-methods ret)))) + (output-files ,output-files) + (operation-done-p ,operation-done-p)) + do (map 'nil + ;; this is inefficient as most of the stored + ;; methods will not be for this particular gf n + ;; But this is hardly performance-critical + (lambda (m) (remove-method (symbol-function n) m)) + (component-inline-methods ret)) + when v + do (destructuring-bind (op qual (o c) &body body) v + (pushnew + (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret))) + ,@body)) + (component-inline-methods ret)))) ret))) (defun check-component-input (type name depends-on components in-order-to) "A partial test of the values of a component." (unless (listp depends-on) (sysdef-error-component ":depends-on must be a list." - type name depends-on)) + type name depends-on)) (unless (listp components) (sysdef-error-component ":components must be NIL or a list of components." - type name components)) + type name components)) (unless (and (listp in-order-to) (listp (car in-order-to))) (sysdef-error-component ":in-order-to must be NIL or a list of components." - type name in-order-to))) + type name in-order-to))) (defun sysdef-error-component (msg type name value) (sysdef-error (concatenate 'string msg - "~&The value specified for ~(~A~) ~A is ~W") - type name value)) + "~&The value specified for ~(~A~) ~A is ~W") + type name value)) (defun resolve-symlinks (path) #-allegro (truename path) @@ -1020,36 +1020,36 @@ output to *verbose-out*. Returns the shell's exit code." (format *verbose-out* "; $ ~A~%" command) #+sbcl (sb-impl::process-exit-code - (sb-ext:run-program + (sb-ext:run-program "/bin/sh" (list "-c" command) :input nil :output *verbose-out*)) - + #+(or cmu scl) (ext:process-exit-code - (ext:run-program + (ext:run-program "/bin/sh" (list "-c" command) :input nil :output *verbose-out*)) #+allegro (excl:run-shell-command command :input nil :output *verbose-out*) - + #+lispworks (system:call-system-showing-output command :shell-type "/bin/sh" :output-stream *verbose-out*) - - #+clisp ;XXX not exactly *verbose-out*, I know + + #+clisp ;XXX not exactly *verbose-out*, I know (ext:run-shell-command command :output :terminal :wait t) #+openmcl (nth-value 1 - (ccl:external-process-status - (ccl:run-program "/bin/sh" (list "-c" command) - :input nil :output *verbose-out* - :wait t))) + (ccl:external-process-status + (ccl:run-program "/bin/sh" (list "-c" command) + :input nil :output *verbose-out* + :wait t))) #+ecl ;; courtesy of Juan Jose Garcia Ripoll (si:system command) #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl) @@ -1077,26 +1077,26 @@ output to *verbose-out*. Returns the shell's exit code." (defun module-provide-asdf (name) (handler-bind ((style-warning #'muffle-warning)) (let* ((*verbose-out* (make-broadcast-stream)) - (system (asdf:find-system name nil))) - (when system - (asdf:operate 'asdf:load-op name) - t)))) + (system (asdf:find-system name nil))) + (when system + (asdf:operate 'asdf:load-op name) + t)))) (pushnew '(merge-pathnames "systems/" (truename (sb-ext:posix-getenv "SBCL_HOME"))) *central-registry*) - + (pushnew '(merge-pathnames "site-systems/" (truename (sb-ext:posix-getenv "SBCL_HOME"))) *central-registry*) - + (pushnew '(merge-pathnames ".sbcl/systems/" (user-homedir-pathname)) *central-registry*) - + (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)) (provide 'asdf) diff --git a/contrib/code-extras.lisp b/contrib/code-extras.lisp index cc14fcf..c81b365 100644 --- a/contrib/code-extras.lisp +++ b/contrib/code-extras.lisp @@ -9,11 +9,11 @@ #+nil (defun replace (..) (cond ((and (typep seq1 'simple-vector) - (typep seq2 'simple-vector)) - (%replace-vector-vector ..)) - ((and (typep seq1 'simple-string) - (typep seq2 'simple-string)) - (%replace-vector-vector ..)) - (t - ..))) + (typep seq2 'simple-vector)) + (%replace-vector-vector ..)) + ((and (typep seq1 'simple-string) + (typep seq2 'simple-string)) + (%replace-vector-vector ..)) + (t + ..))) diff --git a/contrib/compiler-extras.lisp b/contrib/compiler-extras.lisp index 4e68bd2..140b563 100644 --- a/contrib/compiler-extras.lisp +++ b/contrib/compiler-extras.lisp @@ -29,53 +29,53 @@ #+nil ; not tested yet.. (deftransform replace ((seq1 seq2 &key (start1 0) end1 (start2 0) end2) - (vector vector &key - (:start1 index) (:end1 (or index null)) - (:start2 index) (:end2 (or index null))) - * - ;; This is potentially an awfully big transform - ;; (if things like (EQ SEQ1 SEQ2) aren't known - ;; at runtime). We need to make it available - ;; inline, since otherwise there's no way to do - ;; it efficiently on all array types, but it - ;; probably doesn't belong inline all the time. - :policy (> speed (1+ space))) + (vector vector &key + (:start1 index) (:end1 (or index null)) + (:start2 index) (:end2 (or index null))) + * + ;; This is potentially an awfully big transform + ;; (if things like (EQ SEQ1 SEQ2) aren't known + ;; at runtime). We need to make it available + ;; inline, since otherwise there's no way to do + ;; it efficiently on all array types, but it + ;; probably doesn't belong inline all the time. + :policy (> speed (1+ space))) "open code" (let ((et1 (upgraded-element-type-specifier-or-give-up seq1)) - (et2 (upgraded-element-type-specifier-or-give-up seq2))) + (et2 (upgraded-element-type-specifier-or-give-up seq2))) `(let* ((n-copied (min (- end1 start1) (- end2 start2))) - (effective-end1 (+ start1 n-copied))) + (effective-end1 (+ start1 n-copied))) (if (eq seq1 seq2) - (with-array-data ((seq seq1) - (start (min start1 start2)) - (end (max end1 end2))) - (declare (type (simple-array ,et1 1) seq)) - (if (<= start1 start2) - (let ((index2 start2)) - (declare (type index index2)) - (loop for index1 of-type index - from start1 below effective-end1 do - (setf (aref seq index1) - (aref seq index2)) - (incf index2))) - (let ((index2 (1- end2))) - (declare (type (integer -2 #.most-positive-fixnum) index2)) - (loop for index1 of-type index-or-minus-1 - from (1- effective-end1) downto start1 do - (setf (aref seq index1) - (aref seq index2)) - (decf index2))))) - (with-array-data ((seq1 seq1) (start1 start1) (end1 end1)) - (declare (type (simple-array ,et1 1) seq1)) - (with-array-data ((seq2 seq2) (start2 start2) (end2 end2)) - (declare (type (simple-array ,et2 1) seq2)) + (with-array-data ((seq seq1) + (start (min start1 start2)) + (end (max end1 end2))) + (declare (type (simple-array ,et1 1) seq)) + (if (<= start1 start2) + (let ((index2 start2)) + (declare (type index index2)) + (loop for index1 of-type index + from start1 below effective-end1 do + (setf (aref seq index1) + (aref seq index2)) + (incf index2))) + (let ((index2 (1- end2))) + (declare (type (integer -2 #.most-positive-fixnum) index2)) + (loop for index1 of-type index-or-minus-1 + from (1- effective-end1) downto start1 do + (setf (aref seq index1) + (aref seq index2)) + (decf index2))))) + (with-array-data ((seq1 seq1) (start1 start1) (end1 end1)) + (declare (type (simple-array ,et1 1) seq1)) + (with-array-data ((seq2 seq2) (start2 start2) (end2 end2)) + (declare (type (simple-array ,et2 1) seq2)) (let ((index2 start2)) - (declare (type index index2)) - (loop for index1 of-type index - from start1 below effective-end1 do - (setf (aref seq index1) - (aref seq index2)) - (incf index2)))))) + (declare (type index index2)) + (loop for index1 of-type index + from start1 below effective-end1 do + (setf (aref seq index1) + (aref seq index2)) + (incf index2)))))) seq1))) ;;; Boyer-Moore search for strings. @@ -89,64 +89,64 @@ ;;; * investigate whether we can make this work with a hashtable and a ;;; default for "not in pattern" (deftransform search ((pattern text) - (simple-base-string simple-base-string)) + (simple-base-string simple-base-string)) (unless (constant-lvar-p pattern) (give-up-ir1-transform)) (let* ((pattern (lvar-value pattern)) - (bad-character (make-array 256 :element-type 'fixnum :initial-element (length pattern))) - (temp (make-array (length pattern) :element-type 'fixnum)) - (good-suffix (make-array (length pattern) :element-type 'fixnum :initial-element (1- (length pattern))))) + (bad-character (make-array 256 :element-type 'fixnum :initial-element (length pattern))) + (temp (make-array (length pattern) :element-type 'fixnum)) + (good-suffix (make-array (length pattern) :element-type 'fixnum :initial-element (1- (length pattern))))) (dotimes (i (1- (length pattern))) (setf (aref bad-character (char-code (aref pattern i))) - (- (length pattern) 1 i))) + (- (length pattern) 1 i))) (setf (aref temp (1- (length pattern))) (length pattern)) (loop with g = (1- (length pattern)) - with f = (1- (length pattern)) ; XXXXXX? - for i downfrom (- (length pattern) 2) above 0 - if (and (> i g) - (< (aref temp (- (+ i (length pattern)) 1 f)) (- i g))) - do (setf (aref temp i) (aref temp (- (+ i (length pattern)) 1 f))) - else - do (progn - (when (< i g) - (setf g i)) - (setf f i) - (do () - ((not - (and (>= g 0) - (char= (aref pattern g) - (aref pattern (- (+ g (length pattern)) 1 f)))))) - (decf g)) - (setf (aref temp i) (- f g)))) + with f = (1- (length pattern)) ; XXXXXX? + for i downfrom (- (length pattern) 2) above 0 + if (and (> i g) + (< (aref temp (- (+ i (length pattern)) 1 f)) (- i g))) + do (setf (aref temp i) (aref temp (- (+ i (length pattern)) 1 f))) + else + do (progn + (when (< i g) + (setf g i)) + (setf f i) + (do () + ((not + (and (>= g 0) + (char= (aref pattern g) + (aref pattern (- (+ g (length pattern)) 1 f)))))) + (decf g)) + (setf (aref temp i) (- f g)))) (loop with j = 0 - for i downfrom (1- (length pattern)) to -1 - if (or (= i -1) (= (aref temp i) (1+ i))) - do (do () - ((>= j (- (length pattern) 1 i))) - (when (= (aref good-suffix j) (length pattern)) - (setf (aref good-suffix j) (- (length pattern) 1 i))) - (incf j))) + for i downfrom (1- (length pattern)) to -1 + if (or (= i -1) (= (aref temp i) (1+ i))) + do (do () + ((>= j (- (length pattern) 1 i))) + (when (= (aref good-suffix j) (length pattern)) + (setf (aref good-suffix j) (- (length pattern) 1 i))) + (incf j))) (loop for i from 0 below (1- (length pattern)) - do (setf (aref good-suffix (- (length pattern) 1 (aref temp i))) - (- (length pattern) 1 i))) + do (setf (aref good-suffix (- (length pattern) 1 (aref temp i))) + (- (length pattern) 1 i))) `(let ((good-suffix ,good-suffix) - (bad-character ,bad-character)) + (bad-character ,bad-character)) (declare (optimize speed (safety 0))) (block search - (do ((j 0)) - ((> j (- (length text) (length pattern)))) - (declare (fixnum j)) - (do ((i (1- (length pattern)) (1- i))) - ((< i 0) (return-from search j)) - (declare (fixnum i)) - (when (char/= (aref pattern i) (aref text (+ i j))) - (incf j (max (aref good-suffix i) - (+ (- (aref bad-character (char-code (aref text (+ i j)))) - (length pattern)) - (1+ i)))) - (return)))))))) + (do ((j 0)) + ((> j (- (length text) (length pattern)))) + (declare (fixnum j)) + (do ((i (1- (length pattern)) (1- i))) + ((< i 0) (return-from search j)) + (declare (fixnum i)) + (when (char/= (aref pattern i) (aref text (+ i j))) + (incf j (max (aref good-suffix i) + (+ (- (aref bad-character (char-code (aref text (+ i j)))) + (length pattern)) + (1+ i)))) + (return)))))))) diff --git a/contrib/sb-aclrepl/debug.lisp b/contrib/sb-aclrepl/debug.lisp index 76eef97..c42cff1 100644 --- a/contrib/sb-aclrepl/debug.lisp +++ b/contrib/sb-aclrepl/debug.lisp @@ -10,56 +10,56 @@ ;;; all? Seems not. #+ignore (declaim (special - sb-debug::*debug-command-level* - sb-debug::*real-stack-top* sb-debug::*stack-top* - sb-debug::*stack-top-hint* sb-debug::*current-frame* - sb-debug::*flush-debug-errors*)) + sb-debug::*debug-command-level* + sb-debug::*real-stack-top* sb-debug::*stack-top* + sb-debug::*stack-top-hint* sb-debug::*current-frame* + sb-debug::*flush-debug-errors*)) (defun debug-loop () (let* ((sb-debug::*debug-command-level* (1+ sb-debug::*debug-command-level*)) - (sb-debug::*real-stack-top* (sb-di:top-frame)) - (sb-debug::*stack-top* (or sb-debug::*stack-top-hint* - sb-debug::*real-stack-top*)) - (sb-debug::*stack-top-hint* nil) - (sb-debug::*current-frame* sb-debug::*stack-top*) - (continuable (continuable-break-p))) + (sb-debug::*real-stack-top* (sb-di:top-frame)) + (sb-debug::*stack-top* (or sb-debug::*stack-top-hint* + sb-debug::*real-stack-top*)) + (sb-debug::*stack-top-hint* nil) + (sb-debug::*current-frame* sb-debug::*stack-top*) + (continuable (continuable-break-p))) (handler-bind ((sb-di:debug-condition - (lambda (condition) - (princ condition sb-debug::*debug-io*) - (sb-int:/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER") - (throw 'debug-loop-catcher nil)))) + (lambda (condition) + (princ condition sb-debug::*debug-io*) + (sb-int:/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER") + (throw 'debug-loop-catcher nil)))) (fresh-line) ;;(sb-debug::print-frame-call sb-debug::*current-frame* :verbosity 2) (loop ;; only valid to way to exit invoke-debugger is by a restart (catch 'debug-loop-catcher - (handler-bind ((error (lambda (condition) - (when sb-debug::*flush-debug-errors* - (clear-input *debug-io*) - (princ condition) - ;; FIXME: Doing input on *DEBUG-IO* - ;; and output on T seems broken. - (format t - "~&error flushed (because ~ - ~S is set)" - 'sb-debug::*flush-debug-errors*) - (sb-int:/show0 "throwing DEBUG-LOOP-CATCHER") - (throw 'debug-loop-catcher nil))))) - - (if (zerop *break-level*) ; restart added by SBCL - (repl :continuable continuable) - (let ((level *break-level*)) - (with-simple-restart - (abort "~@" - level) - (let ((sb-debug::*debug-restarts* (compute-restarts))) - (repl :continuable continuable))))))) + (handler-bind ((error (lambda (condition) + (when sb-debug::*flush-debug-errors* + (clear-input *debug-io*) + (princ condition) + ;; FIXME: Doing input on *DEBUG-IO* + ;; and output on T seems broken. + (format t + "~&error flushed (because ~ + ~S is set)" + 'sb-debug::*flush-debug-errors*) + (sb-int:/show0 "throwing DEBUG-LOOP-CATCHER") + (throw 'debug-loop-catcher nil))))) + + (if (zerop *break-level*) ; restart added by SBCL + (repl :continuable continuable) + (let ((level *break-level*)) + (with-simple-restart + (abort "~@" + level) + (let ((sb-debug::*debug-restarts* (compute-restarts))) + (repl :continuable continuable))))))) (throw 'repl-catcher (values :debug :exit)) )))) (defun continuable-break-p () (when (eq 'continue - (restart-name (car (compute-restarts)))) + (restart-name (car (compute-restarts)))) t)) #+ignore @@ -80,7 +80,7 @@ (let ((old-hook *debugger-hook*)) (when old-hook (let ((*debugger-hook* nil)) - (funcall old-hook condition old-hook)))) + (funcall old-hook condition old-hook)))) (%debugger condition)) #+ignore @@ -94,13 +94,13 @@ #+ignore (defun print-condition-type (condition) (format *output* "~& [Condition type: ~A]~%" (type-of condition))) - + #+ignore (defun %debugger (condition) (print-condition condition) (print-condition-type condition) (princ #\newline *output*) - (print-restarts) + (print-restarts) (acldebug-loop)) @@ -108,10 +108,10 @@ (defun acldebug-loop () (let ((continuable (continuable-break-p))) (if continuable - (aclrepl :continuable t) - (let ((level *break-level*)) - (with-simple-restart - (abort "~@" level) - (loop - (repl))))))) + (aclrepl :continuable t) + (let ((level *break-level*)) + (with-simple-restart + (abort "~@" level) + (loop + (repl))))))) diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp index c13f686..6c3e196 100644 --- a/contrib/sb-aclrepl/inspect.lisp +++ b/contrib/sb-aclrepl/inspect.lisp @@ -13,19 +13,19 @@ (defconstant +default-inspect-length+ 20)) (defstruct (%inspect (:constructor make-inspect) - (:conc-name inspect-)) + (:conc-name inspect-)) ;; stack of parents of inspected object - object-stack + object-stack ;; a stack of indices of parent object components select-stack) ;; FIXME - raw mode isn't currently used in object display (defparameter *current-inspect* nil - "current inspect") + "current inspect") (defparameter *inspect-raw* nil "Raw mode for object display.") (defparameter *inspect-length* +default-inspect-length+ - "maximum number of components to print") + "maximum number of components to print") (defparameter *skip-address-display* nil "Skip displaying addresses of objects.") @@ -60,14 +60,14 @@ The commands are: (defun inspector-fun (object input-stream output-stream) (let ((*current-inspect* nil) - (*inspect-raw* nil) - (*inspect-length* *inspect-length*) - (*skip-address-display* nil)) + (*inspect-raw* nil) + (*inspect-length* *inspect-length*) + (*skip-address-display* nil)) (setq *current-inspect* (make-inspect)) (reset-stack object "(inspect ...)") (redisplay output-stream) (let ((*input* input-stream) - (*output* output-stream)) + (*output* output-stream)) (repl :inspect t))) (values)) @@ -77,9 +77,9 @@ The commands are: (unless *current-inspect* (setq *current-inspect* (make-inspect))) (istep-dispatch args - (first args) - (when (first args) (read-from-string (first args))) - stream)) + (first args) + (when (first args) (read-from-string (first args))) + stream)) (defun istep-dispatch (args option-string option stream) (cond @@ -92,7 +92,7 @@ The commands are: ((string= "+" option-string) (istep-cmd-inspect-new-form (read-from-string (second args)) stream)) ((or (string= "<" option-string) - (string= ">" option-string)) + (string= ">" option-string)) (istep-cmd-select-parent-component option-string stream)) ((string-equal "set" option-string) (istep-cmd-set (second args) (third args) stream)) @@ -105,13 +105,13 @@ The commands are: ((string-equal "skip" option-string) (istep-cmd-skip (second args) stream)) ((string-equal "tree" option-string) - (istep-cmd-tree stream)) + (istep-cmd-tree stream)) ((string-equal "print" option-string) (istep-cmd-print (second args) stream)) ((string-equal "slot" option-string) (istep-cmd-select-component (read-from-string (second args)) stream)) ((or (symbolp option) - (integerp option)) + (integerp option)) (istep-cmd-select-component option stream)) (t (istep-cmd-set-stack option stream)))) @@ -149,9 +149,9 @@ The commands are: (cond ((> (length (inspect-object-stack *current-inspect*)) 1) (setf (inspect-object-stack *current-inspect*) - (cdr (inspect-object-stack *current-inspect*))) + (cdr (inspect-object-stack *current-inspect*))) (setf (inspect-select-stack *current-inspect*) - (cdr (inspect-select-stack *current-inspect*))) + (cdr (inspect-select-stack *current-inspect*))) (redisplay stream)) ((stack) (output-inspect-note stream "Object has no parent")) @@ -168,24 +168,24 @@ The commands are: (defun istep-cmd-select-parent-component (option stream) (if (stack) (if (eql (length (stack)) 1) - (output-inspect-note stream "Object does not have a parent") - (let ((parent (second (stack))) - (id (car (inspect-select-stack *current-inspect*)))) - (multiple-value-bind (position parts) - (find-part-id parent id) - (let ((new-position (if (string= ">" option) - (1+ position) - (1- position)))) - (if (< -1 new-position (parts-count parts)) - (let* ((value (component-at parts new-position))) - (setf (car (inspect-object-stack *current-inspect*)) - value) - (setf (car (inspect-select-stack *current-inspect*)) - (id-at parts new-position)) - (redisplay stream)) - (output-inspect-note stream - "Parent has no selectable component indexed by ~d" - new-position)))))) + (output-inspect-note stream "Object does not have a parent") + (let ((parent (second (stack))) + (id (car (inspect-select-stack *current-inspect*)))) + (multiple-value-bind (position parts) + (find-part-id parent id) + (let ((new-position (if (string= ">" option) + (1+ position) + (1- position)))) + (if (< -1 new-position (parts-count parts)) + (let* ((value (component-at parts new-position))) + (setf (car (inspect-object-stack *current-inspect*)) + value) + (setf (car (inspect-select-stack *current-inspect*)) + (id-at parts new-position)) + (redisplay stream)) + (output-inspect-note stream + "Parent has no selectable component indexed by ~d" + new-position)))))) (no-object-msg stream))) (defun istep-cmd-set-raw (option-string stream) @@ -209,17 +209,17 @@ The commands are: (defun istep-cmd-skip (option-string stream) (if option-string (let ((len (read-from-string option-string))) - (if (and (integerp len) (>= len 0)) - (redisplay stream len) - (output-inspect-note stream "Skip length invalid"))) + (if (and (integerp len) (>= len 0)) + (redisplay stream len) + (output-inspect-note stream "Skip length invalid"))) (output-inspect-note stream "Skip length missing"))) (defun istep-cmd-print (option-string stream) (if option-string (let ((len (read-from-string option-string))) - (if (and (integerp len) (plusp len)) - (setq *inspect-length* len) - (output-inspect-note stream "Cannot set print limit to ~A~%" len))) + (if (and (integerp len) (plusp len)) + (setq *inspect-length* len) + (output-inspect-note stream "Cannot set print limit to ~A~%" len))) (output-inspect-note stream "Print length missing"))) (defun select-description (select) @@ -236,67 +236,67 @@ The commands are: (defun istep-cmd-tree (stream) (let ((stack (inspect-object-stack *current-inspect*))) (if stack - (progn - (output-inspect-note stream "The current object is:") - (dotimes (i (length stack)) - (output-inspect-note - stream "~A, ~A" - (inspected-description (nth i stack)) - (select-description - (nth i (inspect-select-stack *current-inspect*)))))) - (no-object-msg stream)))) + (progn + (output-inspect-note stream "The current object is:") + (dotimes (i (length stack)) + (output-inspect-note + stream "~A, ~A" + (inspected-description (nth i stack)) + (select-description + (nth i (inspect-select-stack *current-inspect*)))))) + (no-object-msg stream)))) (defun istep-cmd-set (id-string value-string stream) (if (stack) (let ((id (when id-string (read-from-string id-string)))) - (multiple-value-bind (position parts) - (find-part-id (car (stack)) id) - (if parts - (if position - (when value-string - (let ((new-value (eval (read-from-string value-string)))) - (let ((result (set-component-value (car (stack)) - id - new-value - (component-at - parts position)))) - (typecase result - (string - (output-inspect-note stream result)) - (t - (redisplay stream)))))) - (output-inspect-note - stream - "Object has no selectable component named by ~A" id)) - (output-inspect-note stream - "Object has no selectable components")))) + (multiple-value-bind (position parts) + (find-part-id (car (stack)) id) + (if parts + (if position + (when value-string + (let ((new-value (eval (read-from-string value-string)))) + (let ((result (set-component-value (car (stack)) + id + new-value + (component-at + parts position)))) + (typecase result + (string + (output-inspect-note stream result)) + (t + (redisplay stream)))))) + (output-inspect-note + stream + "Object has no selectable component named by ~A" id)) + (output-inspect-note stream + "Object has no selectable components")))) (no-object-msg stream))) (defun istep-cmd-select-component (id stream) (if (stack) (multiple-value-bind (position parts) - (find-part-id (car (stack)) id) - (cond - ((integerp position) - (let* ((value (component-at parts position))) - (cond ((eq value *inspect-unbound-object-marker*) - (output-inspect-note stream "That slot is unbound")) - (t - (push value (inspect-object-stack *current-inspect*)) - (push id (inspect-select-stack *current-inspect*)) - (redisplay stream))))) - ((null parts) - (output-inspect-note stream "Object does not contain any subobjects")) - (t - (typecase id - (symbol - (output-inspect-note - stream "Object has no selectable component named ~A" - id)) - (integer - (output-inspect-note - stream "Object has no selectable component indexed by ~d" - id)))))) + (find-part-id (car (stack)) id) + (cond + ((integerp position) + (let* ((value (component-at parts position))) + (cond ((eq value *inspect-unbound-object-marker*) + (output-inspect-note stream "That slot is unbound")) + (t + (push value (inspect-object-stack *current-inspect*)) + (push id (inspect-select-stack *current-inspect*)) + (redisplay stream))))) + ((null parts) + (output-inspect-note stream "Object does not contain any subobjects")) + (t + (typecase id + (symbol + (output-inspect-note + stream "Object has no selectable component named ~A" + id)) + (integer + (output-inspect-note + stream "Object has no selectable component indexed by ~d" + id)))))) (no-object-msg stream))) (defun istep-cmd-set-stack (form stream) @@ -310,8 +310,8 @@ The commands are: (defun display-current (s length skip) (if (stack) (let ((inspected (car (stack)))) - (setq cl:* inspected) - (display-inspect inspected s length skip)) + (setq cl:* inspected) + (display-inspect inspected s length skip)) (no-object-msg s))) @@ -325,16 +325,16 @@ The commands are: (fresh-line stream) (format stream "~A" (inspected-description object)) (unless (or *skip-address-display* - (eq object *inspect-unbound-object-marker*) - (characterp object) (typep object 'fixnum)) + (eq object *inspect-unbound-object-marker*) + (characterp object) (typep object 'fixnum)) (write-string " at #x" stream) (format stream (n-word-bits-hex-format) - (logand (sb-kernel:get-lisp-obj-address object) - (lognot sb-vm:lowtag-mask)))) + (logand (sb-kernel:get-lisp-obj-address object) + (lognot sb-vm:lowtag-mask)))) (dotimes (i count) (fresh-line stream) (display-labeled-element (elt elements i) (elt labels i) stream)))) - + (defun array-label-p (label) (and (consp label) (stringp (cdr label)) @@ -346,10 +346,10 @@ The commands are: (defun hex-label-p (label &optional width) (and (consp label) (case width - (32 (eq (cdr label) :hex32)) - (64 (eq (cdr label) :hex64)) - (t (or (eq (cdr label) :hex32) - (eq (cdr label) :hex64)))))) + (32 (eq (cdr label) :hex32)) + (64 (eq (cdr label) :hex64)) + (t (or (eq (cdr label) :hex32) + (eq (cdr label) :hex64)))))) (defun display-labeled-element (element label stream) (cond @@ -359,12 +359,12 @@ The commands are: (format stream "tail-> ~A" (inspected-description element))) ((named-or-array-label-p label) (format stream - (if (array-label-p label) - "~4,' D ~A-> ~A" - "~4,' D ~16,1,1,'-A> ~A") - (car label) - (format nil "~A " (cdr label)) - (inspected-description element))) + (if (array-label-p label) + "~4,' D ~A-> ~A" + "~4,' D ~16,1,1,'-A> ~A") + (car label) + (format nil "~A " (cdr label)) + (inspected-description element))) ((hex-label-p label 32) (format stream "~4,' D-> #x~8,'0X" (car label) element)) ((hex-label-p label 64) @@ -401,59 +401,59 @@ The commands are: Returns (VALUES POSITION PARTS). POSITION is NIL if the id is invalid or not found." (let* ((parts (inspected-parts object)) - (name (if (symbolp id) (symbol-name id) id))) + (name (if (symbolp id) (symbol-name id) id))) (values (cond ((and (numberp id) - (< -1 id (parts-count parts)) - (not (eq (parts-seq-type parts) :bignum))) - id) + (< -1 id (parts-count parts)) + (not (eq (parts-seq-type parts) :bignum))) + id) (t - (case (parts-seq-type parts) - (:named - (position name (the list (parts-components parts)) - :key #'car :test #'string-equal)) - ((:dotted-list :cyclic-list) - (when (string-equal name "tail") - (1- (parts-count parts))))))) + (case (parts-seq-type parts) + (:named + (position name (the list (parts-components parts)) + :key #'car :test #'string-equal)) + ((:dotted-list :cyclic-list) + (when (string-equal name "tail") + (1- (parts-count parts))))))) parts))) (defun component-at (parts position) (let ((count (parts-count parts)) - (components (parts-components parts))) + (components (parts-components parts))) (when (< -1 position count) (case (parts-seq-type parts) - (:dotted-list - (if (= position (1- count)) - (cdr (last components)) - (elt components position))) - (:cyclic-list - (if (= position (1- count)) - components - (elt components position))) - (:named - (cdr (elt components position))) - (:array - (aref (the array components) position)) - (:bignum - (bignum-component-at components position)) - (t - (elt components position)))))) + (:dotted-list + (if (= position (1- count)) + (cdr (last components)) + (elt components position))) + (:cyclic-list + (if (= position (1- count)) + components + (elt components position))) + (:named + (cdr (elt components position))) + (:array + (aref (the array components) position)) + (:bignum + (bignum-component-at components position)) + (t + (elt components position)))))) (defun id-at (parts position) (let ((count (parts-count parts))) (when (< -1 position count) (case (parts-seq-type parts) - ((:dotted-list :cyclic-list) - (if (= position (1- count)) - :tail - position)) - (:array - (array-index-string position parts)) - (:named - (car (elt (parts-components parts) position))) - (t - position))))) + ((:dotted-list :cyclic-list) + (if (= position (1- count)) + :tail + position)) + (:array + (array-index-string position parts)) + (:named + (car (elt (parts-components parts) position))) + (t + position))))) (defun inspected-elements (object &optional length (skip 0)) "Returns elements of an object that have been trimmed and labeled based on @@ -464,29 +464,29 @@ This function may return an ELEMENT-COUNT of up to (+ 3 length) which would include an :ellipses at the beginning, :ellipses at the end, and the last element." (let* ((parts (inspected-parts object)) - (print-length (if length length (parts-count parts))) - (last-part (last-part parts)) - (last-requested (last-requested parts print-length skip)) - (element-count (compute-elements-count parts print-length skip)) - (first-to (if (first-element-ellipses-p parts skip) 1 0)) - (elements (when (plusp element-count) (make-array element-count))) - (labels (when (plusp element-count) (make-array element-count)))) + (print-length (if length length (parts-count parts))) + (last-part (last-part parts)) + (last-requested (last-requested parts print-length skip)) + (element-count (compute-elements-count parts print-length skip)) + (first-to (if (first-element-ellipses-p parts skip) 1 0)) + (elements (when (plusp element-count) (make-array element-count))) + (labels (when (plusp element-count) (make-array element-count)))) (when (plusp element-count) ;; possible first ellipses (when (first-element-ellipses-p parts skip) - (set-element-values elements labels 0 nil :ellipses)) + (set-element-values elements labels 0 nil :ellipses)) ;; main elements (do* ((i 0 (1+ i))) - ((> i (- last-requested skip))) - (set-element elements labels parts (+ i first-to) (+ i skip))) + ((> i (- last-requested skip))) + (set-element elements labels parts (+ i first-to) (+ i skip))) ;; last parts value if needed - (when (< last-requested last-part) - (set-element elements labels parts (- element-count 1) last-part)) + (when (< last-requested last-part) + (set-element elements labels parts (- element-count 1) last-part)) ;; ending ellipses or next to last parts value if needed - (when (< last-requested (1- last-part)) - (if (= last-requested (- last-part 2)) - (set-element elements labels parts (- element-count 2) (1- last-part)) - (set-element-values elements labels (- element-count 2) nil :ellipses)))) + (when (< last-requested (1- last-part)) + (if (= last-requested (- last-part 2)) + (set-element elements labels parts (- element-count 2) (1- last-part)) + (set-element-values elements labels (- element-count 2) nil :ellipses)))) (values elements labels element-count))) (defun last-requested (parts print skip) @@ -496,22 +496,22 @@ and the last element." (1- (parts-count parts))) (defun compute-elements-count (parts length skip) - "Compute the number of elements in parts given the print length and skip." + "Compute the number of elements in parts given the print length and skip." (let ((element-count (min (parts-count parts) length - (max 0 (- (parts-count parts) skip))))) + (max 0 (- (parts-count parts) skip))))) (when (and (plusp (parts-count parts)) (plusp skip)) ; starting ellipses (incf element-count)) (when (< (last-requested parts length skip) - (last-part parts)) ; last value - (incf element-count) + (last-part parts)) ; last value + (incf element-count) (when (< (last-requested parts length skip) - (1- (last-part parts))) ; ending ellipses - (incf element-count))) + (1- (last-part parts))) ; ending ellipses + (incf element-count))) element-count)) (defun set-element (elements labels parts to-index from-index) (set-element-values elements labels to-index (component-at parts from-index) - (label-at parts from-index))) + (label-at parts from-index))) (defun set-element-values (elements labels index element label) (setf (aref elements index) element) @@ -528,23 +528,23 @@ position with the label if the label is a string." ((stringp id) (cons position id)) ((eq (parts-seq-type parts) :bignum) - (cons position (case sb-vm::n-word-bits - (32 :hex32) - (64 :hex64)))) + (cons position (case sb-vm::n-word-bits + (32 :hex32) + (64 :hex64)))) (t - id)))) + id)))) (defun array-index-string (index parts) "Formats an array index in row major format." (let ((rev-dimensions (parts-seq-hint parts))) (if (null rev-dimensions) - "[]" - (let ((list nil)) - (dolist (dim rev-dimensions) - (multiple-value-bind (q r) (floor index dim) - (setq index q) - (push r list))) - (format nil "[~W~{,~W~}]" (car list) (cdr list)))))) + "[]" + (let ((list nil)) + (dolist (dim rev-dimensions) + (multiple-value-bind (q r) (floor index dim) + (setq index q) + (push r list))) + (format nil "[~W~{,~W~}]" (car list) (cdr list)))))) ;;; INSPECTED-DESCRIPTION @@ -576,23 +576,23 @@ position with the label if the label is a string." (defmethod inspected-description ((object vector)) (declare (vector object)) (format nil "a ~:[~;displaced ~]vector (~W)" - (and (sb-kernel:array-header-p object) - (sb-kernel:%array-displaced-p object)) - (length object))) + (and (sb-kernel:array-header-p object) + (sb-kernel:%array-displaced-p object)) + (length object))) (defmethod inspected-description ((object simple-vector)) (declare (simple-vector object)) (format nil "a simple ~A vector (~D)" - (array-element-type object) - (length object))) + (array-element-type object) + (length object))) (defmethod inspected-description ((object array)) (declare (array object)) (format nil "~:[A displaced~;An~] array of ~A with dimensions ~W" - (and (sb-kernel:array-header-p object) - (sb-kernel:%array-displaced-p object)) - (array-element-type object) - (array-dimensions object))) + (and (sb-kernel:array-header-p object) + (sb-kernel:%array-displaced-p object)) + (array-element-type object) + (array-dimensions object))) (defun simple-cons-pair-p (object) (atom (cdr object))) @@ -606,26 +606,26 @@ position with the label if the label is a string." "Returns (VALUES LENGTH LIST-TYPE) where length is the number of cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" (do ((length 1 (1+ length)) - (lst (cdr object) (cdr lst))) - ((or (not (consp lst)) - (eq object lst)) - (cond - ((null lst) - (values length :normal)) - ((atom lst) - (values length :dotted)) - ((eq object lst) - (values length :cyclic)))) + (lst (cdr object) (cdr lst))) + ((or (not (consp lst)) + (eq object lst)) + (cond + ((null lst) + (values length :normal)) + ((atom lst) + (values length :dotted)) + ((eq object lst) + (values length :cyclic)))) ;; nothing to do in body )) (defun inspected-description-of-nontrivial-list (object) (multiple-value-bind (length list-type) (cons-safe-length object) (format nil "a ~A list with ~D element~:*~P~A" - (string-downcase (symbol-name list-type)) length - (ecase list-type - ((:dotted :cyclic) "+tail") - (:normal ""))))) + (string-downcase (symbol-name list-type)) length + (ecase list-type + ((:dotted :cyclic) "+tail") + (:normal ""))))) (defun n-word-bits-hex-format () (case sb-vm::n-word-bits @@ -646,21 +646,21 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" (defun description-maybe-internals (fmt objects internal-fmt &rest args) (let ((base (apply #'format nil fmt objects))) (if *skip-address-display* - base - (concatenate 'string - base " " (apply #'format nil internal-fmt args))))) - + base + (concatenate 'string + base " " (apply #'format nil internal-fmt args))))) + (defmethod inspected-description ((object double-float)) (let ((start (round (* 2 sb-vm::n-word-bits) 8))) (description-maybe-internals "double-float ~W" (list object) - "[#~A ~A]" - (ref32-hexstr object (+ start 4)) - (ref32-hexstr object start)))) + "[#~A ~A]" + (ref32-hexstr object (+ start 4)) + (ref32-hexstr object start)))) (defmethod inspected-description ((object single-float)) (description-maybe-internals "single-float ~W" (list object) - "[#x~A]" - (ref32-hexstr object (round sb-vm::n-word-bits 8)))) + "[#x~A]" + (ref32-hexstr object (round sb-vm::n-word-bits 8)))) (defmethod inspected-description ((object fixnum)) (description-maybe-internals @@ -678,21 +678,21 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" "Return the number of words in a bignum" (ash (logand (ref32 bignum) (lognot sb-vm:widetag-mask)) - (- sb-vm:n-widetag-bits))) + (- sb-vm:n-widetag-bits))) (defun bignum-component-at (bignum offset) "Return the word at offset" (case sb-vm::n-word-bits - (32 - (ref32 bignum (* 4 (1+ offset)))) - (64 - (let ((start (* 8 (1+ offset)))) - (+ (ref32 bignum start) - (ash (ref32 bignum (+ 4 start)) 32)))))) + (32 + (ref32 bignum (* 4 (1+ offset)))) + (64 + (let ((start (* 8 (1+ offset)))) + (+ (ref32 bignum start) + (ash (ref32 bignum (+ 4 start)) 32)))))) (defmethod inspected-description ((object bignum)) (format nil "bignum ~W with ~D ~A-bit word~P" object - (bignum-words object) sb-vm::n-word-bits (bignum-words object))) + (bignum-words object) sb-vm::n-word-bits (bignum-words object))) (defmethod inspected-description ((object ratio)) (format nil "ratio ~W" object)) @@ -705,7 +705,7 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" (list object (char-code object)) "[#x~8,'0X]" (logior sb-vm:character-widetag (ash (char-code object) - sb-vm:n-widetag-bits)))) + sb-vm:n-widetag-bits)))) (defmethod inspected-description ((object t)) (format nil "a generic object ~W" object)) @@ -734,9 +734,9 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" ;;; If SEQ-TYPE is :list, then each element is a value of an array ;;; If SEQ-TYPE is :vector, then each element is a value of an vector ;;; If SEQ-TYPE is :array, then each element is a value of an array -;;; with rank >= 2. The +;;; with rank >= 2. The ;;; If SEQ-TYPE is :bignum, then object is just a bignum and not a -;;; a sequence +;;; a sequence ;;; ;;; COUNT is the total number of components in the OBJECT ;;; @@ -768,25 +768,25 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" (defmethod inspected-parts ((object symbol)) (let ((components - (list (cons "NAME" (symbol-name object)) - (cons "PACKAGE" (symbol-package object)) - (cons "VALUE" (if (boundp object) - (symbol-value object) - *inspect-unbound-object-marker*)) - (cons "FUNCTION" (if (fboundp object) - (symbol-function object) - *inspect-unbound-object-marker*)) - (cons "PLIST" (symbol-plist object))))) + (list (cons "NAME" (symbol-name object)) + (cons "PACKAGE" (symbol-package object)) + (cons "VALUE" (if (boundp object) + (symbol-value object) + *inspect-unbound-object-marker*)) + (cons "FUNCTION" (if (fboundp object) + (symbol-function object) + *inspect-unbound-object-marker*)) + (cons "PLIST" (symbol-plist object))))) (list components (length components) :named nil))) (defun inspected-structure-parts (object) (let ((components-list '()) - (info (sb-kernel:layout-info (sb-kernel:layout-of object)))) + (info (sb-kernel:layout-info (sb-kernel:layout-of object)))) (when (sb-kernel::defstruct-description-p info) (dolist (dd-slot (sb-kernel:dd-slots info) (nreverse components-list)) - (push (cons (string (sb-kernel:dsd-name dd-slot)) - (funcall (sb-kernel:dsd-accessor-name dd-slot) object)) - components-list))))) + (push (cons (string (sb-kernel:dsd-name dd-slot)) + (funcall (sb-kernel:dsd-accessor-name dd-slot) object)) + components-list))))) (defmethod inspected-parts ((object structure-object)) (let ((components (inspected-structure-parts object))) @@ -794,13 +794,13 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" (defun inspected-standard-object-parts (object) (let ((components nil) - (class-slots (sb-pcl::class-slots (class-of object)))) + (class-slots (sb-pcl::class-slots (class-of object)))) (dolist (class-slot class-slots (nreverse components)) (let* ((slot-name (slot-value class-slot 'sb-pcl::name)) - (slot-value (if (slot-boundp object slot-name) - (slot-value object slot-name) - *inspect-unbound-object-marker*))) - (push (cons (symbol-name slot-name) slot-value) components))))) + (slot-value (if (slot-boundp object slot-name) + (slot-value object slot-name) + *inspect-unbound-object-marker*))) + (push (cons (symbol-name slot-name) slot-value) components))))) (defmethod inspected-parts ((object standard-object)) @@ -817,11 +817,11 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" (defmethod inspected-parts ((object function)) (let* ((type (sb-kernel:widetag-of object)) - (object (if (= type sb-vm:closure-header-widetag) - (sb-kernel:%closure-fun object) - object)) - (components (list (cons "arglist" - (sb-kernel:%simple-fun-arglist object))))) + (object (if (= type sb-vm:closure-header-widetag) + (sb-kernel:%closure-fun object) + object)) + (components (list (cons "arglist" + (sb-kernel:%simple-fun-arglist object))))) (list components (length components) :named nil))) (defmethod inspected-parts ((object vector)) @@ -829,12 +829,12 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" (defmethod inspected-parts ((object array)) (let ((size (array-total-size object))) - (list (make-array size + (list (make-array size :element-type (array-element-type object) - :displaced-to object) - size - :array - (reverse (array-dimensions object))))) + :displaced-to object) + size + :array + (reverse (array-dimensions object))))) (defmethod inspected-parts ((object cons)) (if (simple-cons-pair-p object) @@ -843,28 +843,28 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic" (defun inspected-parts-of-simple-cons (object) (let ((components (list (cons "car" (car object)) - (cons "cdr" (cdr object))))) + (cons "cdr" (cdr object))))) (list components 2 :named nil))) (defun inspected-parts-of-nontrivial-list (object) (multiple-value-bind (count list-type) (cons-safe-length object) (case list-type - (:normal - (list object count :list nil)) - (:cyclic - (list object (1+ count) :cyclic-list nil)) - (:dotted - ;; count tail element - (list object (1+ count) :dotted-list nil))))) + (:normal + (list object count :list nil)) + (:cyclic + (list object (1+ count) :cyclic-list nil)) + (:dotted + ;; count tail element + (list object (1+ count) :dotted-list nil))))) (defmethod inspected-parts ((object complex)) (let ((components (list (cons "real" (realpart object)) - (cons "imag" (imagpart object))))) + (cons "imag" (imagpart object))))) (list components (length components) :named nil))) (defmethod inspected-parts ((object ratio)) (let ((components (list (cons "numerator" (numerator object)) - (cons "denominator" (denominator object))))) + (cons "denominator" (denominator object))))) (list components (length components) :named nil))) (defmethod inspected-parts ((object bignum)) diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp index 9c8f7cd..9f7dcdc 100644 --- a/contrib/sb-aclrepl/repl.lisp +++ b/contrib/sb-aclrepl/repl.lisp @@ -25,7 +25,7 @@ (parsing nil) ; (:string :case-sensitive nil) (group nil) ; command group (:cmd or :alias) (abbr-len 0)) ; abbreviation length - + (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *default-prompt* "~:[~3*~;[~:*~D~:[~;~:*:~D~]~:[~;i~]~:[~;c~]] ~]~A(~D): " @@ -62,49 +62,49 @@ (defun prompt-package-name () (if *use-short-package-name* (car (sort (append - (package-nicknames cl:*package*) - (list (package-name cl:*package*))) - (lambda (a b) (< (length a) (length b))))) + (package-nicknames cl:*package*) + (list (package-name cl:*package*))) + (lambda (a b) (< (length a) (length b))))) (package-name cl:*package*))) (defun read-cmd (input-stream) ;; Reads a command from the user and returns a user-cmd object (let* ((next-char (peek-char-non-whitespace input-stream)) - (cmd (cond - ((eql *command-char* next-char) - (dispatch-command-line input-stream)) - ((eql #\newline next-char) - (read-char input-stream) - *null-cmd*) - ((eql :eof next-char) - *eof-cmd*) - (t - (let* ((eof (cons nil *eof-marker*)) - (form (read input-stream nil eof))) - (if (eq form eof) - *eof-cmd* - (make-user-cmd :input form :func nil :hnum *cmd-number*))))))) + (cmd (cond + ((eql *command-char* next-char) + (dispatch-command-line input-stream)) + ((eql #\newline next-char) + (read-char input-stream) + *null-cmd*) + ((eql :eof next-char) + *eof-cmd*) + (t + (let* ((eof (cons nil *eof-marker*)) + (form (read input-stream nil eof))) + (if (eq form eof) + *eof-cmd* + (make-user-cmd :input form :func nil :hnum *cmd-number*))))))) (if (and (eq cmd *eof-cmd*) (typep input-stream 'string-stream)) - (throw 'repl-catcher cmd) - cmd))) + (throw 'repl-catcher cmd) + cmd))) (defun dispatch-command-line (input-stream) "Processes an input line that starts with *command-char*" (let* ((line (string-trim-whitespace (read-line input-stream))) - (first-space-pos (position #\space line)) - (cmd-string (subseq line 1 first-space-pos)) - (cmd-args-string - (if first-space-pos - (string-trim-whitespace (subseq line first-space-pos)) - ""))) + (first-space-pos (position #\space line)) + (cmd-string (subseq line 1 first-space-pos)) + (cmd-args-string + (if first-space-pos + (string-trim-whitespace (subseq line first-space-pos)) + ""))) (declare (simple-string line)) (cond ((or (zerop (length cmd-string)) - (whitespace-char-p (char cmd-string 0))) + (whitespace-char-p (char cmd-string 0))) *null-cmd*) ((or (numberp (read-from-string cmd-string)) - (char= (char cmd-string 0) #\+) - (char= (char cmd-string 0) #\-)) + (char= (char cmd-string 0) #\+) + (char= (char cmd-string 0) #\-)) (process-cmd-numeric cmd-string cmd-args-string)) ((char= (char cmd-string 0) *command-char*) (process-history-search (subseq cmd-string 1) cmd-args-string)) @@ -114,54 +114,54 @@ (defun process-cmd-numeric (cmd-string cmd-args-string) "Process a numeric cmd, such as ':123'" (let* ((first-char (char cmd-string 0)) - (number-string (if (digit-char-p first-char) - cmd-string - (subseq cmd-string 1))) - (is-minus (char= first-char #\-)) - (raw-number (read-from-string number-string)) - (number (if is-minus - (- *cmd-number* raw-number) - raw-number)) - (cmd (get-history number))) + (number-string (if (digit-char-p first-char) + cmd-string + (subseq cmd-string 1))) + (is-minus (char= first-char #\-)) + (raw-number (read-from-string number-string)) + (number (if is-minus + (- *cmd-number* raw-number) + raw-number)) + (cmd (get-history number))) (when (eq cmd *null-cmd*) (return-from process-cmd-numeric - (make-user-cmd :func :history-error :input (read-from-string - cmd-string)))) + (make-user-cmd :func :history-error :input (read-from-string + cmd-string)))) (maybe-return-history-cmd cmd cmd-args-string))) (defun maybe-return-history-cmd (cmd cmd-args-string) (format *output* "~A~%" (user-cmd-input cmd)) (let ((dont-redo - (when (and (stringp cmd-args-string) - (plusp (length cmd-args-string)) - (char= #\? (char cmd-args-string 0))) - (do ((line nil (read-line *input*))) - ((and line (or (zerop (length line)) - (string-equal line "Y") - (string-equal line "N"))) - (when (string-equal line "N") - t)) - (when line - (format *output* "Type \"y\" for yes or \"n\" for no.~%")) - (format *output* "redo? [y] ") - (force-output *output*))))) + (when (and (stringp cmd-args-string) + (plusp (length cmd-args-string)) + (char= #\? (char cmd-args-string 0))) + (do ((line nil (read-line *input*))) + ((and line (or (zerop (length line)) + (string-equal line "Y") + (string-equal line "N"))) + (when (string-equal line "N") + t)) + (when line + (format *output* "Type \"y\" for yes or \"n\" for no.~%")) + (format *output* "redo? [y] ") + (force-output *output*))))) (if dont-redo - *null-cmd* - (make-user-cmd :func (user-cmd-func cmd) - :input (user-cmd-input cmd) - :args (user-cmd-args cmd) - :hnum *cmd-number*)))) + *null-cmd* + (make-user-cmd :func (user-cmd-func cmd) + :input (user-cmd-input cmd) + :args (user-cmd-args cmd) + :hnum *cmd-number*)))) (defun find-history-matching-pattern (cmd-string) "Return history item matching cmd-string or NIL if not found" (dolist (his *history* nil) (let* ((input (user-cmd-input his)) - (string-input (if (stringp input) - input - (write-to-string input)))) + (string-input (if (stringp input) + input + (write-to-string input)))) (when (search cmd-string string-input :test #'string-equal) - (return-from find-history-matching-pattern his))))) + (return-from find-history-matching-pattern his))))) (defun process-history-search (pattern cmd-args-string) (let ((cmd (find-history-matching-pattern pattern))) @@ -174,54 +174,54 @@ (defun process-cmd-text (cmd-string line cmd-args-string) "Process a text cmd, such as ':ld a b c'" (flet ((parse-args (parsing args-string) - (case parsing - (:string - (if (zerop (length args-string)) - nil - (list args-string))) - (t - (let ((string-stream (make-string-input-stream args-string)) - (eof (cons nil *eof-marker*))) ;new cons for eq uniqueness - (loop as arg = (read string-stream nil eof) - until (eq arg eof) - collect arg)))))) + (case parsing + (:string + (if (zerop (length args-string)) + nil + (list args-string))) + (t + (let ((string-stream (make-string-input-stream args-string)) + (eof (cons nil *eof-marker*))) ;new cons for eq uniqueness + (loop as arg = (read string-stream nil eof) + until (eq arg eof) + collect arg)))))) (let ((cmd-entry (find-cmd cmd-string))) (unless cmd-entry - (return-from process-cmd-text - (make-user-cmd :func :cmd-error :input cmd-string))) + (return-from process-cmd-text + (make-user-cmd :func :cmd-error :input cmd-string))) (make-user-cmd :func (cmd-table-entry-func cmd-entry) - :input line - :args (parse-args (cmd-table-entry-parsing cmd-entry) - cmd-args-string) - :hnum *cmd-number*)))) - + :input line + :args (parse-args (cmd-table-entry-parsing cmd-entry) + cmd-args-string) + :hnum *cmd-number*)))) + (defun make-cte (name-param func desc parsing group abbr-len) (let ((name (etypecase name-param - (string - name-param) - (symbol - (string-downcase (write-to-string name-param)))))) + (string + name-param) + (symbol + (string-downcase (write-to-string name-param)))))) (make-cmd-table-entry :name name :func func :desc desc - :parsing parsing :group group - :abbr-len (if abbr-len - abbr-len - (length name))))) + :parsing parsing :group group + :abbr-len (if abbr-len + abbr-len + (length name))))) (defun %add-entry (cmd &optional abbr-len) (let* ((name (cmd-table-entry-name cmd)) - (alen (if abbr-len - abbr-len - (length name)))) + (alen (if abbr-len + abbr-len + (length name)))) (dotimes (i (length name)) (when (>= i (1- alen)) - (setf (gethash (subseq name 0 (1+ i)) *cmd-table-hash*) - cmd))))) + (setf (gethash (subseq name 0 (1+ i)) *cmd-table-hash*) + cmd))))) (defun add-cmd-table-entry (cmd-string abbr-len func-name desc parsing) (%add-entry (make-cte cmd-string (symbol-function func-name) desc parsing :cmd abbr-len) abbr-len)) - + (defun find-cmd (cmdstr) (gethash (string-downcase cmdstr) *cmd-table-hash*)) @@ -235,47 +235,47 @@ (unless (and *history* (user-cmd= cmd (car *history*))) (when (>= (length *history*) *max-history*) (setq *history* (nbutlast *history* - (1+ (- (length *history*) *max-history*))))) + (1+ (- (length *history*) *max-history*))))) (push cmd *history*) (incf *cmd-number*))) (defun get-history (n) (let ((cmd (find n *history* :key #'user-cmd-hnum :test #'eql))) (if cmd - cmd - *null-cmd*))) + cmd + *null-cmd*))) (defun get-cmd-doc-list (&optional (group :cmd)) "Return list of all commands" (let ((cmds '())) (maphash (lambda (k v) - (when (and - (= (length k) (length (cmd-table-entry-name v))) - (eq (cmd-table-entry-group v) group)) - (push (list k - (if (= (cmd-table-entry-abbr-len v) - (length k)) - "" - (subseq k 0 (cmd-table-entry-abbr-len v))) - (cmd-table-entry-desc v)) cmds))) - *cmd-table-hash*) + (when (and + (= (length k) (length (cmd-table-entry-name v))) + (eq (cmd-table-entry-group v) group)) + (push (list k + (if (= (cmd-table-entry-abbr-len v) + (length k)) + "" + (subseq k 0 (cmd-table-entry-abbr-len v))) + (cmd-table-entry-desc v)) cmds))) + *cmd-table-hash*) (sort cmds #'string-lessp :key #'car))) (defun cd-cmd (&optional string-dir) (cond ((or (zerop (length string-dir)) - (string= string-dir "~")) + (string= string-dir "~")) (setf cl:*default-pathname-defaults* (user-homedir-pathname))) (t (let ((new (truename string-dir))) (when (pathnamep new) - (setf cl:*default-pathname-defaults* new))))) + (setf cl:*default-pathname-defaults* new))))) (format *output* "~A~%" (namestring cl:*default-pathname-defaults*)) (values)) (defun pwd-cmd () (format *output* "Lisp's current working directory is ~s.~%" - (namestring cl:*default-pathname-defaults*)) + (namestring cl:*default-pathname-defaults*)) (values)) (defun trace-cmd (&rest args) @@ -287,16 +287,16 @@ (defun untrace-cmd (&rest args) (if args (format *output* "~A~%" - (eval - (sb-int:collect ((res)) - (let ((current args)) - (loop - (unless current (return)) - (let ((name (pop current))) - (res (if (eq name :function) - `(sb-debug::untrace-1 ,(pop current)) - `(sb-debug::untrace-1 ',name)))))) - `(progn ,@(res) t)))) + (eval + (sb-int:collect ((res)) + (let ((current args)) + (loop + (unless current (return)) + (let ((name (pop current))) + (res (if (eq name :function) + `(sb-debug::untrace-1 ,(pop current)) + `(sb-debug::untrace-1 ',name)))))) + `(progn ,@(res) t)))) (format *output* "~A~%" (eval (sb-debug::untrace-all)))) (values)) @@ -319,15 +319,15 @@ (format *output* "Do you want to exit lisp anyway [n]? ") (force-output *output*) (let ((input (string-trim-whitespace (read-line *input*)))) - (if (and (plusp (length input)) - (or (char= #\y (char input 0)) - (char= #\Y (char input 0)))) - ;; loop in case more threads get created while trying to exit - (do ((threads other-threads (other-threads))) - ((eq nil threads)) - (map nil #'sb-thread:destroy-thread threads) - (sleep 0.2)) - (return-from exit-cmd))))) + (if (and (plusp (length input)) + (or (char= #\y (char input 0)) + (char= #\Y (char input 0)))) + ;; loop in case more threads get created while trying to exit + (do ((threads other-threads (other-threads))) + ((eq nil threads)) + (map nil #'sb-thread:destroy-thread threads) + (sleep 0.2)) + (return-from exit-cmd))))) (sb-ext:quit :unix-status status) (values)) @@ -335,7 +335,7 @@ (cond ((null pkg) (format *output* "The ~A package is current.~%" - (package-name cl:*package*))) + (package-name cl:*package*))) ((null (find-package (write-to-string pkg))) (format *output* "Unknown package: ~A.~%" pkg)) (t @@ -344,27 +344,27 @@ (defun string-to-list-skip-spaces (str) "Return a list of strings, delimited by spaces, skipping spaces." - (declare (type (or null string) str)) + (declare (type (or null string) str)) (when str (loop for i = 0 then (1+ j) - as j = (position #\space str :start i) - when (not (char= (char str i) #\space)) - collect (subseq str i j) while j))) + as j = (position #\space str :start i) + when (not (char= (char str i) #\space)) + collect (subseq str i j) while j))) (let ((last-files-loaded nil)) (defun ld-cmd (&optional string-files) (if string-files - (setq last-files-loaded string-files) - (setq string-files last-files-loaded)) + (setq last-files-loaded string-files) + (setq string-files last-files-loaded)) (dolist (arg (string-to-list-skip-spaces string-files)) - (let ((file - (if (string= arg "~/" :end1 1 :end2 1) - (merge-pathnames (parse-namestring - (string-left-trim "~/" arg)) - (user-homedir-pathname)) - arg))) - (format *output* "loading ~S~%" file) - (load file)))) + (let ((file + (if (string= arg "~/" :end1 1 :end2 1) + (merge-pathnames (parse-namestring + (string-left-trim "~/" arg)) + (user-homedir-pathname)) + arg))) + (format *output* "loading ~S~%" file) + (load file)))) (values)) (defun cf-cmd (string-files) @@ -380,13 +380,13 @@ (defun newer-file-p (file1 file2) "Is file1 newer (written later than) file2?" (>-num (if (probe-file file1) (file-write-date file1)) - (if (probe-file file2) (file-write-date file2)))) + (if (probe-file file2) (file-write-date file2)))) (defun compile-file-as-needed (src-path) "Compiles a file if needed, returns path." (let ((dest-path (compile-file-pathname src-path))) (when (or (not (probe-file dest-path)) - (newer-file-p src-path dest-path)) + (newer-file-p src-path dest-path)) (ensure-directories-exist dest-path) (compile-file src-path :output-file dest-path)) dest-path)) @@ -401,8 +401,8 @@ (let ((last-files-loaded nil)) (defun cload-cmd (&optional string-files) (if string-files - (setq last-files-loaded string-files) - (setq string-files last-files-loaded)) + (setq last-files-loaded string-files) + (setq string-files last-files-loaded)) (dolist (arg (string-to-list-skip-spaces string-files)) (format *output* "loading ~a~%" arg) (load (compile-file-as-needed arg))) @@ -431,10 +431,10 @@ (dotimes (i n) (declare (fixnum i)) (let ((hist (nth (- n i 1) *history*))) - (format *output* "~3A " (user-cmd-hnum hist)) - (if (stringp (user-cmd-input hist)) - (format *output* "~A~%" (user-cmd-input hist)) - (format *output* "~W~%" (user-cmd-input hist)))))) + (format *output* "~3A " (user-cmd-hnum hist)) + (if (stringp (user-cmd-input hist)) + (format *output* "~A~%" (user-cmd-input hist)) + (format *output* "~W~%" (user-cmd-input hist)))))) (values)) (defun help-cmd (&optional cmd) @@ -442,16 +442,16 @@ (cmd (let ((cmd-entry (find-cmd cmd))) (if cmd-entry - (format *output* "Documentation for ~A: ~A~%" - (cmd-table-entry-name cmd-entry) - (cmd-table-entry-desc cmd-entry))))) + (format *output* "Documentation for ~A: ~A~%" + (cmd-table-entry-name cmd-entry) + (cmd-table-entry-desc cmd-entry))))) (t (format *output* "~11A ~4A ~A~%" "COMMAND" "ABBR" "DESCRIPTION") (format *output* "~11A ~4A ~A~%" "" "" - "re-execute th history command") + "re-execute th history command") (dolist (doc-entry (get-cmd-doc-list :cmd)) (format *output* "~11A ~4A ~A~%" (first doc-entry) - (second doc-entry) (third doc-entry))))) + (second doc-entry) (third doc-entry))))) (values)) (defun alias-cmd () @@ -460,14 +460,14 @@ (cons (format *output* "~11A ~A ~4A~%" "ALIAS" "ABBR" "DESCRIPTION") (dolist (doc-entry doc-entries) - (format *output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry)))) + (format *output* "~11A ~4A ~A~%" (first doc-entry) (second doc-entry) (third doc-entry)))) (t (format *output* "No aliases are defined~%")))) (values)) (defun shell-cmd (string-arg) (sb-ext:run-program "/bin/sh" (list "-c" string-arg) - :input nil :output *output*) + :input nil :output *output*) (values)) (defun pushd-cmd (string-arg) @@ -478,7 +478,7 @@ (defun popd-cmd () (if *dir-stack* (let ((dir (pop *dir-stack*))) - (cd-cmd dir)) + (cd-cmd dir)) (format *output* "No directory on stack to pop.~%")) (values)) @@ -505,52 +505,52 @@ (defun up-cmd (&optional (n 1)) (dotimes (i n) (if (and sb-debug::*current-frame* - (sb-di:frame-up sb-debug::*current-frame*)) - (sb-debug::up-debug-command) - (progn - (format *output* "Top of the stack") - (return-from up-cmd))))) + (sb-di:frame-up sb-debug::*current-frame*)) + (sb-debug::up-debug-command) + (progn + (format *output* "Top of the stack") + (return-from up-cmd))))) (defun dn-cmd (&optional (n 1)) (dotimes (i n) (if (and sb-debug::*current-frame* - (sb-di:frame-down sb-debug::*current-frame*)) - (sb-debug::down-debug-command) - (progn - (format *output* "Bottom of the stack") - (return-from dn-cmd))))) + (sb-di:frame-down sb-debug::*current-frame*)) + (sb-debug::down-debug-command) + (progn + (format *output* "Bottom of the stack") + (return-from dn-cmd))))) (defun continue-cmd (&optional (num 0)) ;; don't look at first restart (let ((restarts (compute-restarts))) (if restarts - (let ((restart - (typecase num - (unsigned-byte - (if (< -1 num (length restarts)) - (nth num restarts) - (progn - (format *output* "There is no such restart") - (return-from continue-cmd)))) - (symbol - (find num (the list restarts) - :key #'restart-name - :test (lambda (sym1 sym2) - (string= (symbol-name sym1) - (symbol-name sym2))))) - (t - (format *output* "~S is invalid as a restart name" num) - (return-from continue-cmd nil))))) - (when restart - (invoke-restart-interactively restart))) + (let ((restart + (typecase num + (unsigned-byte + (if (< -1 num (length restarts)) + (nth num restarts) + (progn + (format *output* "There is no such restart") + (return-from continue-cmd)))) + (symbol + (find num (the list restarts) + :key #'restart-name + :test (lambda (sym1 sym2) + (string= (symbol-name sym1) + (symbol-name sym2))))) + (t + (format *output* "~S is invalid as a restart name" num) + (return-from continue-cmd nil))))) + (when restart + (invoke-restart-interactively restart))) (format *output* "~&There are no restarts")))) (defun error-cmd () (when (plusp *break-level*) (if *inspect-break* - (sb-debug::show-restarts (compute-restarts) *output*) - (let ((sb-debug::*debug-restarts* (compute-restarts))) - (sb-debug::error-debug-command))))) + (sb-debug::show-restarts (compute-restarts) *output*) + (let ((sb-debug::*debug-restarts* (compute-restarts))) + (sb-debug::error-debug-command))))) (defun frame-cmd () (sb-debug::print-frame-call sb-debug::*current-frame*)) @@ -574,14 +574,14 @@ (defun sb-aclrepl::kill-cmd (&rest selected-threads) #+sb-thread - (dolist (thread selected-threads) + (dolist (thread selected-threads) (let ((found (find thread (all-threads) :key 'sb-thread:thread-name - :test 'equal))) + :test 'equal))) (if found - (progn - (format *output* "~&Destroying thread ~A" thread) - (sb-thread:destroy-thread found)) - (format *output* "~&Thread ~A not found" thread)))) + (progn + (format *output* "~&Destroying thread ~A" thread) + (sb-thread:destroy-thread found)) + (format *output* "~&Thread ~A not found" thread)))) #-sb-thread (declare (ignore selected-threads)) #-sb-thread @@ -615,44 +615,44 @@ (let ((cmd-table '(("aliases" 3 alias-cmd "show aliases") - ("apropos" 2 apropos-cmd "show apropos" :parsing :string) - ("bottom" 3 bottom-cmd "move to bottom stack frame") - ("top" 3 top-cmd "move to top stack frame") - ("bt" 2 bt-cmd "backtrace `n' stack frames, default all") - ("up" 2 up-cmd "move up `n' stack frames, default 1") - ("dn" 2 dn-cmd "move down `n' stack frames, default 1") - ("cd" 2 cd-cmd "change default diretory" :parsing :string) - ("ld" 2 ld-cmd "load a file" :parsing :string) - ("cf" 2 cf-cmd "compile file" :parsing :string) - ("cload" 2 cload-cmd "compile if needed and load file" - :parsing :string) - ("current" 3 current-cmd "print the expression for the current stack frame") - ("continue" 4 continue-cmd "continue from a continuable error") - ("describe" 2 describe-cmd "describe an object") - ("macroexpand" 2 macroexpand-cmd "macroexpand an expression") - ("package" 2 package-cmd "change current package") - ("error" 3 error-cmd "print the last error message") - ("exit" 2 exit-cmd "exit sbcl") - ("frame" 2 frame-cmd "print info about the current frame") - ("help" 2 help-cmd "print this help") - ("history" 3 history-cmd "print the recent history") - ("inspect" 2 inspect-cmd "inspect an object") - ("istep" 1 istep-cmd "navigate within inspection of a lisp object" :parsing :string) - #+sb-thread ("kill" 2 kill-cmd "kill (destroy) processes") - #+sb-thread ("focus" 2 focus-cmd "focus the top level on a process") - ("local" 3 local-cmd "print the value of a local variable") - ("pwd" 3 pwd-cmd "print current directory") - ("pushd" 2 pushd-cmd "push directory on stack" :parsing :string) - ("pop" 3 pop-cmd "pop up `n' (default 1) break levels") - ("popd" 4 popd-cmd "pop directory from stack") - #+sb-thread ("processes" 3 processes-cmd "list all processes") - ("reset" 3 reset-cmd "reset to top break level") - ("trace" 2 trace-cmd "trace a function") - ("untrace" 4 untrace-cmd "untrace a function") - ("dirs" 2 dirs-cmd "show directory stack") - ("shell" 2 shell-cmd "execute a shell cmd" :parsing :string) - ("zoom" 2 zoom-cmd "print the runtime stack") - ))) + ("apropos" 2 apropos-cmd "show apropos" :parsing :string) + ("bottom" 3 bottom-cmd "move to bottom stack frame") + ("top" 3 top-cmd "move to top stack frame") + ("bt" 2 bt-cmd "backtrace `n' stack frames, default all") + ("up" 2 up-cmd "move up `n' stack frames, default 1") + ("dn" 2 dn-cmd "move down `n' stack frames, default 1") + ("cd" 2 cd-cmd "change default diretory" :parsing :string) + ("ld" 2 ld-cmd "load a file" :parsing :string) + ("cf" 2 cf-cmd "compile file" :parsing :string) + ("cload" 2 cload-cmd "compile if needed and load file" + :parsing :string) + ("current" 3 current-cmd "print the expression for the current stack frame") + ("continue" 4 continue-cmd "continue from a continuable error") + ("describe" 2 describe-cmd "describe an object") + ("macroexpand" 2 macroexpand-cmd "macroexpand an expression") + ("package" 2 package-cmd "change current package") + ("error" 3 error-cmd "print the last error message") + ("exit" 2 exit-cmd "exit sbcl") + ("frame" 2 frame-cmd "print info about the current frame") + ("help" 2 help-cmd "print this help") + ("history" 3 history-cmd "print the recent history") + ("inspect" 2 inspect-cmd "inspect an object") + ("istep" 1 istep-cmd "navigate within inspection of a lisp object" :parsing :string) + #+sb-thread ("kill" 2 kill-cmd "kill (destroy) processes") + #+sb-thread ("focus" 2 focus-cmd "focus the top level on a process") + ("local" 3 local-cmd "print the value of a local variable") + ("pwd" 3 pwd-cmd "print current directory") + ("pushd" 2 pushd-cmd "push directory on stack" :parsing :string) + ("pop" 3 pop-cmd "pop up `n' (default 1) break levels") + ("popd" 4 popd-cmd "pop directory from stack") + #+sb-thread ("processes" 3 processes-cmd "list all processes") + ("reset" 3 reset-cmd "reset to top break level") + ("trace" 2 trace-cmd "trace a function") + ("untrace" 4 untrace-cmd "untrace a function") + ("dirs" 2 dirs-cmd "show directory stack") + ("shell" 2 shell-cmd "execute a shell cmd" :parsing :string) + ("zoom" 2 zoom-cmd "print the runtime stack") + ))) (dolist (cmd cmd-table) (destructuring-bind (cmd-string abbr-len func-name desc &key parsing) cmd (add-cmd-table-entry cmd-string abbr-len func-name desc parsing)))) @@ -667,56 +667,56 @@ (defmacro alias (name-param args &rest body) (let ((parsing nil) - (desc "") - (abbr-index nil) - (name (if (atom name-param) - name-param - (car name-param)))) + (desc "") + (abbr-index nil) + (name (if (atom name-param) + name-param + (car name-param)))) (when (consp name-param) (dolist (param (cdr name-param)) - (cond - ((or - (eq param :case-sensitive) - (eq param :string)) - (setq parsing param)) - ((stringp param) - (setq desc param)) - ((numberp param) - (setq abbr-index param))))) + (cond + ((or + (eq param :case-sensitive) + (eq param :string)) + (setq parsing param)) + ((stringp param) + (setq desc param)) + ((numberp param) + (setq abbr-index param))))) `(progn (%add-entry (make-cte (quote ,name) (lambda ,args ,@body) ,desc ,parsing :alias (when ,abbr-index - (1+ ,abbr-index))) + (1+ ,abbr-index))) ,abbr-index) ,name))) - - + + (defun remove-alias (&rest aliases) (declare (list aliases)) (let ((keys '()) - (remove-all (not (null (find :all aliases))))) + (remove-all (not (null (find :all aliases))))) (unless remove-all ;; ensure all alias are strings (setq aliases - (loop for alias in aliases - collect - (etypecase alias - (string - alias) - (symbol - (symbol-name alias)))))) + (loop for alias in aliases + collect + (etypecase alias + (string + alias) + (symbol + (symbol-name alias)))))) (maphash (lambda (key cmd) (when (eq (cmd-table-entry-group cmd) :alias) - (if remove-all - (push key keys) - (when (some - (lambda (alias) - (let ((klen (length key))) - (and (>= (length alias) klen) - (string-equal (subseq alias 0 klen) - (subseq key 0 klen))))) - aliases) - (push key keys))))) + (if remove-all + (push key keys) + (when (some + (lambda (alias) + (let ((klen (length key))) + (and (>= (length alias) klen) + (string-equal (subseq alias 0 klen) + (subseq key 0 klen))))) + aliases) + (push key keys))))) *cmd-table-hash*) (dolist (key keys) (remhash key *cmd-table-hash*)) @@ -728,21 +728,21 @@ ;;; character. (defun peek-char-non-whitespace (&optional stream) (do ((char (peek-char nil stream nil *eof-marker*) - (peek-char nil stream nil *eof-marker*))) + (peek-char nil stream nil *eof-marker*))) ((not (whitespace-char-not-newline-p char)) char) (read-char stream))) (defun string-trim-whitespace (str) (string-trim '(#\space #\tab #\return) - str)) + str)) (defun whitespace-char-p (x) (and (characterp x) (or (char= x #\space) - (char= x #\tab) - (char= x #\page) - (char= x #\newline) - (char= x #\return)))) + (char= x #\tab) + (char= x #\page) + (char= x #\newline) + (char= x #\return)))) (defun whitespace-char-not-newline-p (x) (and (whitespace-char-p x) @@ -752,71 +752,71 @@ (defun repl-prompt-fun (stream) (let ((break-level (when (plusp *break-level*) - *break-level*)) - (frame-number (when (and (plusp *break-level*) - sb-debug::*current-frame*) - (sb-di::frame-number sb-debug::*current-frame*)))) + *break-level*)) + (frame-number (when (and (plusp *break-level*) + sb-debug::*current-frame*) + (sb-di::frame-number sb-debug::*current-frame*)))) (sb-thread::get-foreground) (fresh-line stream) (if (functionp *prompt*) - (write-string (funcall *prompt* - break-level - frame-number - *inspect-break* - *continuable-break* - (prompt-package-name) *cmd-number*) - stream) - (handler-case - (format nil *prompt* - break-level - frame-number - *inspect-break* - *continuable-break* - (prompt-package-name) *cmd-number*) - (error () - (format stream "~&Prompt error> ")) - (:no-error (prompt) - (format stream "~A" prompt)))))) - + (write-string (funcall *prompt* + break-level + frame-number + *inspect-break* + *continuable-break* + (prompt-package-name) *cmd-number*) + stream) + (handler-case + (format nil *prompt* + break-level + frame-number + *inspect-break* + *continuable-break* + (prompt-package-name) *cmd-number*) + (error () + (format stream "~&Prompt error> ")) + (:no-error (prompt) + (format stream "~A" prompt)))))) + (defun process-cmd (user-cmd) ;; Processes a user command. Returns t if the user-cmd was a top-level ;; command (cond ((eq user-cmd *eof-cmd*) - (when *exit-on-eof* - (sb-ext:quit)) - (format *output* "EOF~%") - t) - ((eq user-cmd *null-cmd*) - t) - ((eq (user-cmd-func user-cmd) :cmd-error) - (format *output* "Unknown top-level command: ~s.~%" - (user-cmd-input user-cmd)) - (format *output* "Type `~Ahelp' for the list of commands.~%" *command-char*) - t) - ((eq (user-cmd-func user-cmd) :history-error) - (format *output* "Input numbered ~d is not on the history list~%" - (user-cmd-input user-cmd)) - t) - ((functionp (user-cmd-func user-cmd)) - (add-to-history user-cmd) - (apply (user-cmd-func user-cmd) (user-cmd-args user-cmd)) - ;;(fresh-line) - t) - (t - (add-to-history user-cmd) - nil))) ; nope, not in my job description + (when *exit-on-eof* + (sb-ext:quit)) + (format *output* "EOF~%") + t) + ((eq user-cmd *null-cmd*) + t) + ((eq (user-cmd-func user-cmd) :cmd-error) + (format *output* "Unknown top-level command: ~s.~%" + (user-cmd-input user-cmd)) + (format *output* "Type `~Ahelp' for the list of commands.~%" *command-char*) + t) + ((eq (user-cmd-func user-cmd) :history-error) + (format *output* "Input numbered ~d is not on the history list~%" + (user-cmd-input user-cmd)) + t) + ((functionp (user-cmd-func user-cmd)) + (add-to-history user-cmd) + (apply (user-cmd-func user-cmd) (user-cmd-args user-cmd)) + ;;(fresh-line) + t) + (t + (add-to-history user-cmd) + nil))) ; nope, not in my job description (defun repl-read-form-fun (input output) ;; Pick off all the leading ACL magic commands, then return a normal ;; Lisp form. (let ((*input* input) - (*output* output)) + (*output* output)) (loop for user-cmd = (read-cmd *input*) do - (if (process-cmd user-cmd) - (progn - (funcall sb-int:*repl-prompt-fun* *output*) - (force-output *output*)) - (return (user-cmd-input user-cmd)))))) + (if (process-cmd user-cmd) + (progn + (funcall sb-int:*repl-prompt-fun* *output*) + (force-output *output*)) + (return (user-cmd-input user-cmd)))))) (setf sb-int:*repl-prompt-fun* #'repl-prompt-fun @@ -826,18 +826,18 @@ (let ((gvars (mapcar (lambda (var) (gensym (symbol-name var))) vars))) `(let (,@(mapcar (lambda (var gvar) `(,gvar ,var)) vars gvars)) (lambda (noprint) - (let ((*noprint* noprint)) - (let (,@(mapcar (lambda (var gvar) `(,var ,gvar)) vars gvars)) - (unwind-protect - (progn ,@forms) - ,@(mapcar (lambda (var gvar) `(setf ,gvar ,var)) - vars gvars)))))))) - + (let ((*noprint* noprint)) + (let (,@(mapcar (lambda (var gvar) `(,var ,gvar)) vars gvars)) + (unwind-protect + (progn ,@forms) + ,@(mapcar (lambda (var gvar) `(setf ,gvar ,var)) + vars gvars)))))))) + (defun make-repl-fun () (with-new-repl-state (*break-level* *inspect-break* *continuable-break* - *dir-stack* *command-char* *prompt* - *use-short-package-name* *max-history* *exit-on-eof* - *history* *cmd-number*) + *dir-stack* *command-char* *prompt* + *use-short-package-name* *max-history* *exit-on-eof* + *history* *cmd-number*) (repl :noprint noprint :break-level 0))) (when (boundp 'sb-impl::*repl-fun-generator*) diff --git a/contrib/sb-aclrepl/tests.lisp b/contrib/sb-aclrepl/tests.lisp index 2bf3397..001b516 100644 --- a/contrib/sb-aclrepl/tests.lisp +++ b/contrib/sb-aclrepl/tests.lisp @@ -1,11 +1,11 @@ -;; Tests for sb-aclrepl +;; Tests for sb-aclrepl (defpackage #:aclrepl-tests (:use #:sb-aclrepl #:cl #:sb-rt)) (in-package #:aclrepl-tests) (declaim (special sb-aclrepl::*skip-address-display* - sb-aclrepl::*inspect-unbound-object-marker*)) + sb-aclrepl::*inspect-unbound-object-marker*)) (setf sb-rt::*catch-errors* nil) @@ -55,8 +55,8 @@ (defparameter *bignum* 1234567890123456789) (defparameter *array* (make-array '(3 3 2) :initial-element nil)) (defparameter *vector* (make-array '(20):initial-contents - '(0 1 2 3 4 5 6 7 8 9 - 10 11 12 13 14 15 16 17 18 19))) + '(0 1 2 3 4 5 6 7 8 9 + 10 11 12 13 14 15 16 17 18 19))) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *circle-list1* '(a)) (setf (car *circle-list1*) *circle-list1*) @@ -126,27 +126,27 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defun basename (id &optional print (skip 0)) (let ((name (typecase id - (symbol (symbol-name id)) - (string (string-upcase id)) - (t (format nil "~A" id))))) + (symbol (symbol-name id)) + (string (string-upcase id)) + (t (format nil "~A" id))))) (format nil "~A~A~A" - (string-left-trim "*" (string-right-trim "*" name)) - (if print (format nil ".P~D" print) "") - (if (not (zerop skip)) (format nil ".S~D" skip) "")))) - + (string-left-trim "*" (string-right-trim "*" name)) + (if print (format nil ".P~D" print) "") + (if (not (zerop skip)) (format nil ".S~D" skip) "")))) + (defun elements-tests-name (id ext print skip) (intern (format nil "ELEM.~A.~A" (basename id print skip) ext)))) (defmacro def-elements-tests (object count components labels - &optional (print nil) (skip 0)) + &optional (print nil) (skip 0)) `(progn (deftest ,(elements-tests-name object "COUNT" print skip) - (elements-count ,object ,print ,skip) ,count) + (elements-count ,object ,print ,skip) ,count) (unless (eq ,components :dont-check) (deftest ,(elements-tests-name object "COMPONENTS" print skip) - (elements-components ,object ,print ,skip) ,components)) + (elements-components ,object ,print ,skip) ,components)) (deftest ,(elements-tests-name object "LABELS" print skip) - (elements-labels ,object ,print ,skip) ,labels))) + (elements-labels ,object ,print ,skip) ,labels))) (def-elements-tests *normal-list* 3 #(a b 3) #(0 1 2)) (def-elements-tests *dotted-list* 3 #(a b 3) #(0 1 :tail)) @@ -164,9 +164,9 @@ (deftest circle-list2-components.1 (aref (elements-components *circle-list2*) 1) #.*circle-list2*) (deftest circle-list3-components.0 - (aref (elements-components *circle-list3*) 0) #.*circle-list3*) + (aref (elements-components *circle-list3*) 0) #.*circle-list3*) (deftest circle-list3-components.1 - (aref (elements-components *circle-list3*) 1) b) + (aref (elements-components *circle-list3*) 1) b) (deftest circle-list3-components.2 (aref (elements-components *circle-list3*) 2) c) (deftest circle-list4-components.0 @@ -183,10 +183,10 @@ (aref (elements-components *circle-list5*) 2) #.*circle-list5*) (def-elements-tests *cons-pair* 2 #(#c(1 2) a-symbol) - #((0 . "car") (1 . "cdr"))) + #((0 . "car") (1 . "cdr"))) (def-elements-tests *complex* 2 #(1 2) #((0 . "real") (1 . "imag"))) (def-elements-tests *ratio* 2 #(22 7) - #((0 . "numerator") (1 . "denominator"))) + #((0 . "numerator") (1 . "denominator"))) (case sb-vm::n-word-bits (32 (def-elements-tests *bignum* 2 @@ -198,8 +198,8 @@ #((0 . :HEX64))))) (def-elements-tests *vector* 20 - #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) - #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)) + #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) + #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)) (def-elements-tests *vector* 18 #(nil 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) #(:ellipses 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) @@ -290,9 +290,9 @@ (def-elements-tests *tiny-struct* 1 #(10) #((0 . "FIRST"))) (def-elements-tests *tiny-struct* 1 - #(nil) #(:ellipses) nil 1) + #(nil) #(:ellipses) nil 1) (def-elements-tests *tiny-struct* 1 - #(nil) #(:ellipses) nil 2) + #(nil) #(:ellipses) nil 2) (def-elements-tests *double* 0 nil nil) (def-elements-tests *double* 0 nil nil nil 1) @@ -373,15 +373,15 @@ tail-> a cyclic list with 2 elements+tail") ;;; Inspector traversal tests (deftest inspect.0 (progn (setq * *simple-struct*) - (istep '("*"))) + (istep '("*"))) "# 0 FIRST ----------> the symbol NIL 1 SLOT-2 ---------> the symbol A-VALUE 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") (deftest istep.0 (progn (setq * *simple-struct*) - (istep '("*")) - (istep '("="))) + (istep '("*")) + (istep '("="))) "# 0 FIRST ----------> the symbol NIL 1 SLOT-2 ---------> the symbol A-VALUE @@ -389,8 +389,8 @@ tail-> a cyclic list with 2 elements+tail") (deftest istep.1 (progn (setq * *simple-struct*) - (istep '("*")) - (istep '("first"))) + (istep '("*")) + (istep '("first"))) "the symbol NIL 0 NAME -----------> a simple-string (3) \"NIL\" 1 PACKAGE --------> the COMMON-LISP package @@ -400,9 +400,9 @@ tail-> a cyclic list with 2 elements+tail") (deftest istep.2 (progn (setq * *simple-struct*) - (istep '("*")) - (istep '("first")) - (istep '(">"))) + (istep '("*")) + (istep '("first")) + (istep '(">"))) "the symbol A-VALUE 0 NAME -----------> a simple-string (7) \"A-VALUE\" 1 PACKAGE --------> the ACLREPL-TESTS package @@ -411,10 +411,10 @@ tail-> a cyclic list with 2 elements+tail") 4 PLIST ----------> the symbol NIL") (deftest istep.3 (progn (setq * *simple-struct*) - (istep '("*")) - (istep '("first")) - (istep '(">")) - (istep '("<"))) + (istep '("*")) + (istep '("first")) + (istep '(">")) + (istep '("<"))) "the symbol NIL 0 NAME -----------> a simple-string (3) \"NIL\" 1 PACKAGE --------> the COMMON-LISP package @@ -423,43 +423,43 @@ tail-> a cyclic list with 2 elements+tail") 4 PLIST ----------> the symbol NIL") (deftest istep.4 (progn (setq * *simple-struct*) - (istep '("*")) - (istep '("first")) - (istep '(">")) - (istep '("<")) - (istep '("tree"))) + (istep '("*")) + (istep '("first")) + (istep '(">")) + (istep '("<")) + (istep '("tree"))) "The current object is: the symbol NIL, which was selected by FIRST #, which was selected by (inspect *) ") (deftest istep.5 (progn (setq * *simple-struct*) - (istep '("*")) - (istep '("first")) - (istep '(">")) - (istep '("<")) - (istep '("-"))) + (istep '("*")) + (istep '("first")) + (istep '(">")) + (istep '("<")) + (istep '("-"))) "# 0 FIRST ----------> the symbol NIL 1 SLOT-2 ---------> the symbol A-VALUE 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") (deftest istep.6 (progn (setq * *dotted-list*) - (istep '("*")) - (istep '("tail"))) + (istep '("*")) + (istep '("tail"))) "fixnum 3") (deftest istep.7 (progn (setq * *dotted-list*) - (istep '("*")) - (istep '("2"))) + (istep '("*")) + (istep '("2"))) "fixnum 3") (deftest istep.8 (progn (setq * 5.5d0) - (istep '("*"))) + (istep '("*"))) "double-float 5.5d0") (deftest istep.9 (progn (setq * 5.5d0) - (istep '("-"))) + (istep '("-"))) "Object has no parent ") diff --git a/contrib/sb-aclrepl/toplevel.lisp b/contrib/sb-aclrepl/toplevel.lisp index 316c8fb..60a54bc 100644 --- a/contrib/sb-aclrepl/toplevel.lisp +++ b/contrib/sb-aclrepl/toplevel.lisp @@ -25,19 +25,19 @@ "boolean: T if break caused by continuable error") (defun repl (&key - (break-level (1+ *break-level*)) - (noprint *noprint*) - (inspect nil) - (continuable nil)) + (break-level (1+ *break-level*)) + (noprint *noprint*) + (inspect nil) + (continuable nil)) (let ((*noprint* noprint) - (*break-level* break-level) - (*inspect-break* inspect) - (*continuable-break* continuable)) + (*break-level* break-level) + (*inspect-break* inspect) + (*continuable-break* continuable)) (sb-int:/show0 "entering REPL") (loop (multiple-value-bind (reason reason-param) - (catch 'repl-catcher - (loop + (catch 'repl-catcher + (loop (unwind-protect (rep-one) ;; reset toplevel step-condition handler @@ -45,12 +45,12 @@ *stepping* nil)))) (declare (ignore reason-param)) (cond - ((and (eq reason :inspect) - (plusp *break-level*)) - (return-from repl)) - ((and (eq reason :pop) - (plusp *break-level*)) - (return-from repl))))))) + ((and (eq reason :inspect) + (plusp *break-level*)) + (return-from repl)) + ((and (eq reason :pop) + (plusp *break-level*)) + (return-from repl))))))) (defun rep-one () "Read-Eval-Print one form" @@ -66,15 +66,15 @@ ;; by another process or something...) (force-output *standard-output*)) (let* ((form (funcall *repl-read-form-fun* - *standard-input* - *standard-output*)) - (results (multiple-value-list (sb-impl::interactive-eval form)))) + *standard-input* + *standard-output*)) + (results (multiple-value-list (sb-impl::interactive-eval form)))) (unless *noprint* (dolist (result results) - ;; FIXME: Calling fresh-line before a result ensures the result starts - ;; on a newline, but it usually generates an empty line. - ;; One solution would be to have the newline's entered on the - ;; input stream inform the output stream that the column should be - ;; reset to the beginning of the line. - (fresh-line *standard-output*) - (prin1 result *standard-output*))))) + ;; FIXME: Calling fresh-line before a result ensures the result starts + ;; on a newline, but it usually generates an empty line. + ;; One solution would be to have the newline's entered on the + ;; input stream inform the output stream that the column should be + ;; reset to the beginning of the line. + (fresh-line *standard-output*) + (prin1 result *standard-output*))))) diff --git a/contrib/sb-bsd-sockets/constants.lisp b/contrib/sb-bsd-sockets/constants.lisp index 7e331c6..c5d19a3 100644 --- a/contrib/sb-bsd-sockets/constants.lisp +++ b/contrib/sb-bsd-sockets/constants.lisp @@ -12,12 +12,12 @@ ((:integer af-inet "AF_INET" "IP Protocol family") (:integer af-unspec "AF_UNSPEC" "Unspecified") (:integer af-local - #+(or sunos solaris) "AF_UNIX" - #-(or sunos solaris) "AF_LOCAL" - "Local to host (pipes and file-domain).") + #+(or sunos solaris) "AF_UNIX" + #-(or sunos solaris) "AF_LOCAL" + "Local to host (pipes and file-domain).") #+linux (:integer af-inet6 "AF_INET6" "IP version 6") #+linux (:integer af-route "AF_NETLINK" "Alias to emulate 4.4BSD ") - + (:integer sock-stream "SOCK_STREAM" "Sequenced, reliable, connection-based byte streams.") (:integer sock-dgram "SOCK_DGRAM" @@ -60,7 +60,7 @@ (:integer tcp-nodelay "TCP_NODELAY") #+linux (:integer so-bindtodevice "SO_BINDTODEVICE") (:integer ifnamsiz "IFNAMSIZ") - + (:integer EADDRINUSE "EADDRINUSE") (:integer EAGAIN "EAGAIN") (:integer EBADF "EBADF") @@ -111,18 +111,18 @@ (:structure protoent ("struct protoent" (c-string-pointer name "char *" "p_name") ((* (* t)) aliases "char **" "p_aliases") - (integer proto "int" "p_proto"))) + (integer proto "int" "p_proto"))) (:function getprotobyname ("getprotobyname" (* protoent) - (name c-string))) + (name c-string))) (:integer inaddr-any "INADDR_ANY") (:structure in-addr ("struct in_addr" - ((array (unsigned 8)) addr "u_int32_t" "s_addr"))) + ((array (unsigned 8)) addr "u_int32_t" "s_addr"))) (:structure sockaddr-in ("struct sockaddr_in" (integer family "sa_family_t" "sin_family") - ;; These two could be in-port-t and - ;; in-addr-t, but then we'd throw away the - ;; convenience (and byte-order agnosticism) - ;; of the old sb-grovel scheme. + ;; These two could be in-port-t and + ;; in-addr-t, but then we'd throw away the + ;; convenience (and byte-order agnosticism) + ;; of the old sb-grovel scheme. ((array (unsigned 8)) port "u_int16_t" "sin_port") ((array (unsigned 8)) addr "struct in_addr" "sin_addr"))) (:structure sockaddr-un ("struct sockaddr_un" @@ -161,21 +161,21 @@ (socket int) (his-addr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un? (addrlen int ))) - + (:function close ("close" int (fd int))) (:function recvfrom ("recvfrom" int - (socket int) - (buf (* t)) - (len integer) - (flags int) - (sockaddr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un? - (socklen (* socklen-t)))) + (socket int) + (buf (* t)) + (len integer) + (flags int) + (sockaddr (* t)) ; KLUDGE: sockaddr-in or sockaddr-un? + (socklen (* socklen-t)))) (:function gethostbyname ("gethostbyname" (* hostent) (name c-string))) (:function gethostbyaddr ("gethostbyaddr" (* hostent) - (addr (* t)) - (len int) - (af int))) + (addr (* t)) + (len int) + (af int))) (:function setsockopt ("setsockopt" int (socket int) (level int) diff --git a/contrib/sb-bsd-sockets/defpackage.lisp b/contrib/sb-bsd-sockets/defpackage.lisp index 6e07ad5..fbd9bd9 100644 --- a/contrib/sb-bsd-sockets/defpackage.lisp +++ b/contrib/sb-bsd-sockets/defpackage.lisp @@ -35,8 +35,8 @@ socket-send socket-receive socket-recv socket-name socket-peername socket-listen socket-close socket-file-descriptor - socket-family socket-protocol socket-open-p - socket-type socket-make-stream get-protocol-by-name + socket-family socket-protocol socket-open-p + socket-type socket-make-stream get-protocol-by-name get-host-by-name get-host-by-address host-ent @@ -49,15 +49,15 @@ host-not-found-error try-again-error no-recovery-error - - ;; all socket options are also exported, by code in - ;; sockopt.lisp - socket-error + ;; all socket options are also exported, by code in + ;; sockopt.lisp + + socket-error + + ;; other errno-based socket errors are exported by code in + ;; sockets.lisp - ;; other errno-based socket errors are exported by code in - ;; sockets.lisp - make-inet-address non-blocking-mode @@ -87,7 +87,7 @@ arguments to fit Lisp style more closely.
  • Methods applicable to a particular subclass
    1. INET-SOCKET - Internet Protocol (TCP, UDP, raw) sockets -
    2. Methods on LOCAL-SOCKET - Local-domain sockets +
    3. Methods on LOCAL-SOCKET - Local-domain sockets
  • Name resolution (DNS, /etc/hosts, &c) @@ -124,7 +124,7 @@ than "network-endian integers". See the section on ~A" - w w)) - ((and (> (length w) 0) - (eql (elt w 0) #\_) - (eql (elt w (1- (length w))) #\_)) - (format nil "~A" (subseq w 1 (1- (length w))))) - (t w))) + (cond ((linkable-symbol-p w) + (format nil "~A" + w w)) + ((and (> (length w) 0) + (eql (elt w 0) #\_) + (eql (elt w (1- (length w))) #\_)) + (format nil "~A" (subseq w 1 (1- (length w))))) + (t w))) (defun markup-space (w) (let ((para (search (coerce '(#\Newline #\Newline) 'string) w))) (if para - (format nil "~A

    ~A" - (subseq w 0 (1+ para)) - (markup-space (subseq w (1+ para) nil))) - w))) + (format nil "~A

    ~A" + (subseq w 0 (1+ para)) + (markup-space (subseq w (1+ para) nil))) + w))) (defun text-markup (text) (let ((start-word 0) (end-word 0)) (labels ((read-word () - (setf end-word - (position-if - (lambda (x) (member x '(#\Space #\, #\. #\Newline))) - text :start start-word)) - (subseq text start-word end-word)) - (read-space () - (setf start-word - (position-if-not - (lambda (x) (member x '(#\Space #\, #\. #\Newline))) - text :start end-word )) - (subseq text end-word start-word))) + (setf end-word + (position-if + (lambda (x) (member x '(#\Space #\, #\. #\Newline))) + text :start start-word)) + (subseq text start-word end-word)) + (read-space () + (setf start-word + (position-if-not + (lambda (x) (member x '(#\Space #\, #\. #\Newline))) + text :start end-word )) + (subseq text end-word start-word))) (with-output-to-string (o) - (loop for inword = (read-word) - do (princ (markup-word inword) o) - while (and start-word end-word) - do (princ (markup-space (read-space)) o) - while (and start-word end-word)))))) + (loop for inword = (read-word) + do (princ (markup-word inword) o) + while (and start-word end-word) + do (princ (markup-space (read-space)) o) + while (and start-word end-word)))))) (defun do-defpackage (form stream) @@ -86,7 +86,7 @@ do cross-references and stuff (when (string-equal name (package-name *package*)) (format stream "

    Package ~A

    ~%" name) (when (documentation *package* t) - (princ (text-markup (documentation *package* t)))) + (princ (text-markup (documentation *package* t)))) (let ((exports (assoc :export options))) (when exports (setf *symbols* (mapcar #'symbol-name (cdr exports))))) @@ -96,55 +96,55 @@ do cross-references and stuff (destructuring-bind (defn name super slots &rest options) form (when (interesting-name-p name) (let ((class (find-class name))) - (format stream "

    Class: ~A~%" - name name) - #+nil (format stream "

    Superclasses: ~{~A ~}~%" - (mapcar (lambda (x) (text-markup (class-name x))) - (mop:class-direct-superclasses class))) - (if (documentation class 'type) - (format stream "

    ~A
    ~%" - (text-markup (documentation class 'type)))) - (when slots - (princ "

    Slots:

      " stream) - (dolist (slot slots) - (destructuring-bind - (name &key reader writer accessor initarg initform type - documentation) - (if (consp slot) slot (list slot)) - (format stream "
    • ~A : ~A
      • ~%" name - (if documentation (text-markup documentation) "")))) - (princ "
    " stream)) - t)))) - + (format stream "

    Class: ~A~%" + name name) + #+nil (format stream "

    Superclasses: ~{~A ~}~%" + (mapcar (lambda (x) (text-markup (class-name x))) + (mop:class-direct-superclasses class))) + (if (documentation class 'type) + (format stream "

    ~A
    ~%" + (text-markup (documentation class 'type)))) + (when slots + (princ "

    Slots:

      " stream) + (dolist (slot slots) + (destructuring-bind + (name &key reader writer accessor initarg initform type + documentation) + (if (consp slot) slot (list slot)) + (format stream "
    • ~A : ~A
      • ~%" name + (if documentation (text-markup documentation) "")))) + (princ "
    " stream)) + t)))) + (defun interesting-name-p (name) (cond ((consp name) - (and (eql (car name) 'setf) - (interesting-name-p (cadr name)))) - (t (member (symbol-name name) *symbols* :test #'string=)))) + (and (eql (car name) 'setf) + (interesting-name-p (cadr name)))) + (t (member (symbol-name name) *symbols* :test #'string=)))) (defun markup-lambdalist (l) (let (key-p) (loop for i in l - if (eq '&key i) do (setf key-p t) - end - if (and (not key-p) (consp i)) - collect (list (car i) (markup-word (cadr i))) - else collect i))) + if (eq '&key i) do (setf key-p t) + end + if (and (not key-p) (consp i)) + collect (list (car i) (markup-word (cadr i))) + else collect i))) (defun do-defunlike (form label stream) (destructuring-bind (defn name lambdalist &optional doc &rest code) form (when (interesting-name-p name) (when (symbolp name) - (setf *symbols* (remove (symbol-name name) *symbols* :test #'string=))) + (setf *symbols* (remove (symbol-name name) *symbols* :test #'string=))) (format stream "

    (~A ~A)~A
    ~%" name (string-downcase (princ-to-string name)) - (string-downcase - (format nil "~{ ~A~}" (markup-lambdalist lambdalist))) - label) + (string-downcase + (format nil "~{ ~A~}" (markup-lambdalist lambdalist))) + label) (if (stringp doc) (format stream "

    ~A
    ~%" - (text-markup doc))) + (text-markup doc))) t))) (defun do-defun (form stream) (do-defunlike form "Function" stream)) @@ -155,38 +155,38 @@ do cross-references and stuff (pushnew (symbol-name lisp-name) *symbols*) (do-defunlike `(defun ,lisp-name ((socket socket) argument) - ,(format nil "Return the value of the ~A socket option for SOCKET. This can also be updated with SETF." (symbol-name c-name) ) 'empty) + ,(format nil "Return the value of the ~A socket option for SOCKET. This can also be updated with SETF." (symbol-name c-name) ) 'empty) "Accessor" stream))) - + (defun do-form (form output-stream) (cond ((not (listp form)) nil) - ((string= (symbol-name (car form)) "DEFINE-SOCKET-OPTION-BOOL") - (do-boolean-sockopt form output-stream)) - ((eq (car form) 'defclass) - (do-defclass form output-stream)) - ((eq (car form) 'eval-when) - (do-form (third form) output-stream)) - ((eq (car form) 'defpackage) - (do-defpackage form output-stream)) - ((eq (car form) 'defun) - (do-defun form output-stream)) - ((eq (car form) 'defmethod) - (do-defmethod form output-stream)) - ((eq (car form) 'defgeneric) - (do-defgeneric form output-stream)) - (t nil))) + ((string= (symbol-name (car form)) "DEFINE-SOCKET-OPTION-BOOL") + (do-boolean-sockopt form output-stream)) + ((eq (car form) 'defclass) + (do-defclass form output-stream)) + ((eq (car form) 'eval-when) + (do-form (third form) output-stream)) + ((eq (car form) 'defpackage) + (do-defpackage form output-stream)) + ((eq (car form) 'defun) + (do-defun form output-stream)) + ((eq (car form) 'defmethod) + (do-defmethod form output-stream)) + ((eq (car form) 'defgeneric) + (do-defgeneric form output-stream)) + (t nil))) (defun do-file (input-stream output-stream) "Read in a Lisp program on INPUT-STREAM and make semi-pretty HTML on OUTPUT-STREAM" (let ((eof-marker (gensym))) - (if (< 0 - (loop for form = (read input-stream nil eof-marker) - until (eq form eof-marker) - if (do-form form output-stream) - count 1 #| and - do (princ "
    " output-stream) |# )) - (format output-stream "
    " - )))) + (if (< 0 + (loop for form = (read input-stream nil eof-marker) + until (eq form eof-marker) + if (do-form form output-stream) + count 1 #| and + do (princ "
    " output-stream) |# )) + (format output-stream "
    " + )))) (defvar *standard-sharpsign-reader* (get-dispatch-macro-character #\# #\|)) @@ -197,29 +197,29 @@ do cross-references and stuff "Produce HTML documentation for all files defined in SYSTEM, covering symbols exported from PACKAGE" (let ((*package* (find-package package)) - (*readtable* (copy-readtable)) - (*standard-output* output-stream)) + (*readtable* (copy-readtable)) + (*standard-output* output-stream)) (set-dispatch-macro-character #\# #\| (lambda (s c n) (if (eql (peek-char nil s t nil t) #\|) - (princ - (text-markup - (coerce - (loop with discard = (read-char s t nil t) - ;initially (princ "

    ") - for c = (read-char s t nil t) - until (and (eql c #\|) - (eql (peek-char nil s t nil t) #\#)) - collect c - finally (read-char s t nil t)) - 'string))) - (funcall *standard-sharpsign-reader* s c n)))) + (princ + (text-markup + (coerce + (loop with discard = (read-char s t nil t) + ;initially (princ "

    ") + for c = (read-char s t nil t) + until (and (eql c #\|) + (eql (peek-char nil s t nil t) #\#)) + collect c + finally (read-char s t nil t)) + 'string))) + (funcall *standard-sharpsign-reader* s c n)))) (dolist (c (cclan:all-components 'sb-bsd-sockets)) (when (and (typep c 'cl-source-file) - (not (typep c 'sb-bsd-sockets-system::constants-file))) - (with-open-file (in (component-pathname c) :direction :input) - (do-file in *standard-output*)))))) + (not (typep c 'sb-bsd-sockets-system::constants-file))) + (with-open-file (in (component-pathname c) :direction :input) + (do-file in *standard-output*)))))) (defun start () (with-open-file (*standard-output* "index.html" :direction :output) diff --git a/contrib/sb-bsd-sockets/inet.lisp b/contrib/sb-bsd-sockets/inet.lisp index 51e79d3..4cc0684 100644 --- a/contrib/sb-bsd-sockets/inet.lisp +++ b/contrib/sb-bsd-sockets/inet.lisp @@ -52,7 +52,7 @@ using getprotobyname(2) which typically looks in NIS or /etc/protocols" ;; We have no truck with such dreadful type punning. Octets to ;; octets, dust to dust. - + (setf (sockint::sockaddr-in-family sockaddr) sockint::af-inet) (setf (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 0) (ldb (byte 8 8) port)) (setf (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 1) (ldb (byte 8 0) port)) @@ -73,11 +73,11 @@ using getprotobyname(2) which typically looks in NIS or /etc/protocols" "Returns address and port of SOCKADDR as multiple values" (values (coerce (loop for i from 0 below 4 - collect (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) i)) - '(vector (unsigned-byte 8) 4)) + collect (sb-alien:deref (sockint::sockaddr-in-addr sockaddr) i)) + '(vector (unsigned-byte 8) 4)) (+ (* 256 (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 0)) (sb-alien:deref (sockint::sockaddr-in-port sockaddr) 1)))) - + (defun make-inet-socket (type protocol) "Make an INET socket. Deprecated in favour of make-instance" (make-instance 'inet-socket :type type :protocol protocol)) diff --git a/contrib/sb-bsd-sockets/local.lisp b/contrib/sb-bsd-sockets/local.lisp index d77fee7..53a7f85 100644 --- a/contrib/sb-bsd-sockets/local.lisp +++ b/contrib/sb-bsd-sockets/local.lisp @@ -6,7 +6,7 @@ also known as unix-domain sockets.")) (defmethod make-sockaddr-for ((socket local-socket) - &optional sockaddr &rest address &aux (filename (first address))) + &optional sockaddr &rest address &aux (filename (first address))) (let ((sockaddr (or sockaddr (sockint::allocate-sockaddr-un)))) (setf (sockint::sockaddr-un-family sockaddr) sockint::af-local) (when filename diff --git a/contrib/sb-bsd-sockets/misc.lisp b/contrib/sb-bsd-sockets/misc.lisp index c511cc7..21ce486 100644 --- a/contrib/sb-bsd-sockets/misc.lisp +++ b/contrib/sb-bsd-sockets/misc.lisp @@ -32,7 +32,7 @@ (logior arg1 sockint::o-nonblock) (logand (lognot sockint::o-nonblock) arg1)))) (when (= (the (signed-byte 32) -1) - (the (signed-byte 32) + (the (signed-byte 32) (sockint::fcntl fd sockint::f-setfl arg2))) (socket-error "fcntl")) non-blocking-p)) diff --git a/contrib/sb-bsd-sockets/name-service.lisp b/contrib/sb-bsd-sockets/name-service.lisp index 03dd6c5..7ae73af 100644 --- a/contrib/sb-bsd-sockets/name-service.lisp +++ b/contrib/sb-bsd-sockets/name-service.lisp @@ -4,7 +4,7 @@ ((name :initarg :name :accessor host-ent-name) (aliases :initarg :aliases :accessor host-ent-aliases) (address-type :initarg :type :accessor host-ent-address-type) - ; presently always AF_INET + ; presently always AF_INET (addresses :initarg :addresses :accessor host-ent-addresses)) ;; FIXME: Our Texinfo documentation extracter need at least his to spit ;; out the signature. Real documentation would be better... @@ -15,7 +15,7 @@ ;; out the signature. Real documentation would be better... (:documentation "")) -(defmethod host-ent-address ((host-ent host-ent)) +(defmethod host-ent-address ((host-ent host-ent)) (car (host-ent-addresses host-ent))) ;(define-condition host-not-found-error (socket-error)) ; host unknown @@ -26,26 +26,26 @@ (defun make-host-ent (h) (if (sb-grovel::foreign-nullp h) (name-service-error "gethostbyname")) (let* ((length (sockint::hostent-length h)) - (aliases (loop for i = 0 then (1+ i) - for al = (sb-alien:deref (sockint::hostent-aliases h) i) - while al - collect al)) - (addresses - (loop for i = 0 then (1+ i) - for ad = (sb-alien:deref (sockint::hostent-addresses h) i) - until (sb-alien:null-alien ad) - collect (ecase (sockint::hostent-type h) - (#.sockint::af-inet - (assert (= length 4)) - (let ((addr (make-array 4 :element-type '(unsigned-byte 8)))) - (loop for i from 0 below length - do (setf (elt addr i) (sb-alien:deref ad i))) - addr)) - (#.sockint::af-local - (sb-alien:cast ad sb-alien:c-string)))))) + (aliases (loop for i = 0 then (1+ i) + for al = (sb-alien:deref (sockint::hostent-aliases h) i) + while al + collect al)) + (addresses + (loop for i = 0 then (1+ i) + for ad = (sb-alien:deref (sockint::hostent-addresses h) i) + until (sb-alien:null-alien ad) + collect (ecase (sockint::hostent-type h) + (#.sockint::af-inet + (assert (= length 4)) + (let ((addr (make-array 4 :element-type '(unsigned-byte 8)))) + (loop for i from 0 below length + do (setf (elt addr i) (sb-alien:deref ad i))) + addr)) + (#.sockint::af-local + (sb-alien:cast ad sb-alien:c-string)))))) (make-instance 'host-ent :name (sockint::hostent-name h) - :type (sockint::hostent-type h) + :type (sockint::hostent-type h) :aliases aliases :addresses addresses))) @@ -62,11 +62,11 @@ grisly details." (sockint::with-in-addr packed-addr () (let ((addr-vector (coerce address 'vector))) (loop for i from 0 below (length addr-vector) - do (setf (sb-alien:deref (sockint::in-addr-addr packed-addr) i) - (elt addr-vector i))) + do (setf (sb-alien:deref (sockint::in-addr-addr packed-addr) i) + (elt addr-vector i))) (make-host-ent (sockint::gethostbyaddr packed-addr - 4 - sockint::af-inet))))) + 4 + sockint::af-inet))))) ;;; The remainder is my fault - gw @@ -84,22 +84,22 @@ GET-NAME-SERVICE-ERRNO") (if (= *name-service-errno* sockint::NETDB-INTERNAL) (socket-error where) (let ((condition - (condition-for-name-service-errno *name-service-errno*))) + (condition-for-name-service-errno *name-service-errno*))) (error condition :errno *name-service-errno* :syscall where)))) (define-condition name-service-error (condition) ((errno :initform nil - :initarg :errno - :reader name-service-error-errno) + :initarg :errno + :reader name-service-error-errno) (symbol :initform nil :initarg :symbol :reader name-service-error-symbol) (syscall :initform "an unknown location" :initarg :syscall :reader name-service-error-syscall)) (:report (lambda (c s) - (let ((num (name-service-error-errno c))) - (format s "Name service error in \"~A\": ~A (~A)" - (name-service-error-syscall c) - (or (name-service-error-symbol c) - (name-service-error-errno c)) - (get-name-service-error-message num)))))) + (let ((num (name-service-error-errno c))) + (format s "Name service error in \"~A\": ~A (~A)" + (name-service-error-syscall c) + (or (name-service-error-symbol c) + (name-service-error-errno c)) + (get-name-service-error-message num)))))) (defmacro define-name-service-condition (symbol name) `(progn @@ -126,8 +126,8 @@ GET-NAME-SERVICE-ERRNO") (defun get-name-service-errno () (setf *name-service-errno* - (sb-alien:alien-funcall - (sb-alien:extern-alien "get_h_errno" (function integer))))) + (sb-alien:alien-funcall + (sb-alien:extern-alien "get_h_errno" (function integer))))) #-(and cmu solaris) (progn diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp index bb4e7c1..c010811 100644 --- a/contrib/sb-bsd-sockets/sockets.lisp +++ b/contrib/sb-bsd-sockets/sockets.lisp @@ -6,18 +6,18 @@ (eval-when (:load-toplevel :compile-toplevel :execute) (defclass socket () ((file-descriptor :initarg :descriptor - :reader socket-file-descriptor) + :reader socket-file-descriptor) (family :initform (error "No socket family") - :reader socket-family) + :reader socket-family) (protocol :initarg :protocol - :reader socket-protocol - :documentation "Protocol used by the socket. If a + :reader socket-protocol + :documentation "Protocol used by the socket. If a keyword, the symbol-name of the keyword will be passed to GET-PROTOCOL-BY-NAME downcased, and the returned value used as protocol. Other values are used as-is.") (type :initarg :type - :reader socket-type - :documentation "Type of the socket: :STREAM or :DATAGRAM.") + :reader socket-type + :documentation "Type of the socket: :STREAM or :DATAGRAM.") (stream)) (:documentation "Common base class of all sockets, not ment to be directly instantiated."))) @@ -29,24 +29,24 @@ directly instantiated."))) (defmethod shared-initialize :after ((socket socket) slot-names - &key protocol type - &allow-other-keys) + &key protocol type + &allow-other-keys) (let* ((proto-num - (cond ((and protocol (keywordp protocol)) - (get-protocol-by-name (string-downcase (symbol-name protocol)))) - (protocol protocol) - (t 0))) - (fd (or (and (slot-boundp socket 'file-descriptor) - (socket-file-descriptor socket)) - (sockint::socket (socket-family socket) - (ecase type - ((:datagram) sockint::sock-dgram) - ((:stream) sockint::sock-stream)) - proto-num)))) + (cond ((and protocol (keywordp protocol)) + (get-protocol-by-name (string-downcase (symbol-name protocol)))) + (protocol protocol) + (t 0))) + (fd (or (and (slot-boundp socket 'file-descriptor) + (socket-file-descriptor socket)) + (sockint::socket (socket-family socket) + (ecase type + ((:datagram) sockint::sock-dgram) + ((:stream) sockint::sock-stream)) + proto-num)))) (if (= fd -1) (socket-error "socket")) (setf (slot-value socket 'file-descriptor) fd - (slot-value socket 'protocol) proto-num - (slot-value socket 'type) type) + (slot-value socket 'protocol) proto-num + (slot-value socket 'type) type) (sb-ext:finalize socket (lambda () (sockint::close fd))))) @@ -78,8 +78,8 @@ See also bind(2)")) &rest address) (with-sockaddr-for (socket sockaddr address) (if (= (sockint::bind (socket-file-descriptor socket) - sockaddr - (size-of-sockaddr socket)) + sockaddr + (size-of-sockaddr socket)) -1) (socket-error "bind")))) @@ -88,24 +88,24 @@ See also bind(2)")) (:documentation "Perform the accept(2) call, returning a newly-created connected socket and the peer address as multiple values")) - + (defmethod socket-accept ((socket socket)) (with-sockaddr-for (socket sockaddr) (let ((fd (sockint::accept (socket-file-descriptor socket) - sockaddr - (size-of-sockaddr socket)))) + sockaddr + (size-of-sockaddr socket)))) (cond - ((and (= fd -1) (= sockint::EAGAIN (sb-unix::get-errno))) - nil) - ((= fd -1) (socket-error "accept")) - (t (apply #'values - (let ((s (make-instance (class-of socket) - :type (socket-type socket) - :protocol (socket-protocol socket) - :descriptor fd))) - (sb-ext:finalize s (lambda () (sockint::close fd)))) - (multiple-value-list (bits-of-sockaddr socket sockaddr)))))))) - + ((and (= fd -1) (= sockint::EAGAIN (sb-unix::get-errno))) + nil) + ((= fd -1) (socket-error "accept")) + (t (apply #'values + (let ((s (make-instance (class-of socket) + :type (socket-type socket) + :protocol (socket-protocol socket) + :descriptor fd))) + (sb-ext:finalize s (lambda () (sockint::close fd)))) + (multiple-value-list (bits-of-sockaddr socket sockaddr)))))))) + (defgeneric socket-connect (socket &rest address) (:documentation "Perform the connect(2) call to connect SOCKET to a remote PEER. No useful return value.")) @@ -113,21 +113,21 @@ values")) (defmethod socket-connect ((socket socket) &rest peer) (with-sockaddr-for (socket sockaddr peer) (if (= (sockint::connect (socket-file-descriptor socket) - sockaddr - (size-of-sockaddr socket)) - -1) - (socket-error "connect")))) + sockaddr + (size-of-sockaddr socket)) + -1) + (socket-error "connect")))) (defgeneric socket-peername (socket) (:documentation "Return the socket's peer; depending on the address family this may return multiple values")) - + (defmethod socket-peername ((socket socket)) (with-sockaddr-for (socket sockaddr) (when (= (sockint::getpeername (socket-file-descriptor socket) - sockaddr - (size-of-sockaddr socket)) - -1) + sockaddr + (size-of-sockaddr socket)) + -1) (socket-error "getpeername")) (bits-of-sockaddr socket sockaddr))) @@ -138,9 +138,9 @@ values")) (defmethod socket-name ((socket socket)) (with-sockaddr-for (socket sockaddr) (when (= (sockint::getsockname (socket-file-descriptor socket) - sockaddr - (size-of-sockaddr socket)) - -1) + sockaddr + (size-of-sockaddr socket)) + -1) (socket-error "getsockname")) (bits-of-sockaddr socket sockaddr))) @@ -152,8 +152,8 @@ values")) ;;; to learn who the sender of the packet was (defgeneric socket-receive (socket buffer length - &key - oob peek waitall element-type) + &key + oob peek waitall element-type) (:documentation "Read LENGTH octets from SOCKET into BUFFER (or a freshly-consed buffer if NIL), using recvfrom(2). If LENGTH is NIL, the length of BUFFER is used, so at least one of these two arguments must be non-NIL. If @@ -162,54 +162,54 @@ Returns the buffer, its length, and the address of the peer that sent it, as multiple values. On datagram sockets, sets MSG_TRUNC so that the actual packet length is returned even if the buffer was too small")) - + (defmethod socket-receive ((socket socket) buffer length - &key - oob peek waitall - (element-type 'character)) + &key + oob peek waitall + (element-type 'character)) (with-sockaddr-for (socket sockaddr) (let ((flags - (logior (if oob sockint::MSG-OOB 0) - (if peek sockint::MSG-PEEK 0) - (if waitall sockint::MSG-WAITALL 0) - #+linux sockint::MSG-NOSIGNAL ;don't send us SIGPIPE - (if (eql (socket-type socket) :datagram) - sockint::msg-TRUNC 0)))) + (logior (if oob sockint::MSG-OOB 0) + (if peek sockint::MSG-PEEK 0) + (if waitall sockint::MSG-WAITALL 0) + #+linux sockint::MSG-NOSIGNAL ;don't send us SIGPIPE + (if (eql (socket-type socket) :datagram) + sockint::msg-TRUNC 0)))) (unless (or buffer length) - (error "Must supply at least one of BUFFER or LENGTH")) + (error "Must supply at least one of BUFFER or LENGTH")) (unless length - (setf length (length buffer))) + (setf length (length buffer))) (when buffer (setf element-type (array-element-type buffer))) (unless (or (subtypep element-type 'character) - (subtypep element-type 'integer)) - (error "Buffer element-type must be either a character or an integer subtype.")) + (subtypep element-type 'integer)) + (error "Buffer element-type must be either a character or an integer subtype.")) (unless buffer - (setf buffer (make-array length :element-type element-type))) + (setf buffer (make-array length :element-type element-type))) ;; really big FIXME: This whole copy-buffer thing is broken. ;; doesn't support characters more than 8 bits wide, or integer ;; types that aren't (unsigned-byte 8). (let ((copy-buffer (sb-alien:make-alien (array (sb-alien:unsigned 8) 1) length))) - (unwind-protect - (sb-alien:with-alien ((sa-len sockint::socklen-t (size-of-sockaddr socket))) - (let ((len - (sockint::recvfrom (socket-file-descriptor socket) - copy-buffer - length - flags - sockaddr - (sb-alien:addr sa-len)))) - (cond - ((and (= len -1) (= sockint::EAGAIN (sb-unix::get-errno))) nil) - ((= len -1) (socket-error "recvfrom")) - (t (loop for i from 0 below len - do (setf (elt buffer i) - (cond - ((or (eql element-type 'character) (eql element-type 'base-char)) - (code-char (sb-alien:deref (sb-alien:deref copy-buffer) i))) - (t (sb-alien:deref (sb-alien:deref copy-buffer) i))))) - (apply #'values buffer len (multiple-value-list - (bits-of-sockaddr socket sockaddr))))))) - (sb-alien:free-alien copy-buffer)))))) + (unwind-protect + (sb-alien:with-alien ((sa-len sockint::socklen-t (size-of-sockaddr socket))) + (let ((len + (sockint::recvfrom (socket-file-descriptor socket) + copy-buffer + length + flags + sockaddr + (sb-alien:addr sa-len)))) + (cond + ((and (= len -1) (= sockint::EAGAIN (sb-unix::get-errno))) nil) + ((= len -1) (socket-error "recvfrom")) + (t (loop for i from 0 below len + do (setf (elt buffer i) + (cond + ((or (eql element-type 'character) (eql element-type 'base-char)) + (code-char (sb-alien:deref (sb-alien:deref copy-buffer) i))) + (t (sb-alien:deref (sb-alien:deref copy-buffer) i))))) + (apply #'values buffer len (multiple-value-list + (bits-of-sockaddr socket sockaddr))))))) + (sb-alien:free-alien copy-buffer)))))) (defgeneric socket-listen (socket backlog) (:documentation "Mark SOCKET as willing to accept incoming connections. BACKLOG @@ -224,7 +224,7 @@ grow to before new connection attempts are refused. See also listen(2)")) (defgeneric socket-open-p (socket) (:documentation "Return true if SOCKET is open; otherwise, return false.") (:method ((socket t)) (error 'type-error - :datum socket :expected-type 'socket))) + :datum socket :expected-type 'socket))) (defmethod socket-open-p ((socket socket)) (if (slot-boundp socket 'stream) @@ -245,30 +245,30 @@ calls CLOSE on that stream instead")) ;; descriptor). Presumably this is an oversight and we could also ;; get anything that write(2) would have given us. - ;; note that if you have a socket _and_ a stream on the same fd, + ;; note that if you have a socket _and_ a stream on the same fd, ;; the socket will avoid doing anything to close the fd in case ;; the stream has done it already - if so, it may have been ;; reassigned to some other file, and closing it would be bad (let ((fd (socket-file-descriptor socket))) (cond ((eql fd -1) ; already closed - nil) - ((slot-boundp socket 'stream) - (unwind-protect (close (slot-value socket 'stream)) ;; closes fd - (setf (slot-value socket 'file-descriptor) -1) - (slot-makunbound socket 'stream))) - (t - (sb-ext:cancel-finalization socket) - (handler-case - (if (= (sockint::close fd) -1) - (socket-error "close")) - (bad-file-descriptor-error (c) (declare (ignore c)) nil) - (:no-error (c) + nil) + ((slot-boundp socket 'stream) + (unwind-protect (close (slot-value socket 'stream)) ;; closes fd + (setf (slot-value socket 'file-descriptor) -1) + (slot-makunbound socket 'stream))) + (t + (sb-ext:cancel-finalization socket) + (handler-case + (if (= (sockint::close fd) -1) + (socket-error "close")) + (bad-file-descriptor-error (c) (declare (ignore c)) nil) + (:no-error (c) (declare (ignore c)) (setf (slot-value socket 'file-descriptor) -1) nil)))))) - + (defgeneric socket-make-stream (socket &rest args) (:documentation "Find or create a STREAM that can be used for IO on SOCKET (which must be connected). ARGS are passed onto @@ -276,13 +276,13 @@ SB-SYS:MAKE-FD-STREAM.")) (defmethod socket-make-stream ((socket socket) &rest args) (let ((stream - (and (slot-boundp socket 'stream) (slot-value socket 'stream)))) + (and (slot-boundp socket 'stream) (slot-value socket 'stream)))) (unless stream (setf stream (apply #'sb-sys:make-fd-stream - (socket-file-descriptor socket) - :name "a constant string" - :dual-channel-p t - args)) + (socket-file-descriptor socket) + :name "a constant string" + :dual-channel-p t + args)) (setf (slot-value socket 'stream) stream) (sb-ext:cancel-finalization socket)) stream)) @@ -293,8 +293,8 @@ SB-SYS:MAKE-FD-STREAM.")) (define-condition socket-error (error) ((errno :initform nil - :initarg :errno - :reader socket-error-errno) + :initarg :errno + :reader socket-error-errno) (symbol :initform nil :initarg :symbol :reader socket-error-symbol) (syscall :initform "outer space" :initarg :syscall :reader socket-error-syscall)) (:report (lambda (c s) @@ -339,7 +339,7 @@ SB-SYS:MAKE-FD-STREAM.")) (defun condition-for-errno (err) (or (cdr (assoc err *conditions-for-errno* :test #'eql)) 'socket-error)) - + #+cmu (defun socket-error (where) ;; Peter's debian/x86 cmucl packages (and sbcl, derived from them) diff --git a/contrib/sb-bsd-sockets/sockopt.lisp b/contrib/sb-bsd-sockets/sockopt.lisp index 7fa1ff7..e689a48 100644 --- a/contrib/sb-bsd-sockets/sockopt.lisp +++ b/contrib/sb-bsd-sockets/sockopt.lisp @@ -22,7 +22,7 @@ wants to have type (* t). Note that even for options that have integer arguments, this is still a pointer to said integer. size is the size of the buffer that the return of mangle-arg points -to, and also of the buffer that we should allocate for getsockopt +to, and also of the buffer that we should allocate for getsockopt to write into. mangle-return is called with an alien buffer and should turn it into @@ -40,41 +40,41 @@ Code for options that not every system has should be conditionalised: level number buffer-type mangle-arg mangle-return mangle-setf-buffer &optional features info) (let ((find-level - (if (numberp (eval level)) - level - `(get-protocol-by-name ,(string-downcase (symbol-name level))))) - (supportedp (or (null features) (featurep features)))) + (if (numberp (eval level)) + level + `(get-protocol-by-name ,(string-downcase (symbol-name level))))) + (supportedp (or (null features) (featurep features)))) `(progn (export ',lisp-name) (defun ,lisp-name (socket) - ,@(when documentation (list (concatenate 'string documentation " " info))) - ,(if supportedp - `(sb-alien:with-alien ((size sb-alien:int) - (buffer ,buffer-type)) - (setf size (sb-alien:alien-size ,buffer-type :bytes)) - (if (= -1 (sockint::getsockopt (socket-file-descriptor socket) - ,find-level ,number - (sb-alien:addr buffer) - (sb-alien:addr size))) - (socket-error "getsockopt") - (,mangle-return buffer size))) - `(error 'unsupported-operator - :format-control "Socket option ~S is not supported in this platform." + ,@(when documentation (list (concatenate 'string documentation " " info))) + ,(if supportedp + `(sb-alien:with-alien ((size sb-alien:int) + (buffer ,buffer-type)) + (setf size (sb-alien:alien-size ,buffer-type :bytes)) + (if (= -1 (sockint::getsockopt (socket-file-descriptor socket) + ,find-level ,number + (sb-alien:addr buffer) + (sb-alien:addr size))) + (socket-error "getsockopt") + (,mangle-return buffer size))) + `(error 'unsupported-operator + :format-control "Socket option ~S is not supported in this platform." :format-arguments (list ',lisp-name)))) (defun (setf ,lisp-name) (new-val socket) - ,(if supportedp - `(sb-alien:with-alien ((buffer ,buffer-type)) - (setf buffer ,(if mangle-arg - `(,mangle-arg new-val) - `new-val)) - (when (= -1 (sockint::setsockopt (socket-file-descriptor socket) - ,find-level ,number - (,mangle-setf-buffer buffer) - ,(if (eql buffer-type 'sb-alien:c-string) - `(length new-val) - `(sb-alien:alien-size ,buffer-type :bytes)))) - (socket-error "setsockopt"))) - `(error 'unsupported-operator + ,(if supportedp + `(sb-alien:with-alien ((buffer ,buffer-type)) + (setf buffer ,(if mangle-arg + `(,mangle-arg new-val) + `new-val)) + (when (= -1 (sockint::setsockopt (socket-file-descriptor socket) + ,find-level ,number + (,mangle-setf-buffer buffer) + ,(if (eql buffer-type 'sb-alien:c-string) + `(length new-val) + `(sb-alien:alien-size ,buffer-type :bytes)))) + (socket-error "setsockopt"))) + `(error 'unsupported-operator :format-control "Socket option ~S is not supported on this platform." :format-arguments (list ',lisp-name))))))) @@ -116,7 +116,7 @@ Code for options that not every system has should be conditionalised: `(define-socket-option ,name ,(format nil "~@" - (symbol-name c-name)) + (symbol-name c-name)) ,level ,c-name sb-alien:int bool-to-foreign-int foreign-int-to-bool sb-alien:addr ,features ,info)) diff --git a/contrib/sb-bsd-sockets/tests.lisp b/contrib/sb-bsd-sockets/tests.lisp index e2abc15..72ec0f2 100644 --- a/contrib/sb-bsd-sockets/tests.lisp +++ b/contrib/sb-bsd-sockets/tests.lisp @@ -28,18 +28,18 @@ ;; fail to make a socket: check correct error return. There's no nice ;; way to check the condition stuff on its own, which is a shame (handler-case - (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "udp")) + (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "udp")) ((or socket-type-not-supported-error protocol-not-supported-error) (c) - (declare (ignorable c)) t) + (declare (ignorable c)) t) (:no-error nil)) t) (deftest make-inet-socket-keyword-wrong ;; same again with keywords (handler-case - (make-instance 'inet-socket :type :stream :protocol :udp) + (make-instance 'inet-socket :type :stream :protocol :udp) ((or protocol-not-supported-error socket-type-not-supported-error) (c) - (declare (ignorable c)) t) + (declare (ignorable c)) t) (:no-error nil)) t) @@ -67,9 +67,9 @@ (do-gc-portably) ;gc should clear out any old sockets bound to this port (socket-bind s (make-inet-address "127.0.0.1") 1974) (handler-case - (let ((s2 (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp")))) - (socket-bind s2 (make-inet-address "127.0.0.1") 1974) - nil) + (let ((s2 (make-instance 'inet-socket :type :stream :protocol (get-protocol-by-name "tcp")))) + (socket-bind s2 (make-inet-address "127.0.0.1") 1974) + nil) (address-in-use-error () t))) t) @@ -99,24 +99,24 @@ #+internet-available (deftest simple-tcp-client (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)) - (data (make-string 200))) + (data (make-string 200))) (socket-connect s #(127 0 0 1) 7) (let ((stream (socket-make-stream s :input t :output t :buffering :none))) - (format stream "here is some text") - (let ((data (subseq data 0 (read-buf-nonblock data stream)))) - (format t "~&Got ~S back from TCP echo server~%" data) - (> (length data) 0)))) + (format stream "here is some text") + (let ((data (subseq data 0 (read-buf-nonblock data stream)))) + (format t "~&Got ~S back from TCP echo server~%" data) + (> (length data) 0)))) t) #+internet-available (deftest sockaddr-return-type (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) - (unwind-protect - (progn - (socket-connect s #(127 0 0 1) 7) - (multiple-value-bind (host port) (socket-peername s) - (and (vectorp host) - (numberp port)))) + (unwind-protect + (progn + (socket-connect s #(127 0 0 1) 7) + (multiple-value-bind (host port) (socket-peername s) + (and (vectorp host) + (numberp port)))) (socket-close s))) t) @@ -129,8 +129,8 @@ (let ((stream (socket-make-stream s :input t :output t :buffering :none))) (format stream "here is some text") (let ((data (subseq data 0 (read-buf-nonblock data stream)))) - (format t "~&Got ~S back from UDP echo server~%" data) - (> (length data) 0)))) + (format t "~&Got ~S back from UDP echo server~%" data) + (> (length data) 0)))) t) ;;; A fairly rudimentary test that connects to the syslog socket and @@ -146,22 +146,22 @@ ;; unavailable, or if it's a symlink to some weird character ;; device. (when (and (probe-file "/dev/log") - (sb-posix:s-issock - (sb-posix::stat-mode (sb-posix:stat "/dev/log")))) - (let ((s (make-instance 'local-socket :type :datagram))) - (format t "Connecting ~A... " s) - (finish-output) - (handler-case - (socket-connect s "/dev/log") - (sb-bsd-sockets::socket-error () - (setq s (make-instance 'local-socket :type :stream)) - (format t "failed~%Retrying with ~A... " s) - (finish-output) - (socket-connect s "/dev/log"))) - (format t "ok.~%") - (let ((stream (socket-make-stream s :input t :output t :buffering :none))) - (format stream - "<7>bsd-sockets: Don't panic. We're testing local-domain client code; this message can safely be ignored")))) + (sb-posix:s-issock + (sb-posix::stat-mode (sb-posix:stat "/dev/log")))) + (let ((s (make-instance 'local-socket :type :datagram))) + (format t "Connecting ~A... " s) + (finish-output) + (handler-case + (socket-connect s "/dev/log") + (sb-bsd-sockets::socket-error () + (setq s (make-instance 'local-socket :type :stream)) + (format t "failed~%Retrying with ~A... " s) + (finish-output) + (socket-connect s "/dev/log"))) + (format t "ok.~%") + (let ((stream (socket-make-stream s :input t :output t :buffering :none))) + (format stream + "<7>bsd-sockets: Don't panic. We're testing local-domain client code; this message can safely be ignored")))) t) t) @@ -197,13 +197,13 @@ #+internet-available (deftest simple-http-client-1 (handler-case - (let ((s (http-stream "ww.telent.net" 80 "HEAD /"))) - (let ((data (make-string 200))) - (setf data (subseq data 0 - (read-buf-nonblock data - (socket-make-stream s)))) - (princ data) - (> (length data) 0))) + (let ((s (http-stream "ww.telent.net" 80 "HEAD /"))) + (let ((data (make-string 200))) + (setf data (subseq data 0 + (read-buf-nonblock data + (socket-make-stream s)))) + (princ data) + (> (length data) 0))) (network-unreachable-error () 'network-unreachable)) t) @@ -214,14 +214,14 @@ ;; kernel: we set a size of x and then getsockopt() returns 2x. ;; This is why we compare with >= instead of = (handler-case - (let ((s (http-stream "ww.telent.net" 80 "HEAD /"))) - (setf (sockopt-receive-buffer s) 1975) - (let ((data (make-string 200))) - (setf data (subseq data 0 - (read-buf-nonblock data - (socket-make-stream s)))) - (and (> (length data) 0) - (>= (sockopt-receive-buffer s) 1975)))) + (let ((s (http-stream "ww.telent.net" 80 "HEAD /"))) + (setf (sockopt-receive-buffer s) 1975) + (let ((data (make-string 200))) + (setf data (subseq data 0 + (read-buf-nonblock data + (socket-make-stream s)))) + (and (> (length data) 0) + (>= (sockopt-receive-buffer s) 1975)))) (network-unreachable-error () 'network-unreachable)) t) @@ -231,11 +231,11 @@ #+internet-available (deftest socket-open-p-true.2 (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) - (unwind-protect - (progn - (socket-connect s #(127 0 0 1) 7) - (socket-open-p s)) - (socket-close s))) + (unwind-protect + (progn + (socket-connect s #(127 0 0 1) 7) + (socket-open-p s)) + (socket-close s))) t) (deftest socket-open-p-false (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))) @@ -261,6 +261,6 @@ (loop (multiple-value-bind (buf len address port) (socket-receive s nil 500) (format t "Received ~A bytes from ~A:~A - ~A ~%" - len address port (subseq buf 0 (min 10 len))))))) - - + len address port (subseq buf 0 (min 10 len))))))) + + diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp index 896d8f3..905e9b6 100644 --- a/contrib/sb-cltl2/env.lisp +++ b/contrib/sb-cltl2/env.lisp @@ -59,15 +59,15 @@ alist of declarations that apply to the apparent binding of VAR." (case declaration-name (optimize (let ((policy (sb-c::lexenv-policy env))) - (collect ((res)) - (dolist (name sb-c::*policy-qualities*) - (res (list name (cdr (assoc name policy))))) - (loop for (name . nil) in sb-c::*policy-dependent-qualities* - do (res (list name (sb-c::policy-quality policy name)))) - (res)))) + (collect ((res)) + (dolist (name sb-c::*policy-qualities*) + (res (list name (cdr (assoc name policy))))) + (loop for (name . nil) in sb-c::*policy-dependent-qualities* + do (res (list name (sb-c::policy-quality policy name)))) + (res)))) (sb-ext:muffle-conditions (car (rassoc 'muffle-warning - (sb-c::lexenv-handled-conditions env)))) + (sb-c::lexenv-handled-conditions env)))) (t (error "Unsupported declaration ~S." declaration-name))))) (defun parse-macro (name lambda-list body &optional env) diff --git a/contrib/sb-cltl2/tests.lisp b/contrib/sb-cltl2/tests.lisp index 3a9bd8c..ec09e72 100644 --- a/contrib/sb-cltl2/tests.lisp +++ b/contrib/sb-cltl2/tests.lisp @@ -47,10 +47,10 @@ (1)) (defun smv (env) - (multiple-value-bind (expansion macro-p) - (macroexpand 'srlt env) + (multiple-value-bind (expansion macro-p) + (macroexpand 'srlt env) (when macro-p (eval expansion)))) -(defmacro testr (&environment env) +(defmacro testr (&environment env) `',(getf (smv env) nil)) (deftest macroexpand-all.4 @@ -61,21 +61,21 @@ `',(declaration-information thing env)) (macrolet ((def (x) - `(macrolet ((frob (suffix answer &optional declaration) - `(deftest ,(intern (concatenate 'string - "DECLARATION-INFORMATION." - (symbol-name ',x) - suffix)) - (locally (declare ,@(when declaration - (list declaration))) - (cadr (assoc ',',x (dinfo optimize)))) - ,answer))) - (frob ".DEFAULT" 1) - (frob ".0" 0 (optimize (,x 0))) - (frob ".1" 1 (optimize (,x 1))) - (frob ".2" 2 (optimize (,x 2))) - (frob ".3" 3 (optimize (,x 3))) - (frob ".IMPLICIT" 3 (optimize ,x))))) + `(macrolet ((frob (suffix answer &optional declaration) + `(deftest ,(intern (concatenate 'string + "DECLARATION-INFORMATION." + (symbol-name ',x) + suffix)) + (locally (declare ,@(when declaration + (list declaration))) + (cadr (assoc ',',x (dinfo optimize)))) + ,answer))) + (frob ".DEFAULT" 1) + (frob ".0" 0 (optimize (,x 0))) + (frob ".1" 1 (optimize (,x 1))) + (frob ".2" 2 (optimize (,x 2))) + (frob ".3" 3 (optimize (,x 3))) + (frob ".IMPLICIT" 3 (optimize ,x))))) (def speed) (def safety) (def debug) @@ -93,8 +93,8 @@ (locally (declare (sb-ext:muffle-conditions warning)) (locally (declare (sb-ext:unmuffle-conditions style-warning)) (let ((dinfo (dinfo sb-ext:muffle-conditions))) - (not - (not - (and (subtypep dinfo '(and warning (not style-warning))) - (subtypep '(and warning (not style-warning)) dinfo))))))) + (not + (not + (and (subtypep dinfo '(and warning (not style-warning))) + (subtypep '(and warning (not style-warning)) dinfo))))))) t) diff --git a/contrib/sb-executable/sb-executable.lisp b/contrib/sb-executable/sb-executable.lisp index 90d39d4..ee0d3ed 100644 --- a/contrib/sb-executable/sb-executable.lisp +++ b/contrib/sb-executable/sb-executable.lisp @@ -13,7 +13,7 @@ (unless (subtypep (stream-element-type to) (stream-element-type from)) (error "Incompatible streams ~A and ~A." from to)) (let ((buf (make-array *stream-buffer-size* - :element-type (stream-element-type from)))) + :element-type (stream-element-type from)))) (loop (let ((pos (read-sequence buf from))) (when (zerop pos) (return)) @@ -25,33 +25,33 @@ exec sbcl --noinform ~{~A ~}--eval \"(with-open-file (i \\\"$0\\\" :element-type ") (defun make-executable (output-file fasls - &key (runtime-flags '("--disable-debugger" - "--userinit /dev/null" - "--sysinit /dev/null")) - initial-function) + &key (runtime-flags '("--disable-debugger" + "--userinit /dev/null" + "--sysinit /dev/null")) + initial-function) "Write an executable called OUTPUT-FILE which can be run from the shell, by 'linking' together code from FASLS. Actually works by concatenating them and prepending a #! header" (with-open-file (out output-file - :direction :output - :if-exists :supersede - :element-type '(unsigned-byte 8)) + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)) (write-sequence (map 'vector #'char-code - (format nil *exec-header* runtime-flags - (or initial-function 'values))) out) + (format nil *exec-header* runtime-flags + (or initial-function 'values))) out) (dolist (input-file (if (listp fasls) fasls (list fasls))) (with-open-file (in (merge-pathnames input-file - (make-pathname :type "fasl")) - :element-type '(unsigned-byte 8)) - (copy-stream in out)))) + (make-pathname :type "fasl")) + :element-type '(unsigned-byte 8)) + (copy-stream in out)))) (let* (;; FIXME: use OUT as the pathname designator - (out-name (namestring (translate-logical-pathname output-file))) - (prot (elt (multiple-value-list (sb-unix:unix-stat out-name)) 3))) + (out-name (namestring (translate-logical-pathname output-file))) + (prot (elt (multiple-value-list (sb-unix:unix-stat out-name)) 3))) (if prot - (sb-unix::void-syscall ("chmod" c-string int) - out-name - (logior prot - (if (logand prot #o400) #o100) - (if (logand prot #o40) #o10) - (if (logand prot #o4) #o1))) - (error "stat() call failed")))) - + (sb-unix::void-syscall ("chmod" c-string int) + out-name + (logior prot + (if (logand prot #o400) #o100) + (if (logand prot #o40) #o10) + (if (logand prot #o4) #o1))) + (error "stat() call failed")))) + (provide 'sb-executable) diff --git a/contrib/sb-grovel/def-to-lisp.lisp b/contrib/sb-grovel/def-to-lisp.lisp index b39ff5e..0c8159c 100644 --- a/contrib/sb-grovel/def-to-lisp.lisp +++ b/contrib/sb-grovel/def-to-lisp.lisp @@ -8,9 +8,9 @@ (defun c-escape (string &optional (dangerous-chars '(#\")) (escape-char #\\)) "Escape DANGEROUS-CHARS in STRING, with ESCAPE-CHAR." (coerce (loop for c across string - if (member c dangerous-chars) collect escape-char - collect c) - 'string)) + if (member c dangerous-chars) collect escape-char + collect c) + 'string)) (defun as-c (&rest args) "Pretty-print ARGS into the C source file, separated by #\Space" @@ -33,9 +33,9 @@ code: printf-arg-1 printf-arg-2)" (let ((*print-pretty* nil)) (apply #'format *default-c-stream* - " printf (\"~@?\\n\"~@{, ~A~});~%" - (c-escape formatter) - args))) + " printf (\"~@?\\n\"~@{, ~A~});~%" + (c-escape formatter) + args))) (defun c-for-enum (lispname elements export) (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:enum nil" lispname) @@ -47,35 +47,35 @@ code: (dolist (element elements) (destructuring-bind (lisp-element-name c-element-name) element (declare (ignore c-element-name)) - (unless (keywordp lisp-element-name) - (printf "(export '~S)" lisp-element-name)))))) + (unless (keywordp lisp-element-name) + (printf "(export '~S)" lisp-element-name)))))) (defun c-for-structure (lispname cstruct) (destructuring-bind (cname &rest elements) cstruct (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-grovel::define-c-struct ~A %d" lispname - (format nil "sizeof(~A)" cname)) + (format nil "sizeof(~A)" cname)) (dolist (e elements) (destructuring-bind (lisp-type lisp-el-name c-type c-el-name &key distrust-length) e - (printf " (~A ~A \"~A\"" lisp-el-name lisp-type c-type) - ;; offset - (as-c "{" cname "t;") - (printf " %d" - (format nil "((unsigned long)&(t.~A)) - ((unsigned long)&(t))" c-el-name)) - (as-c "}") - ;; length - (if distrust-length - (printf " 0)") - (progn - (as-c "{" cname "t;") - (printf " %d)" - (format nil "sizeof(t.~A)" c-el-name)) - (as-c "}"))))) + (printf " (~A ~A \"~A\"" lisp-el-name lisp-type c-type) + ;; offset + (as-c "{" cname "t;") + (printf " %d" + (format nil "((unsigned long)&(t.~A)) - ((unsigned long)&(t))" c-el-name)) + (as-c "}") + ;; length + (if distrust-length + (printf " 0)") + (progn + (as-c "{" cname "t;") + (printf " %d)" + (format nil "sizeof(t.~A)" c-el-name)) + (as-c "}"))))) (printf "))"))) (defun print-c-source (stream headers definitions package-name) (declare (ignorable definitions package-name)) (let ((*default-c-stream* stream) - (*print-right-margin* nil)) + (*print-right-margin* nil)) (loop for i in (cons "stdio.h" headers) do (format stream "#include <~A>~%" i)) (as-c "#define SIGNEDP(x) (((x)-1)<0)") @@ -85,42 +85,42 @@ code: (printf "(cl:eval-when (:compile-toplevel)") (printf " (cl:defparameter *integer-sizes* (cl:make-hash-table))") (dolist (type '("char" "short" "long" "int" - #+nil"long long" ; TODO: doesn't exist in sb-alien yet - )) + #+nil"long long" ; TODO: doesn't exist in sb-alien yet + )) (printf " (cl:setf (cl:gethash %d *integer-sizes*) 'sb-alien:~A)" (substitute #\- #\Space type) - (format nil "sizeof(~A)" type))) + (format nil "sizeof(~A)" type))) (printf ")") (dolist (def definitions) (destructuring-bind (type lispname cname &optional doc export) def - (case type - (:integer - (as-c "#ifdef" cname) - (printf "(cl:defconstant ~A %d \"~A\")" lispname doc - cname) - (as-c "#else") - (printf "(sb-int:style-warn \"Couldn't grovel for ~A (unknown to the C compiler).\")" cname) - (as-c "#endif")) + (case type + (:integer + (as-c "#ifdef" cname) + (printf "(cl:defconstant ~A %d \"~A\")" lispname doc + cname) + (as-c "#else") + (printf "(sb-int:style-warn \"Couldn't grovel for ~A (unknown to the C compiler).\")" cname) + (as-c "#endif")) (:enum (c-for-enum lispname cname export)) - (:type - (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:%ssigned %d)))" lispname - (format nil "SIGNED_(~A)" cname) - (format nil "(8*sizeof(~A))" cname))) - (:string - (printf "(cl:defparameter ~A %s \"~A\"" lispname doc - cname)) - (:function - (printf "(cl:declaim (cl:inline ~A))" lispname) - (destructuring-bind (f-cname &rest definition) cname - (printf "(sb-grovel::define-foreign-routine (\"~A\" ~A)" f-cname lispname) - (printf "~{ ~W~^\\n~})" definition))) - (:structure - (c-for-structure lispname cname)) - (otherwise - ;; should we really not sprechen espagnol, monsieurs? - (error "Unknown grovel keyword encountered: ~A" type))) - (when export - (printf "(cl:export '~A)" lispname)))) + (:type + (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:%ssigned %d)))" lispname + (format nil "SIGNED_(~A)" cname) + (format nil "(8*sizeof(~A))" cname))) + (:string + (printf "(cl:defparameter ~A %s \"~A\"" lispname doc + cname)) + (:function + (printf "(cl:declaim (cl:inline ~A))" lispname) + (destructuring-bind (f-cname &rest definition) cname + (printf "(sb-grovel::define-foreign-routine (\"~A\" ~A)" f-cname lispname) + (printf "~{ ~W~^\\n~})" definition))) + (:structure + (c-for-structure lispname cname)) + (otherwise + ;; should we really not sprechen espagnol, monsieurs? + (error "Unknown grovel keyword encountered: ~A" type))) + (when export + (printf "(cl:export '~A)" lispname)))) (as-c "return 0;") (as-c "}"))) @@ -136,72 +136,72 @@ code: (define-condition c-compile-failed (compile-failed) () (:report (lambda (c s) - (format s "~@" - (error-operation c) (error-component c))))) + (format s "~@" + (error-operation c) (error-component c))))) (define-condition a-dot-out-failed (compile-failed) () (:report (lambda (c s) - (format s "~@" - (error-operation c) (error-component c))))) + (format s "~@" + (error-operation c) (error-component c))))) (defmethod asdf:perform ((op asdf:compile-op) - (component grovel-constants-file)) + (component grovel-constants-file)) ;; we want to generate all our temporary files in the fasl directory ;; because that's where we have write permission. Can't use /tmp; ;; it's insecure (these files will later be owned by root) (let* ((output-file (car (output-files op component))) - (filename (component-pathname component)) - (real-output-file - (if (typep output-file 'logical-pathname) - (translate-logical-pathname output-file) - (pathname output-file))) - (tmp-c-source (merge-pathnames #p"foo.c" real-output-file)) - (tmp-a-dot-out (merge-pathnames #p"a.out" real-output-file)) - (tmp-constants (merge-pathnames #p"constants.lisp-temp" - real-output-file))) + (filename (component-pathname component)) + (real-output-file + (if (typep output-file 'logical-pathname) + (translate-logical-pathname output-file) + (pathname output-file))) + (tmp-c-source (merge-pathnames #p"foo.c" real-output-file)) + (tmp-a-dot-out (merge-pathnames #p"a.out" real-output-file)) + (tmp-constants (merge-pathnames #p"constants.lisp-temp" + real-output-file))) (princ (list filename output-file real-output-file - tmp-c-source tmp-a-dot-out tmp-constants)) + tmp-c-source tmp-a-dot-out tmp-constants)) (terpri) (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL")) - filename tmp-c-source (constants-package component)) + filename tmp-c-source (constants-package component)) (let ((code (run-shell-command "gcc ~A -o ~S ~S" - (if (sb-ext:posix-getenv "EXTRA_CFLAGS") - (sb-ext:posix-getenv "EXTRA_CFLAGS") - "") - (namestring tmp-a-dot-out) - (namestring tmp-c-source)))) + (if (sb-ext:posix-getenv "EXTRA_CFLAGS") + (sb-ext:posix-getenv "EXTRA_CFLAGS") + "") + (namestring tmp-a-dot-out) + (namestring tmp-c-source)))) (unless (= code 0) - (case (operation-on-failure op) - (:warn (warn "~@" - op component)) - (:error - (error 'c-compile-failed :operation op :component component))))) + (case (operation-on-failure op) + (:warn (warn "~@" + op component)) + (:error + (error 'c-compile-failed :operation op :component component))))) (let ((code (run-shell-command "~A >~A" - (namestring tmp-a-dot-out) - (namestring tmp-constants)))) + (namestring tmp-a-dot-out) + (namestring tmp-constants)))) (unless (= code 0) - (case (operation-on-failure op) - (:warn (warn "~@" - op component)) - (:error - (error 'a-dot-out-failed :operation op :component component))))) + (case (operation-on-failure op) + (:warn (warn "~@" + op component)) + (:error + (error 'a-dot-out-failed :operation op :component component))))) (multiple-value-bind (output warnings-p failure-p) - (compile-file tmp-constants :output-file output-file) + (compile-file tmp-constants :output-file output-file) (when warnings-p - (case (operation-on-warnings op) - (:warn (warn - (formatter "~@") - op component)) - (:error (error 'compile-warned :component component :operation op)) - (:ignore nil))) + op component)) + (:error (error 'compile-warned :component component :operation op)) + (:ignore nil))) (when failure-p - (case (operation-on-failure op) - (:warn (warn - (formatter "~@") - op component)) - (:error (error 'compile-failed :component component :operation op)) - (:ignore nil))) + op component)) + (:error (error 'compile-failed :component component :operation op)) + (:ignore nil))) (unless output - (error 'compile-error :component component :operation op))))) + (error 'compile-error :component component :operation op))))) diff --git a/contrib/sb-grovel/example-constants.lisp b/contrib/sb-grovel/example-constants.lisp index 29d9138..a8cb3d0 100644 --- a/contrib/sb-grovel/example-constants.lisp +++ b/contrib/sb-grovel/example-constants.lisp @@ -9,27 +9,27 @@ ((:integer af-inet "AF_INET" "IP Protocol family") (:integer af-unspec "AF_UNSPEC" "Unspecified.") (:integer af-local - #+(or sunos solaris) "AF_UNIX" - #-(or sunos solaris) "AF_LOCAL" - "Local to host (pipes and file-domain).") + #+(or sunos solaris) "AF_UNIX" + #-(or sunos solaris) "AF_LOCAL" + "Local to host (pipes and file-domain).") (:integer sigterm "SIGTERM") (:structure stat ("struct stat" (integer dev "dev_t" "st_dev") (integer atime "time_t" "st_atime"))) - - + + (:function accept ("accept" int - (socket int) - (my-addr (* t)) - (addrlen int :in-out))) + (socket int) + (my-addr (* t)) + (addrlen int :in-out))) (:function bind ("bind" int - (sockfd int) - (my-addr (* t)) - (addrlen int))) + (sockfd int) + (my-addr (* t)) + (addrlen int))) (:function getpid ("getpid" int )) (:function getppid ("getppid" int)) (:function kill ("kill" int - (pid int) (signal int))) + (pid int) (signal int))) (:function mkdir ("mkdir" int - (name c-string)))) + (name c-string)))) diff --git a/contrib/sb-grovel/foreign-glue.lisp b/contrib/sb-grovel/foreign-glue.lisp index a98cca1..1a4b9e5 100644 --- a/contrib/sb-grovel/foreign-glue.lisp +++ b/contrib/sb-grovel/foreign-glue.lisp @@ -36,49 +36,49 @@ (defparameter lisp-type-table (make-hash-table :test 'eql)) (macrolet ((define-alien-types ((type size) &rest defns) - `(progn - ,@(loop for defn in defns - collect (destructuring-bind (expected-type c-type lisp-type) defn - `(progn - (setf (gethash ',expected-type alien-type-table) - (lambda (,type ,size) - (declare (ignorable type size)) - ,c-type)) - (setf (gethash ',expected-type lisp-type-table) - (lambda (,type ,size) - (declare (ignorable type size)) - ,lisp-type)))))))) + `(progn + ,@(loop for defn in defns + collect (destructuring-bind (expected-type c-type lisp-type) defn + `(progn + (setf (gethash ',expected-type alien-type-table) + (lambda (,type ,size) + (declare (ignorable type size)) + ,c-type)) + (setf (gethash ',expected-type lisp-type-table) + (lambda (,type ,size) + (declare (ignorable type size)) + ,lisp-type)))))))) (define-alien-types (type size) (integer (or (gethash size (symbol-value (intern "*INTEGER-SIZES*"))) - `(integer ,(* 8 size))) - `(unsigned-byte ,(* 8 size))) + `(integer ,(* 8 size))) + `(unsigned-byte ,(* 8 size))) (unsigned `(unsigned ,(* 8 size)) - `(unsigned-byte ,(* 8 size))) + `(unsigned-byte ,(* 8 size))) (signed `(signed ,(* 8 size)) - `(signed-byte ,(* 8 size))) + `(signed-byte ,(* 8 size))) (c-string `(array char ,size) 'cl:simple-string) (c-string-pointer 'c-string 'cl:simple-string) ;; TODO: multi-dimensional arrays, if they are ever needed. (array (destructuring-bind (array-tag elt-type &optional array-size) type - (declare (ignore array-tag)) - ;; XXX: use of EVAL. alien-size is a macro, - ;; unfortunately; and it will only accept unquoted type - ;; forms. - `(sb-alien:array ,elt-type ,(or array-size - (/ size (eval `(sb-alien:alien-size ,elt-type :bytes)))))) - t))) + (declare (ignore array-tag)) + ;; XXX: use of EVAL. alien-size is a macro, + ;; unfortunately; and it will only accept unquoted type + ;; forms. + `(sb-alien:array ,elt-type ,(or array-size + (/ size (eval `(sb-alien:alien-size ,elt-type :bytes)))))) + t))) (defun retrieve-type-for (type size table) (multiple-value-bind (type-fn found) (gethash (reintern (typecase type - (list (first type)) - (t type)) - (find-package '#:sb-grovel)) - table) + (list (first type)) + (t type)) + (find-package '#:sb-grovel)) + table) (values (if found - (funcall (the function type-fn) type size) - type) + (funcall (the function type-fn) type size) + type) found))) (defun alien-type-for (type size) @@ -88,30 +88,30 @@ (multiple-value-bind (val found) (retrieve-type-for type size lisp-type-table) (if found - val - t))) + val + t))) (defun mk-padding (len offset) (make-instance 'padding - :type `(array char ,len) - :offset offset - :size len - :name (gentemp "PADDING"))) + :type `(array char ,len) + :offset offset + :size len + :name (gentemp "PADDING"))) (defun mk-struct (offset &rest children) (make-instance 'struct :name (gentemp "STRUCT") - :children (remove nil children) - :offset offset)) + :children (remove nil children) + :offset offset)) (defun mk-union (offset &rest children) (make-instance 'union :name (gentemp "UNION") - :children (remove nil children) - :offset offset)) + :children (remove nil children) + :offset offset)) (defun mk-val (name type h-type offset size) (declare (ignore h-type)) (make-instance 'value-slot :name name - :size size - :offset offset - :type type)) + :size size + :offset offset + :type type)) ;;; struct tree classes @@ -146,11 +146,11 @@ (defmethod size ((slot structured-type)) (let ((min-offset (offset slot))) (if (null (children slot)) - 0 - (reduce #'max (mapcar (lambda (child) - (+ (- (offset child) min-offset) (size child))) - (children slot)) - :initial-value 0)))) + 0 + (reduce #'max (mapcar (lambda (child) + (+ (- (offset child) min-offset) (size child))) + (children slot)) + :initial-value 0)))) (defgeneric slot-end (slot)) (defmethod slot-end ((slot slot)) @@ -158,24 +158,24 @@ (defun overlap-p (elt1 elt2) (unless (or (zerop (size elt1)) - (zerop (size elt2))) + (zerop (size elt2))) (or (and (<= (offset elt1) - (offset elt2)) - (< (offset elt2) - (slot-end elt1))) + (offset elt2)) + (< (offset elt2) + (slot-end elt1))) (and (<= (offset elt2) - (offset elt1)) - (< (offset elt1) - (slot-end elt2)))))) + (offset elt1)) + (< (offset elt1) + (slot-end elt2)))))) (defgeneric find-overlaps (root new-element)) (defmethod find-overlaps ((root structured-type) new-element) (when (overlap-p root new-element) (let ((overlapping-elts (loop for child in (children root) - for overlap = (find-overlaps child new-element) - when overlap - return overlap))) + for overlap = (find-overlaps child new-element) + when overlap + return overlap))) (cons root overlapping-elts)))) (defmethod find-overlaps ((root value-slot) new-element) @@ -184,73 +184,73 @@ (defgeneric pad-to-offset-of (to-pad parent)) (macrolet ((skel (end-form) - `(let* ((end ,end-form) - (len (abs (- (offset to-pad) end)))) - (cond - ((= end (offset to-pad)) ; we are at the right offset. - nil) - (t ; we have to pad between the - ; old slot's end and the new - ; slot's offset - (mk-padding len end)))))) - + `(let* ((end ,end-form) + (len (abs (- (offset to-pad) end)))) + (cond + ((= end (offset to-pad)) ; we are at the right offset. + nil) + (t ; we have to pad between the + ; old slot's end and the new + ; slot's offset + (mk-padding len end)))))) + (defmethod pad-to-offset-of (to-pad (parent struct)) (skel (if (null (children parent)) - 0 - (+ (size parent) (offset parent))))) + 0 + (+ (size parent) (offset parent))))) (defmethod pad-to-offset-of (to-pad (parent union)) (skel (if (null (children parent)) - (offset to-pad) - (offset parent))))) + (offset to-pad) + (offset parent))))) (defgeneric replace-by-union (in-st element new-element)) (defmethod replace-by-union ((in-st struct) elt new-elt) (setf (children in-st) (remove elt (children in-st))) (let ((padding (pad-to-offset-of new-elt in-st))) (setf (children in-st) - (nconc (children in-st) - (list (mk-union (offset elt) - elt - (if padding - (mk-struct (offset elt) - padding - new-elt) - new-elt))))))) + (nconc (children in-st) + (list (mk-union (offset elt) + elt + (if padding + (mk-struct (offset elt) + padding + new-elt) + new-elt))))))) (defmethod replace-by-union ((in-st union) elt new-elt) (let ((padding (pad-to-offset-of new-elt in-st))) (setf (children in-st) - (nconc (children in-st) - (list (if padding - (mk-struct (offset in-st) - padding - new-elt) - new-elt)))))) + (nconc (children in-st) + (list (if padding + (mk-struct (offset in-st) + padding + new-elt) + new-elt)))))) (defgeneric insert-element (root new-elt)) (defmethod insert-element ((root struct) (new-elt slot)) (let ((overlaps (find-overlaps root new-elt))) (cond (overlaps (let ((last-structure (first (last overlaps 2))) - (last-val (first (last overlaps)))) - (replace-by-union last-structure last-val new-elt) - root)) + (last-val (first (last overlaps)))) + (replace-by-union last-structure last-val new-elt) + root)) (t (let ((padding (pad-to-offset-of new-elt root))) - (setf (children root) - (nconc (children root) - (when padding (list padding)) - (list new-elt))))))) + (setf (children root) + (nconc (children root) + (when padding (list padding)) + (list new-elt))))))) root) (defun sane-slot (alien-var &rest slots) "Emulates the SB-ALIEN:SLOT interface, with useful argument order for deeply nested structures." (labels ((rewriter (slots) - (if (null slots) - alien-var - `(sb-alien:slot ,(rewriter (rest slots)) - ',(first slots))))) + (if (null slots) + alien-var + `(sb-alien:slot ,(rewriter (rest slots)) + ',(first slots))))) (rewriter slots))) (defgeneric accessor-modifier-for (element-type accessor-type)) @@ -265,12 +265,12 @@ deeply nested structures." (defmethod accessor-modifier-for (element-type (accessor-type (eql :getter))) 'identity-1) (defmethod accessor-modifier-for ((element-type (eql 'C-STRING)) - (accessor-type (eql :getter))) + (accessor-type (eql :getter))) 'c-string->lisp-string) (defmethod accessor-modifier-for (element-type (accessor-type (eql :setter))) nil) (defmethod accessor-modifier-for ((element-type (eql 'C-STRING)) - (accessor-type (eql :setter))) + (accessor-type (eql :setter))) 'c-string->lisp-string) (defun c-string->lisp-string (string &optional limit) @@ -280,10 +280,10 @@ deeply nested structures." (defun (setf c-string->lisp-string) (new-string alien &optional limit) (declare (string new-string)) (let* ((upper-bound (or limit (1+ (length new-string)))) - (last-elt (min (1- upper-bound) (length new-string)))) + (last-elt (min (1- upper-bound) (length new-string)))) (loop for i upfrom 0 below last-elt - for char across new-string - do (setf (deref alien i) (char-code char))) + for char across new-string + do (setf (deref alien i) (char-code char))) (setf (deref alien last-elt) 0) (subseq new-string 0 last-elt))) @@ -294,33 +294,33 @@ deeply nested structures." (defmethod accessors-for (struct-name (root value-slot) path) (let ((rpath (reverse path)) - (accessor-name (format nil "~A-~A" - (symbol-name struct-name) - (symbol-name (name root))))) + (accessor-name (format nil "~A-~A" + (symbol-name struct-name) + (symbol-name (name root))))) (labels ((accessor (root rpath) - (apply #'sane-slot 'struct (mapcar 'name (append (rest rpath) (list root)))))) + (apply #'sane-slot 'struct (mapcar 'name (append (rest rpath) (list root)))))) `((declaim (inline ,(intern accessor-name) - (setf ,(intern accessor-name)))) - (defun ,(intern accessor-name) (struct) - (declare (cl:type (alien (* ,struct-name)) struct) - (optimize (speed 3))) - (,(accessor-modifier-for (reintern (type root) (find-package :sb-grovel)) - :getter) - ,(accessor root rpath) ,(size root))) - (defun (setf ,(intern accessor-name)) (new-val struct) - (declare (cl:type (alien (* ,struct-name)) struct) - (cl:type ,(lisp-type-for (type root) (size root)) new-val) - (optimize (speed 3))) - ,(let* ((accessor-modifier (accessor-modifier-for (reintern (type root) - (find-package :sb-grovel)) - :setter)) - (modified-accessor (if accessor-modifier - `(,accessor-modifier ,(accessor root rpath) ,(size root)) - (accessor root rpath)))) - - `(setf ,modified-accessor new-val))) - (defconstant ,(intern (format nil "OFFSET-OF-~A" accessor-name)) - ,(offset root)))))) + (setf ,(intern accessor-name)))) + (defun ,(intern accessor-name) (struct) + (declare (cl:type (alien (* ,struct-name)) struct) + (optimize (speed 3))) + (,(accessor-modifier-for (reintern (type root) (find-package :sb-grovel)) + :getter) + ,(accessor root rpath) ,(size root))) + (defun (setf ,(intern accessor-name)) (new-val struct) + (declare (cl:type (alien (* ,struct-name)) struct) + (cl:type ,(lisp-type-for (type root) (size root)) new-val) + (optimize (speed 3))) + ,(let* ((accessor-modifier (accessor-modifier-for (reintern (type root) + (find-package :sb-grovel)) + :setter)) + (modified-accessor (if accessor-modifier + `(,accessor-modifier ,(accessor root rpath) ,(size root)) + (accessor root rpath)))) + + `(setf ,modified-accessor new-val))) + (defconstant ,(intern (format nil "OFFSET-OF-~A" accessor-name)) + ,(offset root)))))) @@ -330,64 +330,64 @@ deeply nested structures." (defgeneric generate-struct-definition (struct-name root path)) (defmethod generate-struct-definition (struct-name (root structured-type) path) (let ((naccessors (accessors-for struct-name root path)) - (nslots nil)) + (nslots nil)) (dolist (child (children root)) (multiple-value-bind (slots accessors) - (generate-struct-definition struct-name child (cons root path)) - (setf nslots (nconc nslots slots)) - (setf naccessors (nconc naccessors accessors)))) + (generate-struct-definition struct-name child (cons root path)) + (setf nslots (nconc nslots slots)) + (setf naccessors (nconc naccessors accessors)))) (values `((,(name root) (,(type-of root) ,(name root) ,@nslots))) - naccessors))) + naccessors))) (defmethod generate-struct-definition (struct-name (root value-slot) path) (values `((,(name root) ,(alien-type-for (type root) (size root)))) - (accessors-for struct-name root path))) + (accessors-for struct-name root path))) (defmacro define-c-struct (name size &rest elements) (multiple-value-bind (struct-elements accessors) (let* ((root (make-instance 'struct :name name :children nil :offset 0))) - (loop for e in (sort elements #'< :key #'fourth) - do (insert-element root (apply 'mk-val e)) - finally (return root)) - (setf (children root) - (nconc (children root) - (list - (mk-padding (max 0 (- size - (size root))) - (size root))))) - (generate-struct-definition name root nil)) + (loop for e in (sort elements #'< :key #'fourth) + do (insert-element root (apply 'mk-val e)) + finally (return root)) + (setf (children root) + (nconc (children root) + (list + (mk-padding (max 0 (- size + (size root))) + (size root))))) + (generate-struct-definition name root nil)) `(progn (sb-alien:define-alien-type ,@(first struct-elements)) ,@accessors (defmacro ,(intern (format nil "WITH-~A" name)) (var (&rest field-values) &body body) - (labels ((field-name (x) - (intern (concatenate 'string - (symbol-name ',name) "-" - (symbol-name x)) - ,(symbol-package name)))) - `(sb-alien:with-alien ((,var (* ,',name) ,'(,(intern (format nil "ALLOCATE-~A" name))))) - (unwind-protect - (progn - (progn ,@(mapcar (lambda (pair) - `(setf (,(field-name (first pair)) ,var) ,(second pair))) - field-values)) - ,@body) - (funcall ',',(intern (format nil "FREE-~A" name)) ,var))))) + (labels ((field-name (x) + (intern (concatenate 'string + (symbol-name ',name) "-" + (symbol-name x)) + ,(symbol-package name)))) + `(sb-alien:with-alien ((,var (* ,',name) ,'(,(intern (format nil "ALLOCATE-~A" name))))) + (unwind-protect + (progn + (progn ,@(mapcar (lambda (pair) + `(setf (,(field-name (first pair)) ,var) ,(second pair))) + field-values)) + ,@body) + (funcall ',',(intern (format nil "FREE-~A" name)) ,var))))) (defconstant ,(intern (format nil "SIZE-OF-~A" name)) ,size) (defun ,(intern (format nil "ALLOCATE-~A" name)) () - (let* ((o (sb-alien:make-alien ,name)) - (c-o (cast o (* (unsigned 8))))) - ;; we have to initialize the object to all-0 before we can - ;; expect to make sensible use of it - the object returned - ;; by make-alien is initialized to all-D0 bytes. - - ;; FIXME: This should be fixed in sb-alien, where better - ;; optimizations might be possible. - (loop for i from 0 below ,size - do (setf (deref c-o i) 0)) - o)) + (let* ((o (sb-alien:make-alien ,name)) + (c-o (cast o (* (unsigned 8))))) + ;; we have to initialize the object to all-0 before we can + ;; expect to make sensible use of it - the object returned + ;; by make-alien is initialized to all-D0 bytes. + + ;; FIXME: This should be fixed in sb-alien, where better + ;; optimizations might be possible. + (loop for i from 0 below ,size + do (setf (deref c-o i) 0)) + o)) (defun ,(intern (format nil "FREE-~A" name)) (o) - (sb-alien:free-alien o))))) + (sb-alien:free-alien o))))) (defun foreign-nullp (c) "C is a pointer to 0?" diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp index 963ac0f..c48eb28 100644 --- a/contrib/sb-introspect/sb-introspect.lisp +++ b/contrib/sb-introspect/sb-introspect.lisp @@ -29,17 +29,17 @@ (defpackage :sb-introspect (:use "CL") (:export "FUNCTION-ARGLIST" - "VALID-FUNCTION-NAME-P" - "FIND-DEFINITION-SOURCE" - "DEFINITION-SOURCE" - "DEFINITION-SOURCE-PATHNAME" - "DEFINITION-SOURCE-FORM-PATH" - "DEFINITION-SOURCE-CHARACTER-OFFSET" - "DEFINITION-SOURCE-FILE-WRITE-DATE" - "DEFINITION-SOURCE-PLIST" - "DEFINITION-NOT-FOUND" "DEFINITION-NAME" - "FIND-FUNCTION-CALLEES" - "FIND-FUNCTION-CALLERS")) + "VALID-FUNCTION-NAME-P" + "FIND-DEFINITION-SOURCE" + "DEFINITION-SOURCE" + "DEFINITION-SOURCE-PATHNAME" + "DEFINITION-SOURCE-FORM-PATH" + "DEFINITION-SOURCE-CHARACTER-OFFSET" + "DEFINITION-SOURCE-FILE-WRITE-DATE" + "DEFINITION-SOURCE-PLIST" + "DEFINITION-NOT-FOUND" "DEFINITION-NAME" + "FIND-FUNCTION-CALLEES" + "FIND-FUNCTION-CALLERS")) (in-package :sb-introspect) @@ -162,7 +162,7 @@ include the pathname of the file and the position of the definition." (let ((self (sb-vm::%simple-fun-self function))) ;; FIXME there are other kinds of struct accessor. Fill out this list (member self (list *struct-slotplace-reader* - *struct-slotplace-writer*)))) + *struct-slotplace-writer*)))) (defun struct-predicate-p (function) (let ((self (sb-vm::%simple-fun-self function))) @@ -174,22 +174,22 @@ include the pathname of the file and the position of the definition." "Describe the lambda list for the function designator FUNCTION. Works for special-operators, macros, simple functions and generic functions. Signals error if not found" - (cond ((valid-function-name-p function) + (cond ((valid-function-name-p function) (function-arglist - (or (macro-function function) (fdefinition function)))) + (or (macro-function function) (fdefinition function)))) ((typep function 'generic-function) (sb-pcl::generic-function-pretty-arglist function)) - (t (sb-impl::%simple-fun-arglist - (sb-impl::%closure-fun function))))) + (t (sb-impl::%simple-fun-arglist + (sb-impl::%closure-fun function))))) (defun struct-accessor-structure-class (function) (let ((self (sb-vm::%simple-fun-self function))) (cond ((member self (list *struct-slotplace-reader* *struct-slotplace-writer*)) (find-class - (sb-kernel::classoid-name - (sb-kernel::layout-classoid - (sb-kernel:%closure-index-ref function 1))))) + (sb-kernel::classoid-name + (sb-kernel::layout-classoid + (sb-kernel:%closure-index-ref function 1))))) ))) (defun struct-predicate-structure-class (function) @@ -197,14 +197,14 @@ functions. Signals error if not found" (cond ((member self (list *struct-predicate*)) (find-class - (sb-kernel::classoid-name - (sb-kernel::layout-classoid - (sb-kernel:%closure-index-ref function 0))))) + (sb-kernel::classoid-name + (sb-kernel::layout-classoid + (sb-kernel:%closure-index-ref function 0))))) ))) ;;;; find callers/callees, liberated from Helmut Eller's code in SLIME -;;; This interface is trmendously experimental. +;;; This interface is trmendously experimental. ;;; For the moment I'm taking the view that FDEFN is an internal ;;; object (one out of one CMUCL developer surveyed didn't know what @@ -219,39 +219,39 @@ functions. Signals error if not found" (defun find-function-callees (function) "Return functions called by FUNCTION." (let ((callees '())) - (map-code-constants + (map-code-constants (sb-kernel:fun-code-header function) (lambda (obj) (when (sb-kernel:fdefn-p obj) - (push (sb-kernel:fdefn-fun obj) - callees)))) + (push (sb-kernel:fdefn-fun obj) + callees)))) callees)) -(defun find-function-callers (function &optional (spaces '(:read-only :static - :dynamic))) +(defun find-function-callers (function &optional (spaces '(:read-only :static + :dynamic))) "Return functions which call FUNCTION, by searching SPACES for code objects" (let ((referrers '())) - (map-caller-code-components + (map-caller-code-components function spaces (lambda (code) (let ((entry (sb-kernel:%code-entry-points code))) - (cond ((not entry) - (push (princ-to-string code) referrers)) - (t - (loop for e = entry then (sb-kernel::%simple-fun-next e) - while e - do (pushnew e referrers))))))) + (cond ((not entry) + (push (princ-to-string code) referrers)) + (t + (loop for e = entry then (sb-kernel::%simple-fun-next e) + while e + do (pushnew e referrers))))))) referrers)) (declaim (inline map-code-constants)) (defun map-code-constants (code fn) "Call FN for each constant in CODE's constant pool." (check-type code sb-kernel:code-component) - (loop for i from sb-vm:code-constants-offset below - (sb-kernel:get-header-data code) - do (funcall fn (sb-kernel:code-header-ref code i)))) + (loop for i from sb-vm:code-constants-offset below + (sb-kernel:get-header-data code) + do (funcall fn (sb-kernel:code-header-ref code i)))) (declaim (inline map-allocated-code-components)) (defun map-allocated-code-components (spaces fn) @@ -262,7 +262,7 @@ list of the symbols :dynamic, :static, or :read-only." (sb-vm::map-allocated-objects (lambda (obj header size) (when (= sb-vm:code-header-widetag header) - (funcall fn obj size))) + (funcall fn obj size))) space))) (declaim (inline map-caller-code-components)) @@ -271,15 +271,15 @@ list of the symbols :dynamic, :static, or :read-only." constant pool." (let ((function (coerce function 'function))) (map-allocated-code-components - spaces + spaces (lambda (obj size) (declare (ignore size)) - (map-code-constants - obj - (lambda (constant) - (when (and (sb-kernel:fdefn-p constant) - (eq (sb-kernel:fdefn-fun constant) - function)) - (funcall fn obj)))))))) + (map-code-constants + obj + (lambda (constant) + (when (and (sb-kernel:fdefn-p constant) + (eq (sb-kernel:fdefn-fun constant) + function)) + (funcall fn obj)))))))) (provide 'sb-introspect) diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp index d14d627..b93d3de 100644 --- a/contrib/sb-introspect/test-driver.lisp +++ b/contrib/sb-introspect/test-driver.lisp @@ -8,15 +8,15 @@ (load (compile-file (merge-pathnames "test.lisp" *load-pathname*)))) (assert (equal (function-arglist 'cl-user::one) - '(cl-user::a cl-user::b cl-user::c))) + '(cl-user::a cl-user::b cl-user::c))) (assert (equal (function-arglist 'the) - '(type sb-c::value))) + '(type sb-c::value))) (let ((source (find-definition-source 'cl-user::one))) (assert (= (definition-source-file-write-date source) - (file-write-date (merge-pathnames "test.lisp" *load-pathname*)))) + (file-write-date (merge-pathnames "test.lisp" *load-pathname*)))) (assert (equal (getf (definition-source-plist source) :test-outer) - "OUT"))) + "OUT"))) (let ((plist (definition-source-plist (find-definition-source 'cl-user::four)))) (assert (equal (getf plist :test-outer) "OUT")) @@ -25,7 +25,7 @@ (defun matchp (object form-number) (let ((ds (sb-introspect:find-definition-source object))) (and (pathnamep (sb-introspect:definition-source-pathname ds)) - (= form-number + (= form-number (first (sb-introspect:definition-source-form-path ds)))))) (assert (matchp 'cl-user::one 2)) diff --git a/contrib/sb-md5/md5-tests.lisp b/contrib/sb-md5/md5-tests.lisp index 82183b3..c0f8da1 100644 --- a/contrib/sb-md5/md5-tests.lisp +++ b/contrib/sb-md5/md5-tests.lisp @@ -4,16 +4,16 @@ (macrolet ((define-rfc1321-tests (test-list) - `(progn - ,@(loop for i upfrom 0 - for (string . expected-result) in test-list - collect - `(deftest ,(intern (format nil "SB-MD5.RFC1321.~A" i)) - (string= (format nil - "~(~{~2,'0X~}~)" - (coerce (md5sum-string ,string :external-format :ascii) 'list)) - ,expected-result) - t))))) + `(progn + ,@(loop for i upfrom 0 + for (string . expected-result) in test-list + collect + `(deftest ,(intern (format nil "SB-MD5.RFC1321.~A" i)) + (string= (format nil + "~(~{~2,'0X~}~)" + (coerce (md5sum-string ,string :external-format :ascii) 'list)) + ,expected-result) + t))))) (define-rfc1321-tests (("" . "d41d8cd98f00b204e9800998ecf8427e") ("a" ."0cc175b9c0f1b6a831c399e269772661") @@ -25,16 +25,16 @@ (macrolet ((define-other-tests (test-list) - `(progn - ,@(loop for i upfrom 0 - for (string . expected-result) in test-list - collect - `(deftest ,(intern (format nil "SB-MD5.OTHER.~A" i)) - (string= - (format nil "~(~{~2,'0X~}~)" + `(progn + ,@(loop for i upfrom 0 + for (string . expected-result) in test-list + collect + `(deftest ,(intern (format nil "SB-MD5.OTHER.~A" i)) + (string= + (format nil "~(~{~2,'0X~}~)" (coerce (md5sum-string ,string :external-format :ascii) 'list)) - ,expected-result) - t))))) + ,expected-result) + t))))) (define-other-tests (;; From padding bug report by Edi Weitz ("1631901HERR BUCHHEISTERCITROEN NORD1043360796beckenbauer" . "d734945e5930bb28859ccd13c830358b") @@ -112,7 +112,7 @@ (deftest sb-md5.md5sum-file.0 (string= (format nil "~(~{~2,'0X~}~)" (coerce (md5sum-file "/dev/null") 'list)) - "d41d8cd98f00b204e9800998ecf8427e") + "d41d8cd98f00b204e9800998ecf8427e") t) (deftest sb-md5.md5sum-sequence.error.0 diff --git a/contrib/sb-md5/md5.lisp b/contrib/sb-md5/md5.lisp index ab006e9..4d7edac 100644 --- a/contrib/sb-md5/md5.lisp +++ b/contrib/sb-md5/md5.lisp @@ -73,29 +73,29 @@ where a is the intended low-order byte and d the high-order byte." ;;; Section 3.4: Auxilliary functions (declaim (inline f g h i) - (ftype (function (ub32 ub32 ub32) ub32) f g h i)) + (ftype (function (ub32 ub32 ub32) ub32) f g h i)) (defun f (x y z) (declare (type ub32 x y z) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+cmu (kernel:32bit-logical-or (kernel:32bit-logical-and x y) - (kernel:32bit-logical-andc1 x z)) + (kernel:32bit-logical-andc1 x z)) #-cmu (logior (logand x y) (logandc1 x z))) (defun g (x y z) (declare (type ub32 x y z) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+cmu (kernel:32bit-logical-or (kernel:32bit-logical-and x z) - (kernel:32bit-logical-andc2 y z)) + (kernel:32bit-logical-andc2 y z)) #-cmu (logior (logand x z) (logandc2 y z))) (defun h (x y z) (declare (type ub32 x y z) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+cmu (kernel:32bit-logical-xor x (kernel:32bit-logical-xor y z)) #-cmu @@ -103,14 +103,14 @@ where a is the intended low-order byte and d the high-order byte." (defun i (x y z) (declare (type ub32 x y z) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+cmu (kernel:32bit-logical-xor y (kernel:32bit-logical-orc2 x z)) #-cmu (ldb (byte 32 0) (logxor y (logorc2 x z)))) (declaim (inline mod32+) - (ftype (function (ub32 ub32) ub32) mod32+)) + (ftype (function (ub32 ub32) ub32) mod32+)) (defun mod32+ (a b) (declare (type ub32 a b) (optimize (speed 3) (safety 0) (space 0) (debug 0))) (ldb (byte 32 0) (+ a b))) @@ -126,14 +126,14 @@ where a is the intended low-order byte and d the high-order byte." `(ldb (byte 32 0) (+ ,a ,b))) (declaim (inline rol32) - (ftype (function (ub32 (unsigned-byte 5)) ub32) rol32)) + (ftype (function (ub32 (unsigned-byte 5)) ub32) rol32)) (defun rol32 (a s) (declare (type ub32 a) (type (unsigned-byte 5) s) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+cmu (kernel:32bit-logical-or #+little-endian (kernel:shift-towards-end a s) - #+big-endian (kernel:shift-towards-start a s) - (ash a (- s 32))) + #+big-endian (kernel:shift-towards-start a s) + (ash a (- s 32))) #+sbcl (sb-rotate-byte:rotate-byte s (byte 32 0) a) #-(or cmu sbcl) @@ -143,25 +143,25 @@ where a is the intended low-order byte and d the high-order byte." (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *t* (make-array 64 :element-type 'ub32 - :initial-contents - (loop for i from 1 to 64 - collect - (truncate - (* 4294967296 - (abs (sin (float i 0.0d0))))))))) + :initial-contents + (loop for i from 1 to 64 + collect + (truncate + (* 4294967296 + (abs (sin (float i 0.0d0))))))))) ;;; Section 3.4: Helper Macro for single round definitions (defmacro with-md5-round ((op block) &rest clauses) (loop for (a b c d k s i) in clauses - collect - `(setq ,a (mod32+ ,b (rol32 (mod32+ (mod32+ ,a (,op ,b ,c ,d)) - (mod32+ (aref ,block ,k) - ,(aref *t* (1- i)))) - ,s))) - into result - finally - (return `(progn ,@result)))) + collect + `(setq ,a (mod32+ ,b (rol32 (mod32+ (mod32+ ,a (,op ,b ,c ,d)) + (mod32+ (aref ,block ,k) + ,(aref *t* (1- i)))) + ,s))) + into result + finally + (return `(progn ,@result)))) ;;; Section 3.3: (Initial) MD5 Working Set @@ -198,9 +198,9 @@ registers A, B, C and D." (let ((regs (make-array 4 :element-type '(unsigned-byte 32)))) (declare (type md5-regs regs)) (setf (md5-regs-a regs) +md5-magic-a+ - (md5-regs-b regs) +md5-magic-b+ - (md5-regs-c regs) +md5-magic-c+ - (md5-regs-d regs) +md5-magic-d+) + (md5-regs-b regs) +md5-magic-b+ + (md5-regs-c regs) +md5-magic-c+ + (md5-regs-d regs) +md5-magic-d+) regs)) ;;; Section 3.4: Operation on 16-Word Blocks @@ -210,10 +210,10 @@ registers A, B, C and D." word block of input, and updates the working state in A, B, C, and D accordingly." (declare (type md5-regs regs) - (type (simple-array ub32 (16)) block) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (type (simple-array ub32 (16)) block) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) (let ((a (md5-regs-a regs)) (b (md5-regs-b regs)) - (c (md5-regs-c regs)) (d (md5-regs-d regs))) + (c (md5-regs-c regs)) (d (md5-regs-d regs))) (declare (type ub32 a b c d)) ;; Round 1 (with-md5-round (f block) @@ -241,9 +241,9 @@ accordingly." (A B C D 4 6 61)(D A B C 11 10 62)(C D A B 2 15 63)(B C D A 9 21 64)) ;; Update and return (setf (md5-regs-a regs) (mod32+ (md5-regs-a regs) a) - (md5-regs-b regs) (mod32+ (md5-regs-b regs) b) - (md5-regs-c regs) (mod32+ (md5-regs-c regs) c) - (md5-regs-d regs) (mod32+ (md5-regs-d regs) d)) + (md5-regs-b regs) (mod32+ (md5-regs-b regs) b) + (md5-regs-c regs) (mod32+ (md5-regs-c regs) c) + (md5-regs-d regs) (mod32+ (md5-regs-d regs) d)) regs)) ;;; Section 3.4: Converting 8bit-vectors into 16-Word Blocks @@ -255,9 +255,9 @@ word MD5 block. This currently works on (unsigned-byte 8) and character simple-arrays, via the functions `fill-block-ub8' and `fill-block-char' respectively." (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) - (type (simple-array ub32 (16)) block) - (type (simple-array * (*)) buffer) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (type (simple-array ub32 (16)) block) + (type (simple-array * (*)) buffer) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) (etypecase buffer ((simple-array (unsigned-byte 8) (*)) (fill-block-ub8 block buffer offset)) @@ -268,9 +268,9 @@ character simple-arrays, via the functions `fill-block-ub8' and "Convert a complete 64 (unsigned-byte 8) input vector segment starting from offset into the given 16 word MD5 block." (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) - (type (simple-array ub32 (16)) block) - (type (simple-array (unsigned-byte 8) (*)) buffer) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (type (simple-array ub32 (16)) block) + (type (simple-array (unsigned-byte 8) (*)) buffer) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+(and :cmu :little-endian) (kernel:bit-bash-copy buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) @@ -280,22 +280,22 @@ starting from offset into the given 16 word MD5 block." (sb-kernel:ub8-bash-copy buffer offset block 0 64) #-(or (and :sbcl :little-endian) (and :cmu :little-endian)) (loop for i of-type (integer 0 16) from 0 - for j of-type (integer 0 #.most-positive-fixnum) - from offset to (+ offset 63) by 4 - do - (setf (aref block i) - (assemble-ub32 (aref buffer j) - (aref buffer (+ j 1)) - (aref buffer (+ j 2)) - (aref buffer (+ j 3)))))) + for j of-type (integer 0 #.most-positive-fixnum) + from offset to (+ offset 63) by 4 + do + (setf (aref block i) + (assemble-ub32 (aref buffer j) + (aref buffer (+ j 1)) + (aref buffer (+ j 2)) + (aref buffer (+ j 3)))))) (defun fill-block-char (block buffer offset) "Convert a complete 64 character input string segment starting from offset into the given 16 word MD5 block." (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) - (type (simple-array ub32 (16)) block) - (type simple-string buffer) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (type (simple-array ub32 (16)) block) + (type simple-string buffer) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+(and :cmu :little-endian) (kernel:bit-bash-copy buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) @@ -305,14 +305,14 @@ offset into the given 16 word MD5 block." (sb-kernel:ub8-bash-copy buffer offset block 0 64) #-(or (and :sbcl :little-endian) (and :cmu :little-endian)) (loop for i of-type (integer 0 16) from 0 - for j of-type (integer 0 #.most-positive-fixnum) - from offset to (+ offset 63) by 4 - do - (setf (aref block i) - (assemble-ub32 (char-code (schar buffer j)) - (char-code (schar buffer (+ j 1))) - (char-code (schar buffer (+ j 2))) - (char-code (schar buffer (+ j 3))))))) + for j of-type (integer 0 #.most-positive-fixnum) + from offset to (+ offset 63) by 4 + do + (setf (aref block i) + (assemble-ub32 (char-code (schar buffer j)) + (char-code (schar buffer (+ j 1))) + (char-code (schar buffer (+ j 2))) + (char-code (schar buffer (+ j 3))))))) ;;; Section 3.5: Message Digest Output @@ -321,18 +321,18 @@ offset into the given 16 word MD5 block." "Create the final 16 byte message-digest from the MD5 working state in regs. Returns a (simple-array (unsigned-byte 8) (16))." (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) - (type md5-regs regs)) + (type md5-regs regs)) (let ((result (make-array 16 :element-type '(unsigned-byte 8)))) (declare (type (simple-array (unsigned-byte 8) (16)) result)) (macrolet ((frob (reg offset) - (let ((var (gensym))) - `(let ((,var ,reg)) - (declare (type ub32 ,var)) - (setf - (aref result ,offset) (ldb (byte 8 0) ,var) - (aref result ,(+ offset 1)) (ldb (byte 8 8) ,var) - (aref result ,(+ offset 2)) (ldb (byte 8 16) ,var) - (aref result ,(+ offset 3)) (ldb (byte 8 24) ,var)))))) + (let ((var (gensym))) + `(let ((,var ,reg)) + (declare (type ub32 ,var)) + (setf + (aref result ,offset) (ldb (byte 8 0) ,var) + (aref result ,(+ offset 1)) (ldb (byte 8 8) ,var) + (aref result ,(+ offset 2)) (ldb (byte 8 16) ,var) + (aref result ,(+ offset 3)) (ldb (byte 8 24) ,var)))))) (frob (md5-regs-a regs) 0) (frob (md5-regs-b regs) 4) (frob (md5-regs-c regs) 8) @@ -342,16 +342,16 @@ in regs. Returns a (simple-array (unsigned-byte 8) (16))." ;;; Mid-Level Drivers (defstruct (md5-state - (:constructor make-md5-state ()) - (:copier)) + (:constructor make-md5-state ()) + (:copier)) (regs (initial-md5-regs) :type md5-regs :read-only t) (amount 0 :type - #-md5-small-length (integer 0 *) - #+md5-small-length (unsigned-byte 29)) + #-md5-small-length (integer 0 *) + #+md5-small-length (unsigned-byte 29)) (block (make-array 16 :element-type '(unsigned-byte 32)) :read-only t - :type (simple-array (unsigned-byte 32) (16))) + :type (simple-array (unsigned-byte 32) (16))) (buffer (make-array 64 :element-type '(unsigned-byte 8)) :read-only t - :type (simple-array (unsigned-byte 8) (64))) + :type (simple-array (unsigned-byte 8) (64))) (buffer-index 0 :type (integer 0 63)) (finalized-p nil)) @@ -361,15 +361,15 @@ in regs. Returns a (simple-array (unsigned-byte 8) (16))." from-offset and copying count elements into the 64 byte buffer starting at buffer-offset." (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) - (type (unsigned-byte 29) from-offset) - (type (integer 0 63) count buffer-offset) - (type (simple-array * (*)) from) - (type (simple-array (unsigned-byte 8) (64)) buffer)) + (type (unsigned-byte 29) from-offset) + (type (integer 0 63) count buffer-offset) + (type (simple-array * (*)) from) + (type (simple-array (unsigned-byte 8) (64)) buffer)) #+cmu (kernel:bit-bash-copy from (+ (* vm:vector-data-offset vm:word-bits) (* from-offset vm:byte-bits)) buffer (+ (* vm:vector-data-offset vm:word-bits) - (* buffer-offset vm:byte-bits)) + (* buffer-offset vm:byte-bits)) (* count vm:byte-bits)) #+sbcl (sb-kernel:ub8-bash-copy from from-offset buffer buffer-offset count) @@ -377,82 +377,82 @@ starting at buffer-offset." (etypecase from (simple-string (loop for buffer-index of-type (integer 0 64) from buffer-offset - for from-index of-type fixnum from from-offset - below (+ from-offset count) - do - (setf (aref buffer buffer-index) - (char-code (schar (the simple-string from) from-index))))) + for from-index of-type fixnum from from-offset + below (+ from-offset count) + do + (setf (aref buffer buffer-index) + (char-code (schar (the simple-string from) from-index))))) ((simple-array (unsigned-byte 8) (*)) (loop for buffer-index of-type (integer 0 64) from buffer-offset - for from-index of-type fixnum from from-offset - below (+ from-offset count) - do - (setf (aref buffer buffer-index) - (aref (the (simple-array (unsigned-byte 8) (*)) from) - from-index)))))) + for from-index of-type fixnum from from-offset + below (+ from-offset count) + do + (setf (aref buffer buffer-index) + (aref (the (simple-array (unsigned-byte 8) (*)) from) + from-index)))))) (defun update-md5-state (state sequence &key (start 0) (end (length sequence))) "Update the given md5-state from sequence, which is either a simple-string or a simple-array with element-type (unsigned-byte 8), bounded by start and end, which must be numeric bounding-indices." (declare (type md5-state state) - (type (simple-array * (*)) sequence) - (type fixnum start end) - (optimize (speed 3) #+(or cmu sbcl) (safety 0) (space 0) (debug 0)) - #+cmu - (ext:optimize-interface (safety 1) (debug 1))) + (type (simple-array * (*)) sequence) + (type fixnum start end) + (optimize (speed 3) #+(or cmu sbcl) (safety 0) (space 0) (debug 0)) + #+cmu + (ext:optimize-interface (safety 1) (debug 1))) (let ((regs (md5-state-regs state)) - (block (md5-state-block state)) - (buffer (md5-state-buffer state)) - (buffer-index (md5-state-buffer-index state)) - (length (- end start))) + (block (md5-state-block state)) + (buffer (md5-state-buffer state)) + (buffer-index (md5-state-buffer-index state)) + (length (- end start))) (declare (type md5-regs regs) (type fixnum length) - (type (integer 0 63) buffer-index) - (type (simple-array (unsigned-byte 32) (16)) block) - (type (simple-array (unsigned-byte 8) (64)) buffer)) + (type (integer 0 63) buffer-index) + (type (simple-array (unsigned-byte 32) (16)) block) + (type (simple-array (unsigned-byte 8) (64)) buffer)) ;; Handle old rest (unless (zerop buffer-index) (let ((amount (min (- 64 buffer-index) length))) - (declare (type (integer 0 63) amount)) - (copy-to-buffer sequence start amount buffer buffer-index) - (setq start (the fixnum (+ start amount))) - (when (>= start end) - (setf (md5-state-buffer-index state) (+ buffer-index amount)) - (return-from update-md5-state state))) + (declare (type (integer 0 63) amount)) + (copy-to-buffer sequence start amount buffer buffer-index) + (setq start (the fixnum (+ start amount))) + (when (>= start end) + (setf (md5-state-buffer-index state) (+ buffer-index amount)) + (return-from update-md5-state state))) (fill-block-ub8 block buffer 0) (update-md5-block regs block)) ;; Handle main-part and new-rest (etypecase sequence ((simple-array (unsigned-byte 8) (*)) (locally - (declare (type (simple-array (unsigned-byte 8) (*)) sequence)) - (loop for offset of-type (unsigned-byte 29) from start below end by 64 - until (< (- end offset) 64) - do - (fill-block-ub8 block sequence offset) - (update-md5-block regs block) - finally - (let ((amount (- end offset))) - (unless (zerop amount) - (copy-to-buffer sequence offset amount buffer 0)) - (setf (md5-state-buffer-index state) amount))))) + (declare (type (simple-array (unsigned-byte 8) (*)) sequence)) + (loop for offset of-type (unsigned-byte 29) from start below end by 64 + until (< (- end offset) 64) + do + (fill-block-ub8 block sequence offset) + (update-md5-block regs block) + finally + (let ((amount (- end offset))) + (unless (zerop amount) + (copy-to-buffer sequence offset amount buffer 0)) + (setf (md5-state-buffer-index state) amount))))) (simple-string (locally - (declare (type simple-string sequence)) - (loop for offset of-type (unsigned-byte 29) from start below end by 64 - until (< (- end offset) 64) - do - (fill-block-char block sequence offset) - (update-md5-block regs block) - finally - (let ((amount (- end offset))) - (unless (zerop amount) - (copy-to-buffer sequence offset amount buffer 0)) - (setf (md5-state-buffer-index state) amount)))))) + (declare (type simple-string sequence)) + (loop for offset of-type (unsigned-byte 29) from start below end by 64 + until (< (- end offset) 64) + do + (fill-block-char block sequence offset) + (update-md5-block regs block) + finally + (let ((amount (- end offset))) + (unless (zerop amount) + (copy-to-buffer sequence offset amount buffer 0)) + (setf (md5-state-buffer-index state) amount)))))) (setf (md5-state-amount state) - #-md5-small-length (+ (md5-state-amount state) length) - #+md5-small-length (the (unsigned-byte 29) - (+ (md5-state-amount state) length))) + #-md5-small-length (+ (md5-state-amount state) length) + #+md5-small-length (the (unsigned-byte 29) + (+ (md5-state-amount state) length))) state)) (defun finalize-md5-state (state) @@ -464,41 +464,41 @@ The resulting MD5 message-digest is returned as an array of sixteen (unsigned-byte 8) values. Calling `update-md5-state' after a call to `finalize-md5-state' results in unspecified behaviour." (declare (type md5-state state) - (optimize (speed 3) #+(or cmu sbcl) (safety 0) (space 0) (debug 0)) - #+cmu - (ext:optimize-interface (safety 1) (debug 1))) + (optimize (speed 3) #+(or cmu sbcl) (safety 0) (space 0) (debug 0)) + #+cmu + (ext:optimize-interface (safety 1) (debug 1))) (or (md5-state-finalized-p state) (let ((regs (md5-state-regs state)) - (block (md5-state-block state)) - (buffer (md5-state-buffer state)) - (buffer-index (md5-state-buffer-index state)) - (total-length (* 8 (md5-state-amount state)))) - (declare (type md5-regs regs) - (type (integer 0 63) buffer-index) - (type (simple-array ub32 (16)) block) - (type (simple-array (unsigned-byte 8) (*)) buffer)) - ;; Add mandatory bit 1 padding - (setf (aref buffer buffer-index) #x80) - ;; Fill with 0 bit padding - (loop for index of-type (integer 0 64) - from (1+ buffer-index) below 64 - do (setf (aref buffer index) #x00)) - (fill-block-ub8 block buffer 0) - ;; Flush block first if length wouldn't fit - (when (>= buffer-index 56) - (update-md5-block regs block) - ;; Create new fully 0 padded block - (loop for index of-type (integer 0 16) from 0 below 16 - do (setf (aref block index) #x00000000))) - ;; Add 64bit message bit length - (setf (aref block 14) (ldb (byte 32 0) total-length)) - #-md5-small-length - (setf (aref block 15) (ldb (byte 32 32) total-length)) - ;; Flush last block - (update-md5-block regs block) - ;; Done, remember digest for later calls - (setf (md5-state-finalized-p state) - (md5regs-digest regs))))) + (block (md5-state-block state)) + (buffer (md5-state-buffer state)) + (buffer-index (md5-state-buffer-index state)) + (total-length (* 8 (md5-state-amount state)))) + (declare (type md5-regs regs) + (type (integer 0 63) buffer-index) + (type (simple-array ub32 (16)) block) + (type (simple-array (unsigned-byte 8) (*)) buffer)) + ;; Add mandatory bit 1 padding + (setf (aref buffer buffer-index) #x80) + ;; Fill with 0 bit padding + (loop for index of-type (integer 0 64) + from (1+ buffer-index) below 64 + do (setf (aref buffer index) #x00)) + (fill-block-ub8 block buffer 0) + ;; Flush block first if length wouldn't fit + (when (>= buffer-index 56) + (update-md5-block regs block) + ;; Create new fully 0 padded block + (loop for index of-type (integer 0 16) from 0 below 16 + do (setf (aref block index) #x00000000))) + ;; Add 64bit message bit length + (setf (aref block 14) (ldb (byte 32 0) total-length)) + #-md5-small-length + (setf (aref block 15) (ldb (byte 32 32) total-length)) + ;; Flush last block + (update-md5-block regs block) + ;; Done, remember digest for later calls + (setf (md5-state-finalized-p state) + (md5regs-digest regs))))) ;;; High-Level Drivers @@ -507,21 +507,21 @@ The resulting MD5 message-digest is returned as an array of sixteen in SEQUENCE , which must be a vector with element-type (UNSIGNED-BYTE 8)." (declare (optimize (speed 3) (safety 3) (space 0) (debug 1)) - (type (vector (unsigned-byte 8)) sequence) (type fixnum start)) + (type (vector (unsigned-byte 8)) sequence) (type fixnum start)) (locally (declare (optimize (safety 1) (debug 0))) (let ((state (make-md5-state))) (declare (type md5-state state)) #+cmu (lisp::with-array-data ((data sequence) (real-start start) (real-end end)) - (update-md5-state state data :start real-start :end real-end)) + (update-md5-state state data :start real-start :end real-end)) #+sbcl (sb-kernel:with-array-data ((data sequence) (real-start start) (real-end end)) - (update-md5-state state data :start real-start :end real-end)) + (update-md5-state state data :start real-start :end real-end)) #-(or cmu sbcl) (let ((real-end (or end (length sequence)))) - (declare (type fixnum real-end)) - (update-md5-state state sequence :start start :end real-end)) + (declare (type fixnum real-end)) + (update-md5-state state sequence :start start :end real-end)) (finalize-md5-state state)))) (defun md5sum-string (string &key (external-format :default) (start 0) end) @@ -535,8 +535,8 @@ in the resulting binary representation." (declare (optimize (safety 1) (debug 0))) (md5sum-sequence (sb-ext:string-to-octets string - :external-format external-format - :start start :end end)))) + :external-format external-format + :start start :end end)))) (defconstant +buffer-size+ (* 128 1024) "Size of internal buffer to use for md5sum-stream and md5sum-file @@ -554,28 +554,28 @@ element-type has to be (UNSIGNED-BYTE 8)." (let ((state (make-md5-state))) (declare (type md5-state state)) (cond - ((equal (stream-element-type stream) '(unsigned-byte 8)) - (let ((buffer (make-array +buffer-size+ - :element-type '(unsigned-byte 8)))) - (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+)) - buffer)) - (loop for bytes of-type buffer-index = (read-sequence buffer stream) - do (update-md5-state state buffer :end bytes) - until (< bytes +buffer-size+) - finally - (return (finalize-md5-state state))))) - #+(or) - ((equal (stream-element-type stream) 'character) - (let ((buffer (make-string +buffer-size+))) - (declare (type (simple-string #.+buffer-size+) buffer)) - (loop for bytes of-type buffer-index = (read-sequence buffer stream) - do (update-md5-state state buffer :end bytes) - until (< bytes +buffer-size+) - finally - (return (finalize-md5-state state))))) - (t - (error "Unsupported stream element-type ~S for stream ~S." - (stream-element-type stream) stream)))))) + ((equal (stream-element-type stream) '(unsigned-byte 8)) + (let ((buffer (make-array +buffer-size+ + :element-type '(unsigned-byte 8)))) + (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+)) + buffer)) + (loop for bytes of-type buffer-index = (read-sequence buffer stream) + do (update-md5-state state buffer :end bytes) + until (< bytes +buffer-size+) + finally + (return (finalize-md5-state state))))) + #+(or) + ((equal (stream-element-type stream) 'character) + (let ((buffer (make-string +buffer-size+))) + (declare (type (simple-string #.+buffer-size+) buffer)) + (loop for bytes of-type buffer-index = (read-sequence buffer stream) + do (update-md5-state state buffer :end bytes) + until (< bytes +buffer-size+) + finally + (return (finalize-md5-state state))))) + (t + (error "Unsupported stream element-type ~S for stream ~S." + (stream-element-type stream) stream)))))) (defun md5sum-file (pathname) "Calculate the MD5 message-digest of the file designated by diff --git a/contrib/sb-posix/constants.lisp b/contrib/sb-posix/constants.lisp index 560be59..b2081d8 100644 --- a/contrib/sb-posix/constants.lisp +++ b/contrib/sb-posix/constants.lisp @@ -6,11 +6,11 @@ (#||# "sys/types.h" "sys/stat.h" - + "sys/socket.h" "sys/un.h" "netinet/in.h" "netinet/in_systm.h" "netinet/ip.h" "net/if.h" "netinet/tcp.h" "sys/mman.h" "sys/wait.h" - "fcntl.h" - "netdb.h" "errno.h" + "fcntl.h" + "netdb.h" "errno.h" "dirent.h" "signal.h" "unistd.h" @@ -28,7 +28,7 @@ (:type nlink-t "nlink_t") (:type time-t "time_t") (:type dev-t "dev_t") - + ;; signals (:integer SIGHUP "SIGHUP" #+sb-doc "terminal line hangup." t) (:integer SIGINT "SIGINT" #+sb-doc "interrupt program." t) @@ -195,7 +195,7 @@ (:integer edquot "EDQUOT" nil t) (:integer enomedium "ENOMEDIUM" nil t) (:integer emediumtype "EMEDIUMTYPE" nil t) - + ;; wait (:integer wnohang "WNOHANG") (:integer wuntraced "WUNTRACED") @@ -242,22 +242,22 @@ ;; opendir() (:structure dirent - ("struct dirent" - (:c-string name "char *" "d_name" - :distrust-length #+sunos t #-sunos nil)) t) + ("struct dirent" + (:c-string name "char *" "d_name" + :distrust-length #+sunos t #-sunos nil)) t) (:structure alien-stat - ("struct stat" - (mode-t mode "mode_t" "st_mode") - (ino-t ino "ino_t" "st_ino") - (dev-t dev "dev_t" "st_dev") - (nlink-t nlink "nlink_t" "st_nlink") - (uid-t uid "uid_t" "st_uid") - (gid-t gid "gid_t" "st_gid") - (off-t size "off_t" "st_size") - (time-t atime "time_t" "st_atime") - (time-t mtime "time_t" "st_mtime") - (time-t ctime "time_t" "st_ctime"))) + ("struct stat" + (mode-t mode "mode_t" "st_mode") + (ino-t ino "ino_t" "st_ino") + (dev-t dev "dev_t" "st_dev") + (nlink-t nlink "nlink_t" "st_nlink") + (uid-t uid "uid_t" "st_uid") + (gid-t gid "gid_t" "st_gid") + (off-t size "off_t" "st_size") + (time-t atime "time_t" "st_atime") + (time-t mtime "time_t" "st_mtime") + (time-t ctime "time_t" "st_ctime"))) ;; open() (:integer o-rdonly "O_RDONLY" nil t) @@ -275,7 +275,7 @@ (:integer o-directory "O_DIRECTORY" nil t) (:integer o-direct "O_DIRECT" nil t) (:integer o-async "O_ASYNC" nil t) - (:integer o-largefile "O_LARGEFILE" nil t) ; hmm... + (:integer o-largefile "O_LARGEFILE" nil t) ; hmm... (:integer o-dsync "O_DSYNC" nil t) (:integer o-rsync "O_RSYNC" nil t) @@ -301,15 +301,15 @@ (:type speed-t "speed_t" nil t) (:type tcflag-t "tcflag_t" nil t) (:integer nccs "NCCS" nil t) - + (:structure alien-termios - ("struct termios" - (tcflag-t iflag "tcflag_t" "c_iflag") - (tcflag-t oflag "tcflag_t" "c_oflag") - (tcflag-t cflag "tcflag_t" "c_cflag") - (tcflag-t lflag "tcflag_t" "c_lflag") - ((array cc-t) cc "cc_t" "c_cc"))) - + ("struct termios" + (tcflag-t iflag "tcflag_t" "c_iflag") + (tcflag-t oflag "tcflag_t" "c_oflag") + (tcflag-t cflag "tcflag_t" "c_cflag") + (tcflag-t lflag "tcflag_t" "c_lflag") + ((array cc-t) cc "cc_t" "c_cc"))) + (:integer veof "VEOF" nil t) (:integer veol "VEOL" nil t) (:integer verase "VERASE" nil t) @@ -330,7 +330,7 @@ (:integer inlcr "INLCR" nil t) (:integer inpck "INPCK" nil t) (:integer istrip "ISTRIP" nil t) - #+xsi ; FIXME: an extension, apparently + #+xsi ; FIXME: an extension, apparently (:integer ixany "IXANY" nil t) (:integer ixoff "IXOFF" nil t) (:integer ixon "IXON" nil t) @@ -415,5 +415,5 @@ (:integer tcion "TCION" nil t) (:integer tcooff "TCOOFF" nil t) (:integer tcoon "TCOON" nil t) - + ) diff --git a/contrib/sb-posix/defpackage.lisp b/contrib/sb-posix/defpackage.lisp index 335b095..e539cf3 100644 --- a/contrib/sb-posix/defpackage.lisp +++ b/contrib/sb-posix/defpackage.lisp @@ -1,15 +1,15 @@ (defpackage :sb-posix (:use) (:export #:syscall-error #:syscall-errno - ;; grovel structure accessors - - #:dirent-name - - ;; wrapper class accessors - - #:stat-mode #:stat-ino #:stat-dev #:stat-nlink #:stat-uid - #:stat-gid #:stat-size #:stat-atime #:stat-mtime #:stat-ctime - #:termios-iflag #:termios-oflag #:termios-cflag - #:termios-lflag #:termios-cc)) + ;; grovel structure accessors + + #:dirent-name + + ;; wrapper class accessors + + #:stat-mode #:stat-ino #:stat-dev #:stat-nlink #:stat-uid + #:stat-gid #:stat-size #:stat-atime #:stat-mtime #:stat-ctime + #:termios-iflag #:termios-oflag #:termios-cflag + #:termios-lflag #:termios-cc)) (defpackage :sb-posix-internal (:use #:sb-alien #:cl)) diff --git a/contrib/sb-posix/designator.lisp b/contrib/sb-posix/designator.lisp index b7cd3c3..d49c2fd 100644 --- a/contrib/sb-posix/designator.lisp +++ b/contrib/sb-posix/designator.lisp @@ -3,16 +3,16 @@ (defmacro define-designator (name result &body conversions) (let ((type `(quote (or ,@(mapcar #'car conversions)))) - (typename (intern (format nil "~A-~A" - (symbol-name name) - (symbol-name :designator)) - #.*package*))) + (typename (intern (format nil "~A-~A" + (symbol-name name) + (symbol-name :designator)) + #.*package*))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (deftype ,typename () ,type) - (setf (gethash ',name *designator-types*) ',result)) + (deftype ,typename () ,type) + (setf (gethash ',name *designator-types*) ',result)) (defun ,(intern (symbol-name name) :sb-posix) (,name) - (declare (type ,typename ,name)) - (etypecase ,name - ,@conversions))))) + (declare (type ,typename ,name)) + (etypecase ,name + ,@conversions))))) diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index 0bd5675..1a3e6b2 100644 --- a/contrib/sb-posix/interface.lisp +++ b/contrib/sb-posix/interface.lisp @@ -1,65 +1,65 @@ (cl:in-package :sb-posix-internal) -(defmacro define-protocol-class +(defmacro define-protocol-class (name alien-type superclasses slots &rest options) (let ((to-protocol (intern (format nil "ALIEN-TO-~A" name))) - (to-alien (intern (format nil "~A-TO-ALIEN" name)))) + (to-alien (intern (format nil "~A-TO-ALIEN" name)))) `(progn - (defclass ,name ,superclasses - ,(loop for slotd in slots - collect (ldiff slotd (member :array-length slotd))) - ,@options) + (defclass ,name ,superclasses + ,(loop for slotd in slots + collect (ldiff slotd (member :array-length slotd))) + ,@options) (declaim (inline ,to-alien ,to-protocol)) (defun ,to-protocol (alien &optional instance) - (declare (type (sb-alien:alien (* ,alien-type)) alien) - (type (or null ,name) instance)) - (unless instance - (setf instance (make-instance ',name))) - ,@(loop for slotd in slots - ;; FIXME: slotds in source are more complicated in general - ;; - ;; FIXME: baroque construction of intricate fragility - for array-length = (getf (cdr slotd) :array-length) - if array-length - collect `(progn - (let ((array (make-array ,array-length))) - (setf (slot-value instance ',(car slotd)) - array) - (dotimes (i ,array-length) - (setf (aref array i) - (sb-alien:deref - (sb-alien:slot alien ',(car slotd)) - i))))) - else - collect `(setf (slot-value instance ',(car slotd)) - (sb-alien:slot alien ',(car slotd)))) - instance) + (declare (type (sb-alien:alien (* ,alien-type)) alien) + (type (or null ,name) instance)) + (unless instance + (setf instance (make-instance ',name))) + ,@(loop for slotd in slots + ;; FIXME: slotds in source are more complicated in general + ;; + ;; FIXME: baroque construction of intricate fragility + for array-length = (getf (cdr slotd) :array-length) + if array-length + collect `(progn + (let ((array (make-array ,array-length))) + (setf (slot-value instance ',(car slotd)) + array) + (dotimes (i ,array-length) + (setf (aref array i) + (sb-alien:deref + (sb-alien:slot alien ',(car slotd)) + i))))) + else + collect `(setf (slot-value instance ',(car slotd)) + (sb-alien:slot alien ',(car slotd)))) + instance) (defun ,to-alien (instance &optional alien) - (declare (type (or null (sb-alien:alien (* ,alien-type))) alien) - (type ,name instance)) - (unless alien - (setf alien (sb-alien:make-alien ,alien-type))) - ,@(loop for slotd in slots - for array-length = (getf (cdr slotd) :array-length) - if array-length - collect `(progn - (let ((array (slot-value instance ',(car slotd)))) - (dotimes (i ,array-length) - (setf (sb-alien:deref - (sb-alien:slot alien ',(car slotd)) - i) - (aref array i))))) - else - collect `(setf (sb-alien:slot alien ',(car slotd)) - (slot-value instance ',(car slotd))))) + (declare (type (or null (sb-alien:alien (* ,alien-type))) alien) + (type ,name instance)) + (unless alien + (setf alien (sb-alien:make-alien ,alien-type))) + ,@(loop for slotd in slots + for array-length = (getf (cdr slotd) :array-length) + if array-length + collect `(progn + (let ((array (slot-value instance ',(car slotd)))) + (dotimes (i ,array-length) + (setf (sb-alien:deref + (sb-alien:slot alien ',(car slotd)) + i) + (aref array i))))) + else + collect `(setf (sb-alien:slot alien ',(car slotd)) + (slot-value instance ',(car slotd))))) (find-class ',name)))) (define-condition sb-posix:syscall-error (error) ((errno :initarg :errno :reader sb-posix:syscall-errno)) (:report (lambda (c s) - (let ((errno (sb-posix:syscall-errno c))) - (format s "System call error ~A (~A)" - errno (sb-int:strerror errno)))))) + (let ((errno (sb-posix:syscall-errno c))) + (format s "System call error ~A (~A)" + errno (sb-int:strerror errno)))))) (defun syscall-error () (error 'sb-posix:syscall-error :errno (get-errno))) @@ -75,7 +75,7 @@ (define-call "chdir" int minusp (pathname filename)) (define-call "chmod" int minusp (pathname filename) (mode sb-posix::mode-t)) (define-call "chown" int minusp (pathname filename) - (owner sb-posix::uid-t) (group sb-posix::gid-t)) + (owner sb-posix::uid-t) (group sb-posix::gid-t)) (define-call "chroot" int minusp (pathname filename)) (define-call "close" int minusp (fd file-descriptor)) (define-call "creat" int minusp (pathname filename) (mode sb-posix::mode-t)) @@ -84,12 +84,12 @@ (define-call "fchdir" int minusp (fd file-descriptor)) (define-call "fchmod" int minusp (fd file-descriptor) (mode sb-posix::mode-t)) (define-call "fchown" int minusp (fd file-descriptor) - (owner sb-posix::uid-t) (group sb-posix::gid-t)) + (owner sb-posix::uid-t) (group sb-posix::gid-t)) (define-call "fdatasync" int minusp (fd file-descriptor)) (define-call "ftruncate" int minusp (fd file-descriptor) (length sb-posix::off-t)) (define-call "fsync" int minusp (fd file-descriptor)) (define-call "lchown" int minusp (pathname filename) - (owner sb-posix::uid-t) (group sb-posix::gid-t)) + (owner sb-posix::uid-t) (group sb-posix::gid-t)) (define-call "link" int minusp (oldpath filename) (newpath filename)) (define-call "lseek" sb-posix::off-t minusp (fd file-descriptor) (offset sb-posix::off-t) (whence int)) (define-call "mkdir" int minusp (pathname filename) (mode sb-posix::mode-t)) @@ -115,8 +115,8 @@ (define-entry-point "ioctl" (fd cmd &optional (arg nil argp)) (if argp (etypecase arg - ((alien int) (ioctl-with-int-arg fd cmd arg)) - ((or (alien (* t)) null) (ioctl-with-pointer-arg fd cmd arg))) + ((alien int) (ioctl-with-int-arg fd cmd arg)) + ((or (alien (* t)) null) (ioctl-with-pointer-arg fd cmd arg))) (ioctl-without-arg fd cmd))) (define-call-internally fcntl-without-arg "fcntl" int minusp (fd file-descriptor) (cmd int)) @@ -125,8 +125,8 @@ (define-entry-point "fcntl" (fd cmd &optional (arg nil argp)) (if argp (etypecase arg - ((alien int) (fcntl-with-int-arg fd cmd arg)) - ((or (alien (* t)) null) (fcntl-with-pointer-arg fd cmd arg))) + ((alien int) (fcntl-with-int-arg fd cmd arg)) + ((or (alien (* t)) null) (fcntl-with-pointer-arg fd cmd arg))) (fcntl-without-arg fd cmd))) (define-call "opendir" (* t) null-alien (pathname filename)) @@ -148,10 +148,10 @@ (define-call "seteuid" int minusp (uid sb-posix::uid-t)) (define-call "setfsuid" int minusp (uid sb-posix::uid-t)) (define-call "setreuid" int minusp - (ruid sb-posix::uid-t) (euid sb-posix::uid-t)) + (ruid sb-posix::uid-t) (euid sb-posix::uid-t)) (define-call "setresuid" int minusp - (ruid sb-posix::uid-t) (euid sb-posix::uid-t) - (suid sb-posix::uid-t)) + (ruid sb-posix::uid-t) (euid sb-posix::uid-t) + (suid sb-posix::uid-t)) (define-call "setuid" int minusp (uid sb-posix::uid-t)) (define-call "getegid" sb-posix::gid-t never-fails) @@ -161,10 +161,10 @@ (define-call "setfsgid" int minusp (gid sb-posix::gid-t)) (define-call "setgid" int minusp (gid sb-posix::gid-t)) (define-call "setregid" int minusp - (rgid sb-posix::gid-t) (egid sb-posix::gid-t)) + (rgid sb-posix::gid-t) (egid sb-posix::gid-t)) (define-call "setresgid" int minusp - (rgid sb-posix::gid-t) - (egid sb-posix::gid-t) (sgid sb-posix::gid-t)) + (rgid sb-posix::gid-t) + (egid sb-posix::gid-t) (sgid sb-posix::gid-t)) ;;; processes, signals (define-call "alarm" int never-fails (seconds unsigned)) @@ -178,7 +178,7 @@ (define-call "killpg" int minusp (pgrp int) (signal int)) (define-call "pause" int minusp) (define-call "setpgid" int minusp - (pid sb-posix::pid-t) (pgid sb-posix::pid-t)) + (pid sb-posix::pid-t) (pgid sb-posix::pid-t)) (define-call "setpgrp" int minusp) (export 'sb-posix::wait :sb-posix) @@ -186,27 +186,27 @@ (defun sb-posix::wait (&optional statusptr) (declare (type (or null (simple-array (signed-byte 32) (1))) statusptr)) (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32)))) - (pid (alien-funcall - (extern-alien "wait" (function sb-posix::pid-t (* int))) - (sb-sys:vector-sap ptr)))) + (pid (alien-funcall + (extern-alien "wait" (function sb-posix::pid-t (* int))) + (sb-sys:vector-sap ptr)))) (if (minusp pid) - (syscall-error) - (values pid (aref ptr 0))))) + (syscall-error) + (values pid (aref ptr 0))))) (export 'sb-posix::waitpid :sb-posix) (declaim (inline sb-posix::waitpid)) (defun sb-posix::waitpid (pid options &optional statusptr) (declare (type (sb-alien:alien sb-posix::pid-t) pid) - (type (sb-alien:alien int) options) - (type (or null (simple-array (signed-byte 32) (1))) statusptr)) + (type (sb-alien:alien int) options) + (type (or null (simple-array (signed-byte 32) (1))) statusptr)) (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32)))) - (pid (alien-funcall - (extern-alien "waitpid" (function sb-posix::pid-t - sb-posix::pid-t (* int) int)) - pid (sb-sys:vector-sap ptr) options))) - (if (minusp pid) - (syscall-error) - (values pid (aref ptr 0))))) + (pid (alien-funcall + (extern-alien "waitpid" (function sb-posix::pid-t + sb-posix::pid-t (* int) int)) + pid (sb-sys:vector-sap ptr) options))) + (if (minusp pid) + (syscall-error) + (values pid (aref ptr 0))))) ;; waitpid macros (define-call "wifexited" boolean never-fails (status int)) @@ -252,22 +252,22 @@ (export ',lisp-name :sb-posix) (declaim (inline ,lisp-name)) (defun ,lisp-name (,arg &optional stat) - (declare (type (or null (sb-alien:alien (* sb-posix::alien-stat))) stat)) - (sb-posix::with-alien-stat a-stat () - (let ((r (alien-funcall - (extern-alien ,name ,type) - (,designator-fun ,arg) - a-stat))) - (when (minusp r) - (syscall-error)) - (alien-to-stat a-stat stat))))))) + (declare (type (or null (sb-alien:alien (* sb-posix::alien-stat))) stat)) + (sb-posix::with-alien-stat a-stat () + (let ((r (alien-funcall + (extern-alien ,name ,type) + (,designator-fun ,arg) + a-stat))) + (when (minusp r) + (syscall-error)) + (alien-to-stat a-stat stat))))))) (define-stat-call "stat" pathname sb-posix::filename - (function int c-string (* sb-posix::alien-stat))) + (function int c-string (* sb-posix::alien-stat))) (define-stat-call "lstat" pathname sb-posix::filename - (function int c-string (* sb-posix::alien-stat))) + (function int c-string (* sb-posix::alien-stat))) (define-stat-call "fstat" fd sb-posix::file-descriptor - (function int int (* sb-posix::alien-stat))) + (function int int (* sb-posix::alien-stat))) ;;; mode flags @@ -286,9 +286,9 @@ (unless filedes2 (setq filedes2 (make-array 2 :element-type '(signed-byte 32)))) (let ((r (alien-funcall - ;; FIXME: (* INT)? (ARRAY INT 2) would be better - (extern-alien "pipe" (function int (* int))) - (sb-sys:vector-sap filedes2)))) + ;; FIXME: (* INT)? (ARRAY INT 2) would be better + (extern-alien "pipe" (function int (* int))) + (sb-sys:vector-sap filedes2)))) (when (minusp r) (syscall-error))) (values (aref filedes2 0) (aref filedes2 1))) @@ -307,24 +307,24 @@ (termios-to-alien termios a-termios) (let ((fd (sb-posix::file-descriptor fd))) (let* ((r (alien-funcall - (extern-alien - "tcsetattr" - (function int int int (* sb-posix::alien-termios))) - fd actions a-termios))) - (when (minusp r) - (syscall-error))) + (extern-alien + "tcsetattr" + (function int int int (* sb-posix::alien-termios))) + fd actions a-termios))) + (when (minusp r) + (syscall-error))) (values)))) (export 'sb-posix::tcgetattr :sb-posix) (declaim (inline sb-posix::tcgetattr)) (defun sb-posix::tcgetattr (fd &optional termios) (sb-posix::with-alien-termios a-termios () (let ((r (alien-funcall - (extern-alien "tcgetattr" - (function int int (* sb-posix::alien-termios))) - (sb-posix::file-descriptor fd) - a-termios))) + (extern-alien "tcgetattr" + (function int int (* sb-posix::alien-termios))) + (sb-posix::file-descriptor fd) + a-termios))) (when (minusp r) - (syscall-error)) + (syscall-error)) (setf termios (alien-to-termios a-termios termios)))) termios) @@ -333,8 +333,8 @@ (export 'sb-posix::getenv :sb-posix) (defun sb-posix::getenv (name) (let ((r (alien-funcall - (extern-alien "getenv" (function (* char) c-string)) - name))) + (extern-alien "getenv" (function (* char) c-string)) + name))) (declare (type (alien (* char)) r)) (unless (null-alien r) (cast r c-string)))) diff --git a/contrib/sb-posix/macros.lisp b/contrib/sb-posix/macros.lisp index 4cff10c..2e0d4bf 100644 --- a/contrib/sb-posix/macros.lisp +++ b/contrib/sb-posix/macros.lisp @@ -1,33 +1,33 @@ (in-package :sb-posix-internal) -;;; some explanation may be necessary. The namestring "[foo]" +;;; some explanation may be necessary. The namestring "[foo]" ;;; denotes a wild pathname. When there's a file on the disk whose ;;; Unix name is "[foo]", the appropriate CL namestring for it is ;;; "\\[foo]". So, don't call NAMESTRING, instead call a function ;;; that gets us the Unix name (defun native-filename (pathname) (let ((directory (pathname-directory pathname)) - (name (pathname-name pathname)) - (type (pathname-type pathname))) + (name (pathname-name pathname)) + (type (pathname-type pathname))) (with-output-to-string (s nil :element-type 'base-char) (etypecase directory - (string (write-string directory s)) - (list - (when (eq (car directory) :absolute) - (write-char #\/ s)) - (dolist (piece (cdr directory)) - (etypecase piece - (string (write-string piece s) (write-char #\/ s)) - ((member :up) (write-string "../" s)))))) + (string (write-string directory s)) + (list + (when (eq (car directory) :absolute) + (write-char #\/ s)) + (dolist (piece (cdr directory)) + (etypecase piece + (string (write-string piece s) (write-char #\/ s)) + ((member :up) (write-string "../" s)))))) (etypecase name - (null) + (null) (string (write-string name s))) (etypecase type - (null) - (string (write-char #\. s) (write-string type s)))))) + (null) + (string (write-char #\. s) (write-string type s)))))) (define-designator filename c-string - (pathname + (pathname (native-filename (translate-logical-pathname filename))) (string filename)) @@ -47,31 +47,31 @@ (intern (substitute #\- #\_ (string-upcase s)) :sb-posix)) (defmacro define-call-internally (lisp-name c-name return-type error-predicate - &rest arguments) + &rest arguments) (if (sb-sys:find-foreign-symbol-address c-name) `(progn - (declaim (inline ,lisp-name)) - (defun ,lisp-name ,(mapcar #'car arguments) - (let ((r (alien-funcall - (extern-alien - ,c-name - (function ,return-type - ,@(mapcar - (lambda (x) - (gethash (cadr x) - *designator-types* - (cadr x))) - arguments))) - ,@(mapcar (lambda (x) - (if (nth-value 1 - (gethash (cadr x) - *designator-types*)) - `(,(intern (symbol-name (cadr x)) - :sb-posix) - ,(car x)) - (car x))) - arguments)))) - (if (,error-predicate r) (syscall-error) r)))) + (declaim (inline ,lisp-name)) + (defun ,lisp-name ,(mapcar #'car arguments) + (let ((r (alien-funcall + (extern-alien + ,c-name + (function ,return-type + ,@(mapcar + (lambda (x) + (gethash (cadr x) + *designator-types* + (cadr x))) + arguments))) + ,@(mapcar (lambda (x) + (if (nth-value 1 + (gethash (cadr x) + *designator-types*)) + `(,(intern (symbol-name (cadr x)) + :sb-posix) + ,(car x)) + (car x))) + arguments)))) + (if (,error-predicate r) (syscall-error) r)))) `(sb-int:style-warn "Didn't find definition for ~S" ,c-name))) (defmacro define-call (name return-type error-predicate &rest arguments) @@ -79,10 +79,10 @@ `(progn (export ',lisp-name :sb-posix) (define-call-internally ,lisp-name - ,name - ,return-type - ,error-predicate - ,@arguments)))) + ,name + ,return-type + ,error-predicate + ,@arguments)))) (defmacro define-entry-point (name arglist &body body) (let ((lisp-name (lisp-for-c-symbol name))) @@ -90,4 +90,4 @@ (export ',lisp-name :sb-posix) (declaim (inline ,lisp-name)) (defun ,lisp-name ,arglist - ,@body)))) + ,@body)))) diff --git a/contrib/sb-posix/posix-tests.lisp b/contrib/sb-posix/posix-tests.lisp index 1108583..cb382a3 100644 --- a/contrib/sb-posix/posix-tests.lisp +++ b/contrib/sb-posix/posix-tests.lisp @@ -6,8 +6,8 @@ (defvar *test-directory* (ensure-directories-exist (merge-pathnames (make-pathname :directory '(:relative "test-lab")) - (make-pathname :directory - (pathname-directory *load-truename*))))) + (make-pathname :directory + (pathname-directory *load-truename*))))) (defvar *current-directory* *default-pathname-defaults*) @@ -15,14 +15,14 @@ (eval-when (:compile-toplevel :load-toplevel) (defconstant +mode-rwx-all+ (logior sb-posix::s-irusr sb-posix::s-iwusr sb-posix::s-ixusr - sb-posix::s-irgrp sb-posix::s-iwgrp sb-posix::s-ixgrp - sb-posix::s-iroth sb-posix::s-iwoth sb-posix::s-ixoth))) + sb-posix::s-irgrp sb-posix::s-iwgrp sb-posix::s-ixgrp + sb-posix::s-iroth sb-posix::s-iwoth sb-posix::s-ixoth))) (defmacro define-eacces-test (name form &rest values) `(deftest ,name (block ,name (when (= (sb-posix:geteuid) 0) - (return-from ,name (values ,@values))) + (return-from ,name (values ,@values))) ,form) ,@values)) @@ -61,9 +61,9 @@ (deftest chdir.error.1 (let ((dne (make-pathname :directory '(:relative "chdir.does-not-exist")))) (handler-case - (sb-posix:chdir (merge-pathnames dne *test-directory*)) + (sb-posix:chdir (merge-pathnames dne *test-directory*)) (sb-posix:syscall-error (c) - (sb-posix:syscall-errno c)))) + (sb-posix:syscall-errno c)))) #.sb-posix::enoent) (deftest chdir.error.2 @@ -76,7 +76,7 @@ (deftest mkdir.1 (let ((dne (make-pathname :directory '(:relative "mkdir.does-not-exist.1")))) (unwind-protect - (sb-posix:mkdir (merge-pathnames dne *test-directory*) 0) + (sb-posix:mkdir (merge-pathnames dne *test-directory*) 0) ;; FIXME: no delete-directory in CL, but using our own operators ;; is probably not ideal (ignore-errors (sb-posix:rmdir (merge-pathnames dne *test-directory*))))) @@ -85,7 +85,7 @@ (deftest mkdir.2 (let ((dne (make-pathname :directory '(:relative "mkdir.does-not-exist.2")))) (unwind-protect - (sb-posix:mkdir (namestring (merge-pathnames dne *test-directory*)) 0) + (sb-posix:mkdir (namestring (merge-pathnames dne *test-directory*)) 0) (ignore-errors (sb-posix:rmdir (merge-pathnames dne *test-directory*))))) 0) @@ -105,21 +105,21 @@ (define-eacces-test mkdir.error.3 (let* ((dir (merge-pathnames - (make-pathname :directory '(:relative "mkdir.error.3")) - *test-directory*)) - (dir2 (merge-pathnames - (make-pathname :directory '(:relative "does-not-exist")) - dir))) + (make-pathname :directory '(:relative "mkdir.error.3")) + *test-directory*)) + (dir2 (merge-pathnames + (make-pathname :directory '(:relative "does-not-exist")) + dir))) (sb-posix:mkdir dir 0) (handler-case - (sb-posix:mkdir dir2 0) + (sb-posix:mkdir dir2 0) (sb-posix:syscall-error (c) - (sb-posix:rmdir dir) - (sb-posix:syscall-errno c)) + (sb-posix:rmdir dir) + (sb-posix:syscall-errno c)) (:no-error (result) - (sb-posix:rmdir dir2) - (sb-posix:rmdir dir) - result))) + (sb-posix:rmdir dir2) + (sb-posix:rmdir dir) + result))) #.sb-posix::eacces) (deftest rmdir.1 @@ -136,10 +136,10 @@ (deftest rmdir.error.1 (let ((dne (make-pathname :directory '(:relative "rmdir.dne.error.1")))) - (handler-case - (sb-posix:rmdir (merge-pathnames dne *test-directory*)) + (handler-case + (sb-posix:rmdir (merge-pathnames dne *test-directory*)) (sb-posix:syscall-error (c) - (sb-posix:syscall-errno c)))) + (sb-posix:syscall-errno c)))) #.sb-posix::enoent) (deftest rmdir.error.2 @@ -158,74 +158,74 @@ (deftest rmdir.error.4 (let* ((dir (ensure-directories-exist - (merge-pathnames - (make-pathname :directory '(:relative "rmdir.error.4")) - *test-directory*))) - (file (make-pathname :name "foo" :defaults dir))) + (merge-pathnames + (make-pathname :directory '(:relative "rmdir.error.4")) + *test-directory*))) + (file (make-pathname :name "foo" :defaults dir))) (with-open-file (s file :direction :output) (write "" :stream s)) (handler-case - (sb-posix:rmdir dir) + (sb-posix:rmdir dir) (sb-posix:syscall-error (c) - (delete-file file) - (sb-posix:rmdir dir) - (let ((errno (sb-posix:syscall-errno c))) - ;; documented by POSIX - (or (= errno sb-posix::eexist) (= errno sb-posix::enotempty)))))) + (delete-file file) + (sb-posix:rmdir dir) + (let ((errno (sb-posix:syscall-errno c))) + ;; documented by POSIX + (or (= errno sb-posix::eexist) (= errno sb-posix::enotempty)))))) t) (define-eacces-test rmdir.error.5 (let* ((dir (merge-pathnames - (make-pathname :directory '(:relative "rmdir.error.5")) - *test-directory*)) - (dir2 (merge-pathnames - (make-pathname :directory '(:relative "unremovable")) - dir))) + (make-pathname :directory '(:relative "rmdir.error.5")) + *test-directory*)) + (dir2 (merge-pathnames + (make-pathname :directory '(:relative "unremovable")) + dir))) (sb-posix:mkdir dir +mode-rwx-all+) (sb-posix:mkdir dir2 +mode-rwx-all+) (sb-posix:chmod dir 0) (handler-case - (sb-posix:rmdir dir2) + (sb-posix:rmdir dir2) (sb-posix:syscall-error (c) - (sb-posix:chmod dir (logior sb-posix::s-iread sb-posix::s-iwrite sb-posix::s-iexec)) - (sb-posix:rmdir dir2) - (sb-posix:rmdir dir) - (sb-posix:syscall-errno c)) + (sb-posix:chmod dir (logior sb-posix::s-iread sb-posix::s-iwrite sb-posix::s-iexec)) + (sb-posix:rmdir dir2) + (sb-posix:rmdir dir) + (sb-posix:syscall-errno c)) (:no-error (result) - (sb-posix:chmod dir (logior sb-posix::s-iread sb-posix::s-iwrite sb-posix::s-iexec)) - (sb-posix:rmdir dir) - result))) + (sb-posix:chmod dir (logior sb-posix::s-iread sb-posix::s-iwrite sb-posix::s-iexec)) + (sb-posix:rmdir dir) + result))) #.sb-posix::eacces) (deftest stat.1 (let* ((stat (sb-posix:stat *test-directory*)) - (mode (sb-posix::stat-mode stat))) + (mode (sb-posix::stat-mode stat))) ;; FIXME: Ugly ::s everywhere (logand mode (logior sb-posix::s-iread sb-posix::s-iwrite sb-posix::s-iexec))) #.(logior sb-posix::s-iread sb-posix::s-iwrite sb-posix::s-iexec)) (deftest stat.2 (let* ((stat (sb-posix:stat "/")) - (mode (sb-posix::stat-mode stat))) + (mode (sb-posix::stat-mode stat))) ;; it's logically possible for / to be writeable by others... but ;; if it is, either someone is playing with strange security ;; modules or they want to know about it anyway. (logand mode sb-posix::s-iwoth)) 0) - + (deftest stat.3 (let* ((now (get-universal-time)) - ;; FIXME: (encode-universal-time 00 00 00 01 01 1970) - (unix-now (- now 2208988800)) - (stat (sb-posix:stat *test-directory*)) - (atime (sb-posix::stat-atime stat))) + ;; FIXME: (encode-universal-time 00 00 00 01 01 1970) + (unix-now (- now 2208988800)) + (stat (sb-posix:stat *test-directory*)) + (atime (sb-posix::stat-atime stat))) ;; FIXME: breaks if mounted noatime :-( (< (- atime unix-now) 10)) t) (deftest stat.4 (let* ((stat (sb-posix:stat (make-pathname :directory '(:absolute :up)))) - (mode (sb-posix::stat-mode stat))) + (mode (sb-posix::stat-mode stat))) ;; it's logically possible for / to be writeable by others... but ;; if it is, either someone is playing with strange security ;; modules or they want to know about it anyway. @@ -243,27 +243,27 @@ (define-eacces-test stat.error.2 (let* ((dir (merge-pathnames - (make-pathname :directory '(:relative "stat.error.2")) - *test-directory*)) - (file (merge-pathnames - (make-pathname :name "unstatable") - dir))) + (make-pathname :directory '(:relative "stat.error.2")) + *test-directory*)) + (file (merge-pathnames + (make-pathname :name "unstatable") + dir))) (sb-posix:mkdir dir +mode-rwx-all+) (with-open-file (s file :direction :output) (write "" :stream s)) (sb-posix:chmod dir 0) (handler-case - (sb-posix:stat file) + (sb-posix:stat file) (sb-posix:syscall-error (c) - (sb-posix:chmod dir (logior sb-posix::s-iread sb-posix::s-iwrite sb-posix::s-iexec)) - (sb-posix:unlink file) - (sb-posix:rmdir dir) - (sb-posix:syscall-errno c)) + (sb-posix:chmod dir (logior sb-posix::s-iread sb-posix::s-iwrite sb-posix::s-iexec)) + (sb-posix:unlink file) + (sb-posix:rmdir dir) + (sb-posix:syscall-errno c)) (:no-error (result) - (sb-posix:chmod dir (logior sb-posix::s-iread sb-posix::s-iwrite sb-posix::s-iexec)) - (sb-posix:unlink file) - (sb-posix:rmdir dir) - result))) + (sb-posix:chmod dir (logior sb-posix::s-iread sb-posix::s-iwrite sb-posix::s-iexec)) + (sb-posix:unlink file) + (sb-posix:rmdir dir) + result))) #.sb-posix::eacces) ;;; stat-mode tests @@ -366,14 +366,14 @@ (deftest fcntl.1 (let ((fd (sb-posix:open "/dev/null" sb-posix::o-nonblock))) (/= 0 (logand (sb-posix:fcntl fd sb-posix::f-getfl) - sb-posix::o-nonblock))) + sb-posix::o-nonblock))) t) (deftest opendir.1 (let ((dir (sb-posix:opendir "/"))) (unwind-protect (sb-alien:null-alien dir) (unless (sb-alien:null-alien dir) - (sb-posix:closedir dir)))) + (sb-posix:closedir dir)))) nil) (deftest readdir.1 diff --git a/contrib/sb-rotate-byte/compiler.lisp b/contrib/sb-rotate-byte/compiler.lisp index 7165b36..2e7d5e1 100644 --- a/contrib/sb-rotate-byte/compiler.lisp +++ b/contrib/sb-rotate-byte/compiler.lisp @@ -31,27 +31,27 @@ ;; simpler, and also be made to deal with negative integers too. (let ((size (sb-c::lvar-type size))) (if (numeric-type-p size) - (let ((size-high (numeric-type-high size)) - (num-type (sb-c::lvar-type num))) - (if (and size-high - num-type - (<= size-high sb-vm:n-word-bits) - (csubtypep num-type - (specifier-type `(unsigned-byte ,size-high)))) + (let ((size-high (numeric-type-high size)) + (num-type (sb-c::lvar-type num))) + (if (and size-high + num-type + (<= size-high sb-vm:n-word-bits) + (csubtypep num-type + (specifier-type `(unsigned-byte ,size-high)))) (specifier-type `(unsigned-byte ,size-high)) - *universal-type*)) + *universal-type*)) *universal-type*))) (deftransform %rotate-byte ((count size pos integer) - ((constant-arg (member 0)) * * *) *) + ((constant-arg (member 0)) * * *) *) "fold identity operation" 'integer) (deftransform %rotate-byte ((count size pos integer) - ((integer -31 31) - (constant-arg (member 32)) - (constant-arg (member 0)) - (unsigned-byte 32)) *) + ((integer -31 31) + (constant-arg (member 32)) + (constant-arg (member 0)) + (unsigned-byte 32)) *) "inline 32-bit rotation" ;; FIXME: What happens when, as here, the two type specifiers for ;; COUNT overlap? Which gets to run first? diff --git a/contrib/sb-rotate-byte/ppc-vm.lisp b/contrib/sb-rotate-byte/ppc-vm.lisp index 294a7d6..e119a3d 100644 --- a/contrib/sb-rotate-byte/ppc-vm.lisp +++ b/contrib/sb-rotate-byte/ppc-vm.lisp @@ -14,7 +14,7 @@ ;; DEFTRANSFORMed away. (aver (not (= count 0))) (if (> count 0) - (inst rotlwi res integer count) + (inst rotlwi res integer count) (inst rotrwi res integer (- count))))) (define-vop (%32bit-rotate-byte-fixnum/c) @@ -35,28 +35,28 @@ (t (inst rotrwi res integer (- 2 count)))))) (macrolet ((def (name arg-type) - `(define-vop (,name) - (:policy :fast-safe) - (:translate %unsigned-32-rotate-byte) - (:note "inline 32-bit rotation") - (:args (count :scs (sb-vm::signed-reg)) - (integer :scs (sb-vm::unsigned-reg) :target res)) - (:arg-types sb-vm::tagged-num ,arg-type) - (:temporary (:scs (sb-vm::unsigned-reg) :from (:argument 0)) - realcount) - (:results (res :scs (sb-vm::unsigned-reg))) - (:result-types sb-vm::unsigned-byte-32) - (:generator 10 - (let ((label (gen-label)) - (end (gen-label))) - (inst cmpwi count 0) - (inst bge label) - (inst addi realcount count 32) - (inst rotlw res integer realcount) - (inst b end) - (emit-label label) - (inst rotlw res integer count) - (emit-label end)))))) + `(define-vop (,name) + (:policy :fast-safe) + (:translate %unsigned-32-rotate-byte) + (:note "inline 32-bit rotation") + (:args (count :scs (sb-vm::signed-reg)) + (integer :scs (sb-vm::unsigned-reg) :target res)) + (:arg-types sb-vm::tagged-num ,arg-type) + (:temporary (:scs (sb-vm::unsigned-reg) :from (:argument 0)) + realcount) + (:results (res :scs (sb-vm::unsigned-reg))) + (:result-types sb-vm::unsigned-byte-32) + (:generator 10 + (let ((label (gen-label)) + (end (gen-label))) + (inst cmpwi count 0) + (inst bge label) + (inst addi realcount count 32) + (inst rotlw res integer realcount) + (inst b end) + (emit-label label) + (inst rotlw res integer count) + (emit-label end)))))) (def %32bit-rotate-byte sb-vm::unsigned-byte-32) ;; FIXME: see x86-vm.lisp (def %32bit-rotate-byte-fixnum sb-vm::positive-fixnum)) diff --git a/contrib/sb-rotate-byte/rotate-byte-tests.lisp b/contrib/sb-rotate-byte/rotate-byte-tests.lisp index bf463ad..518f8cb 100644 --- a/contrib/sb-rotate-byte/rotate-byte-tests.lisp +++ b/contrib/sb-rotate-byte/rotate-byte-tests.lisp @@ -25,7 +25,7 @@ (defun pfixnum (count integer) (declare (type (unsigned-byte 29) integer) - (type (integer -31 31) count)) + (type (integer -31 31) count)) (rotate-byte count (byte 32 0) integer)) (assert (= (pfixnum 5 5) 160)) @@ -44,7 +44,7 @@ (defun ub32 (count integer) (declare (type (unsigned-byte 32) integer) - (type (integer -31 31) count)) + (type (integer -31 31) count)) (rotate-byte count (byte 32 0) integer)) (assert (= (ub32 5 5) 160)) diff --git a/contrib/sb-rotate-byte/rotate-byte.lisp b/contrib/sb-rotate-byte/rotate-byte.lisp index 9e947fd..2861359 100644 --- a/contrib/sb-rotate-byte/rotate-byte.lisp +++ b/contrib/sb-rotate-byte/rotate-byte.lisp @@ -9,15 +9,15 @@ contains the bits of INTEGER." (defun %rotate-byte (count size pos integer) (let ((count (nth-value 1 (round count size))) - (mask (1- (ash 1 size)))) + (mask (1- (ash 1 size)))) (logior (logand integer (lognot (ash mask pos))) - (let ((field (logand (ash mask pos) integer))) - (logand (ash mask pos) - (if (> count 0) - (logior (ash field count) - (ash field (- count size))) - (logior (ash field count) - (ash field (+ count size))))))))) + (let ((field (logand (ash mask pos) integer))) + (logand (ash mask pos) + (if (> count 0) + (logior (ash field count) + (ash field (- count size))) + (logior (ash field count) + (ash field (+ count size))))))))) (defun %unsigned-32-rotate-byte (count integer) ;; inhibit transforms diff --git a/contrib/sb-rotate-byte/x86-vm.lisp b/contrib/sb-rotate-byte/x86-vm.lisp index de13b6b..4a43d00 100644 --- a/contrib/sb-rotate-byte/x86-vm.lisp +++ b/contrib/sb-rotate-byte/x86-vm.lisp @@ -15,8 +15,8 @@ (aver (not (= count 0))) (move res integer) (if (> count 0) - (inst rol res count) - (inst ror res (- count))))) + (inst rol res count) + (inst ror res (- count))))) (define-vop (%32bit-rotate-byte-fixnum/c) (:policy :fast-safe) @@ -37,30 +37,30 @@ (t (inst ror res (- 2 count)))))) (macrolet ((def (name arg-type) - `(define-vop (,name) - (:policy :fast-safe) - (:translate %unsigned-32-rotate-byte) - (:note "inline 32-bit rotation") - (:args (count :scs (sb-vm::signed-reg) :target ecx) - (integer :scs (sb-vm::unsigned-reg) :target res)) - (:arg-types sb-vm::tagged-num ,arg-type) - (:temporary (:sc sb-vm::signed-reg :offset sb-vm::ecx-offset) - ecx) - (:results (res :scs (sb-vm::unsigned-reg))) - (:result-types sb-vm::unsigned-byte-32) - (:generator 10 - (let ((label (gen-label)) - (end (gen-label))) - (move res integer) - (move ecx count) - (inst cmp ecx 0) - (inst jmp :ge label) - (inst neg ecx) - (inst ror res :cl) - (inst jmp end) - (emit-label label) - (inst rol res :cl) - (emit-label end)))))) + `(define-vop (,name) + (:policy :fast-safe) + (:translate %unsigned-32-rotate-byte) + (:note "inline 32-bit rotation") + (:args (count :scs (sb-vm::signed-reg) :target ecx) + (integer :scs (sb-vm::unsigned-reg) :target res)) + (:arg-types sb-vm::tagged-num ,arg-type) + (:temporary (:sc sb-vm::signed-reg :offset sb-vm::ecx-offset) + ecx) + (:results (res :scs (sb-vm::unsigned-reg))) + (:result-types sb-vm::unsigned-byte-32) + (:generator 10 + (let ((label (gen-label)) + (end (gen-label))) + (move res integer) + (move ecx count) + (inst cmp ecx 0) + (inst jmp :ge label) + (inst neg ecx) + (inst ror res :cl) + (inst jmp end) + (emit-label label) + (inst rol res :cl) + (emit-label end)))))) (def %32bit-rotate-byte sb-vm::unsigned-byte-32) ;; FIXME: it's not entirely clear to me why we need this second ;; definition -- or rather, why the compiler isn't smart enough to diff --git a/contrib/sb-rt/rt.lisp b/contrib/sb-rt/rt.lisp index 117e68e..77a4560 100644 --- a/contrib/sb-rt/rt.lisp +++ b/contrib/sb-rt/rt.lisp @@ -22,8 +22,8 @@ (defpackage :sb-rt (:use #:cl) (:export #:*do-tests-when-defined* #:*test* #:continue-testing - #:deftest #:do-test #:do-tests #:get-test #:pending-tests - #:rem-all-tests #:rem-test) + #:deftest #:do-test #:do-tests #:get-test #:pending-tests + #:rem-all-tests #:rem-test) (:documentation "The MIT regression tester")) (in-package :sb-rt) @@ -44,7 +44,7 @@ "A list of test names that are expected to fail.") (defstruct (entry (:conc-name nil) - (:type list)) + (:type list)) pend name form) (defmacro vals (entry) `(cdddr ,entry)) @@ -74,12 +74,12 @@ (defun get-entry (name) (let ((entry (find name (cdr *entries*) - :key #'name - :test #'equal))) + :key #'name + :test #'equal))) (when (null entry) (report-error t "~%No test with name ~:@(~S~)." - name)) + name)) entry)) (defmacro deftest (name form &rest values) @@ -91,8 +91,8 @@ (when (null (cdr l)) (setf (cdr l) (list entry)) (return nil)) - (when (equal (name (cadr l)) - (name entry)) + (when (equal (name (cadr l)) + (name entry)) (setf (cadr l) entry) (report-error nil "Redefining test ~:@(~S~)" @@ -103,11 +103,11 @@ (setq *test* (name entry))) (defun report-error (error? &rest args) - (cond (*debug* - (apply #'format t args) - (if error? (throw '*debug* nil))) - (error? (apply #'error args)) - (t (apply #'warn args)))) + (cond (*debug* + (apply #'format t args) + (if error? (throw '*debug* nil))) + (error? (apply #'error args)) + (t (apply #'warn args)))) (defun do-test (&optional (name *test*)) (do-entry (get-entry name))) @@ -118,84 +118,84 @@ ((eq x y) t) ((consp x) (and (consp y) - (equalp-with-case (car x) (car y)) - (equalp-with-case (cdr x) (cdr y)))) + (equalp-with-case (car x) (car y)) + (equalp-with-case (cdr x) (cdr y)))) ((and (typep x 'array) - (= (array-rank x) 0)) + (= (array-rank x) 0)) (equalp-with-case (aref x) (aref y))) ((typep x 'vector) (and (typep y 'vector) - (let ((x-len (length x)) - (y-len (length y))) - (and (eql x-len y-len) - (loop - for e1 across x - for e2 across y - always (equalp-with-case e1 e2)))))) + (let ((x-len (length x)) + (y-len (length y))) + (and (eql x-len y-len) + (loop + for e1 across x + for e2 across y + always (equalp-with-case e1 e2)))))) ((and (typep x 'array) - (typep y 'array) - (not (equal (array-dimensions x) - (array-dimensions y)))) + (typep y 'array) + (not (equal (array-dimensions x) + (array-dimensions y)))) nil) ((typep x 'array) (and (typep y 'array) - (let ((size (array-total-size x))) - (loop for i from 0 below size - always (equalp-with-case (row-major-aref x i) - (row-major-aref y i)))))) + (let ((size (array-total-size x))) + (loop for i from 0 below size + always (equalp-with-case (row-major-aref x i) + (row-major-aref y i)))))) (t (eql x y)))) (defun do-entry (entry &optional - (s *standard-output*)) + (s *standard-output*)) (catch '*in-test* (setq *test* (name entry)) (setf (pend entry) t) (let* ((*in-test* t) - ;; (*break-on-warnings* t) - (aborted nil) - r) + ;; (*break-on-warnings* t) + (aborted nil) + r) ;; (declare (special *break-on-warnings*)) (block aborted - (setf r - (flet ((%do - () - (if *compile-tests* - (multiple-value-list - (funcall (compile - nil - `(lambda () - (declare - (optimize ,@*optimization-settings*)) - ,(form entry))))) - (multiple-value-list - (eval (form entry)))))) - (if *catch-errors* - (handler-bind - ((style-warning #'muffle-warning) - (error #'(lambda (c) - (setf aborted t) - (setf r (list c)) - (return-from aborted nil)))) - (%do)) - (%do))))) + (setf r + (flet ((%do + () + (if *compile-tests* + (multiple-value-list + (funcall (compile + nil + `(lambda () + (declare + (optimize ,@*optimization-settings*)) + ,(form entry))))) + (multiple-value-list + (eval (form entry)))))) + (if *catch-errors* + (handler-bind + ((style-warning #'muffle-warning) + (error #'(lambda (c) + (setf aborted t) + (setf r (list c)) + (return-from aborted nil)))) + (%do)) + (%do))))) (setf (pend entry) - (or aborted - (not (equalp-with-case r (vals entry))))) - + (or aborted + (not (equalp-with-case r (vals entry))))) + (when (pend entry) - (let ((*print-circle* *print-circle-on-failure*)) - (format s "~&Test ~:@(~S~) failed~ + (let ((*print-circle* *print-circle-on-failure*)) + (format s "~&Test ~:@(~S~) failed~ ~%Form: ~S~ ~%Expected value~P: ~ ~{~S~^~%~17t~}~%" - *test* (form entry) - (length (vals entry)) - (vals entry)) - (format s "Actual value~P: ~ + *test* (form entry) + (length (vals entry)) + (vals entry)) + (format s "Actual value~P: ~ ~{~S~^~%~15t~}.~%" - (length r) r))))) + (length r) r))))) (when (not (pend entry)) *test*)) (defun continue-testing () @@ -204,51 +204,51 @@ (do-entries *standard-output*))) (defun do-tests (&optional - (out *standard-output*)) + (out *standard-output*)) (dolist (entry (cdr *entries*)) (setf (pend entry) t)) (if (streamp out) (do-entries out) - (with-open-file - (stream out :direction :output) - (do-entries stream)))) + (with-open-file + (stream out :direction :output) + (do-entries stream)))) (defun do-entries (s) (format s "~&Doing ~A pending test~:P ~ of ~A tests total.~%" (count t (cdr *entries*) - :key #'pend) - (length (cdr *entries*))) + :key #'pend) + (length (cdr *entries*))) (dolist (entry (cdr *entries*)) (when (pend entry) (format s "~@[~<~%~:; ~:@(~S~)~>~]" - (do-entry entry s)))) + (do-entry entry s)))) (let ((pending (pending-tests)) - (expected-table (make-hash-table :test #'equal))) + (expected-table (make-hash-table :test #'equal))) (dolist (ex *expected-failures*) (setf (gethash ex expected-table) t)) (let ((new-failures - (loop for pend in pending - unless (gethash pend expected-table) - collect pend))) + (loop for pend in pending + unless (gethash pend expected-table) + collect pend))) (if (null pending) - (format s "~&No tests failed.") - (progn - (format s "~&~A out of ~A ~ + (format s "~&No tests failed.") + (progn + (format s "~&~A out of ~A ~ total tests failed: ~ ~:@(~{~<~% ~1:;~S~>~ ~^, ~}~)." - (length pending) - (length (cdr *entries*)) - pending) - (if (null new-failures) - (format s "~&No unexpected failures.") - (when *expected-failures* - (format s "~&~A unexpected failures: ~ + (length pending) + (length (cdr *entries*)) + pending) + (if (null new-failures) + (format s "~&No unexpected failures.") + (when *expected-failures* + (format s "~&~A unexpected failures: ~ ~:@(~{~<~% ~1:;~S~>~ ~^, ~}~)." - (length new-failures) - new-failures))) - )) + (length new-failures) + new-failures))) + )) (finish-output s) (null pending)))) diff --git a/contrib/sb-simple-streams/classes.lisp b/contrib/sb-simple-streams/classes.lisp index 6007d6e..2343db3 100644 --- a/contrib/sb-simple-streams/classes.lisp +++ b/contrib/sb-simple-streams/classes.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. -;;; +;;; ;;; Sbcl port by Rudi Schlatte. @@ -34,7 +34,7 @@ (deftype j-read-chars-fn () '(function (simple-stream string (or character null) fixnum fixnum blocking) - (values fixnum &optional (member nil t :eof)))) + (values fixnum &optional (member nil t :eof)))) (deftype j-write-char-fn () '(function ((or character null) simple-stream) (or character null))) @@ -81,12 +81,12 @@ ;; the stream is not open for input. (input-handle :initform nil :initarg :input-handle :type (or null fixnum stream) - :accessor stream-input-handle) + :accessor stream-input-handle) ;; A fixnum (denoting a valid file descriptor), a stream, or nil if ;; the stream is not open for output. (output-handle :initform nil :initarg :output-handle - :type (or null fixnum stream) - :accessor stream-output-handle) + :type (or null fixnum stream) + :accessor stream-output-handle) (control-in :initform nil :type (or null simple-vector)) (control-out :initform nil :type (or null simple-vector)) @@ -96,7 +96,7 @@ ;; a stream, allowing for composing external formats (see ;; streams.htm, section 12.5) TODO: document this better (melding-base :type (or null simple-stream)) - + ;; Number of octets the last read-char operation consumed TODO: ;; document this better; what is the difference to ;; last-char-read-size ? @@ -104,7 +104,7 @@ ;; Number of octets the last read-char operation consumed (last-char-read-size :initform 0 :type fixnum) (charpos :initform 0 :type (or null integer) - :accessor stream-line-column) + :accessor stream-line-column) (record-end :initform nil :type (or null fixnum)) ;; Input/output buffer. @@ -167,7 +167,7 @@ (defmethod shared-initialize :after ((instance simple-stream) slot-names - &rest initargs &key &allow-other-keys) + &rest initargs &key &allow-other-keys) (declare (ignore slot-names)) (unless (slot-boundp instance 'melded-stream) (setf (slot-value instance 'melded-stream) instance) @@ -179,9 +179,9 @@ (defmethod print-object ((object simple-stream) stream) (print-unreadable-object (object stream :type nil :identity nil) (cond ((not (any-stream-instance-flags object :simple)) - (princ "Invalid " stream)) - ((not (any-stream-instance-flags object :input :output)) - (princ "Closed " stream))) + (princ "Invalid " stream)) + ((not (any-stream-instance-flags object :input :output)) + (princ "Closed " stream))) (format stream "~:(~A~)" (type-of object)))) ;;; This takes care of the things all device-close methods have to do, @@ -190,12 +190,12 @@ (with-stream-class (simple-stream stream) (when (any-stream-instance-flags stream :input :output) (when (any-stream-instance-flags stream :output) - (ignore-errors (if abort - (clear-output stream) - (finish-output stream)))) + (ignore-errors (if abort + (clear-output stream) + (finish-output stream)))) (call-next-method) (setf (sm input-handle stream) nil - (sm output-handle stream) nil) + (sm output-handle stream) nil) (remove-stream-instance-flags stream :input :output) (sb-ext:cancel-finalization stream) ;; This sets all readers and writers to error-raising functions @@ -238,11 +238,11 @@ (defmethod device-read ((stream single-channel-simple-stream) buffer - start end blocking) + start end blocking) (read-octets stream buffer start end blocking)) (defmethod device-read ((stream dual-channel-simple-stream) buffer - start end blocking) + start end blocking) (read-octets stream buffer start end blocking)) (defmethod device-clear-input ((stream simple-stream) buffer-only) @@ -253,7 +253,7 @@ start end blocking) ;; buffer may be :flush to force/finish-output (when (or (and (null buffer) (not (eql start end))) - (eq buffer :flush)) + (eq buffer :flush)) (with-stream-class (single-channel-simple-stream stream) (setf buffer (sm buffer stream)) (setf end (sm buffpos stream)))) @@ -263,7 +263,7 @@ start end blocking) ;; buffer may be :flush to force/finish-output (when (or (and (null buffer) (not (eql start end))) - (eq buffer :flush)) + (eq buffer :flush)) (with-stream-class (dual-channel-simple-stream stream) (setf buffer (sm out-buffer stream)) (setf end (sm outpos stream)))) diff --git a/contrib/sb-simple-streams/direct.lisp b/contrib/sb-simple-streams/direct.lisp index 2babb72..751bf37 100644 --- a/contrib/sb-simple-streams/direct.lisp +++ b/contrib/sb-simple-streams/direct.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. -;;; +;;; ;;; Sbcl port by Rudi Schlatte. diff --git a/contrib/sb-simple-streams/file.lisp b/contrib/sb-simple-streams/file.lisp index 2e20b2a..7b71b9d 100644 --- a/contrib/sb-simple-streams/file.lisp +++ b/contrib/sb-simple-streams/file.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. -;;; +;;; ;;; Sbcl port by Rudi Schlatte. @@ -21,7 +21,7 @@ (delete-original :initform nil :initarg :delete-original))) (def-stream-class mapped-file-simple-stream (file-simple-stream - direct-simple-stream) + direct-simple-stream) ()) (def-stream-class probe-simple-stream (simple-stream) @@ -35,53 +35,53 @@ ((not (any-stream-instance-flags object :input :output)) (princ "Closed " stream))) (format stream "~:(~A~) for ~S" - (type-of object) (sm filename object))))) + (type-of object) (sm filename object))))) (defun open-file-stream (stream options) (let ((filename (pathname (getf options :filename))) - (direction (getf options :direction :input)) - (if-exists (getf options :if-exists)) - (if-exists-given (not (eql (getf options :if-exists t) t))) - (if-does-not-exist (getf options :if-does-not-exist)) - (if-does-not-exist-given (not (eql (getf options :if-does-not-exist t) t)))) + (direction (getf options :direction :input)) + (if-exists (getf options :if-exists)) + (if-exists-given (not (eql (getf options :if-exists t) t))) + (if-does-not-exist (getf options :if-does-not-exist)) + (if-does-not-exist-given (not (eql (getf options :if-does-not-exist t) t)))) (with-stream-class (file-simple-stream stream) (ecase direction - (:input (add-stream-instance-flags stream :input)) - (:output (add-stream-instance-flags stream :output)) - (:io (add-stream-instance-flags stream :input :output))) + (:input (add-stream-instance-flags stream :input)) + (:output (add-stream-instance-flags stream :output)) + (:io (add-stream-instance-flags stream :input :output))) (cond ((and (sm input-handle stream) (sm output-handle stream) - (not (eql (sm input-handle stream) - (sm output-handle stream)))) - (error "Input-Handle and Output-Handle can't be different.")) - ((or (sm input-handle stream) (sm output-handle stream)) - (add-stream-instance-flags stream :simple) - ;; get namestring, etc., from handle, if possible - ;; (i.e., if it's a stream) - ;; set up buffers - stream) - (t - (multiple-value-bind (fd namestring original delete-original) - (%fd-open filename direction if-exists if-exists-given - if-does-not-exist if-does-not-exist-given) - (when fd - (add-stream-instance-flags stream :simple) - (setf (sm pathname stream) filename - (sm filename stream) namestring - (sm original stream) original - (sm delete-original stream) delete-original) - (when (any-stream-instance-flags stream :input) - (setf (sm input-handle stream) fd)) - (when (any-stream-instance-flags stream :output) - (setf (sm output-handle stream) fd)) - (sb-ext:finalize stream - (lambda () - (sb-unix:unix-close fd) - (format *terminal-io* "~&;;; ** closed ~S (fd ~D)~%" - namestring fd) - (when original - (revert-file namestring original)))) - stream))))))) + (not (eql (sm input-handle stream) + (sm output-handle stream)))) + (error "Input-Handle and Output-Handle can't be different.")) + ((or (sm input-handle stream) (sm output-handle stream)) + (add-stream-instance-flags stream :simple) + ;; get namestring, etc., from handle, if possible + ;; (i.e., if it's a stream) + ;; set up buffers + stream) + (t + (multiple-value-bind (fd namestring original delete-original) + (%fd-open filename direction if-exists if-exists-given + if-does-not-exist if-does-not-exist-given) + (when fd + (add-stream-instance-flags stream :simple) + (setf (sm pathname stream) filename + (sm filename stream) namestring + (sm original stream) original + (sm delete-original stream) delete-original) + (when (any-stream-instance-flags stream :input) + (setf (sm input-handle stream) fd)) + (when (any-stream-instance-flags stream :output) + (setf (sm output-handle stream) fd)) + (sb-ext:finalize stream + (lambda () + (sb-unix:unix-close fd) + (format *terminal-io* "~&;;; ** closed ~S (fd ~D)~%" + namestring fd) + (when original + (revert-file namestring original)))) + stream))))))) (defmethod device-open ((stream file-simple-stream) options) (with-stream-class (file-simple-stream stream) @@ -98,15 +98,15 @@ ;; buffer it finds in a stream, if it does not become a security ;; issue." (unless (sm buffer stream) - (let ((length (device-buffer-length stream))) - (setf (sm buffer stream) (allocate-buffer length) - (sm buffpos stream) 0 - (sm buffer-ptr stream) 0 - (sm buf-len stream) length))) + (let ((length (device-buffer-length stream))) + (setf (sm buffer stream) (allocate-buffer length) + (sm buffpos stream) 0 + (sm buffer-ptr stream) 0 + (sm buf-len stream) length))) (when (any-stream-instance-flags stream :output) - (setf (sm control-out stream) *std-control-out-table*)) + (setf (sm control-out stream) *std-control-out-table*)) (setf (stream-external-format stream) - (getf options :external-format :default)) + (getf options :external-format :default)) stream))) ;;; Revert a file, if possible; otherwise just delete it. Used during @@ -116,22 +116,22 @@ ;;; as well, snarf error reporting from there. (defun revert-file (filename original) (declare (type simple-base-string filename) - (type (or simple-base-string null) original)) + (type (or simple-base-string null) original)) ;; We can't do anything unless we know what file were ;; dealing with, and we don't want to do anything ;; strange unless we were writing to the file. (if original (multiple-value-bind (okay err) (sb-unix:unix-rename original filename) - (unless okay - (cerror "Go on as if nothing bad happened." - "Could not restore ~S to its original contents: ~A" - filename (sb-int:strerror err)))) + (unless okay + (cerror "Go on as if nothing bad happened." + "Could not restore ~S to its original contents: ~A" + filename (sb-int:strerror err)))) ;; We can't restore the original, so nuke that puppy. (multiple-value-bind (okay err) (sb-unix:unix-unlink filename) - (unless okay - (cerror "Go on as if nothing bad happened." - "Could not remove ~S: ~A" - filename (sb-int:strerror err)))))) + (unless okay + (cerror "Go on as if nothing bad happened." + "Could not remove ~S: ~A" + filename (sb-int:strerror err)))))) ;;; DELETE-ORIGINAL -- internal ;;; @@ -141,110 +141,110 @@ ;;; as well, snarf error reporting from there. (defun delete-original (filename original) (declare (type simple-base-string filename) - (type (or simple-base-string null) original)) + (type (or simple-base-string null) original)) (when original (multiple-value-bind (okay err) (sb-unix:unix-unlink original) (unless okay - (cerror "Go on as if nothing bad happened." - "Could not delete ~S during close of ~S: ~A" - original filename (sb-int:strerror err)))))) + (cerror "Go on as if nothing bad happened." + "Could not delete ~S during close of ~S: ~A" + original filename (sb-int:strerror err)))))) (defmethod device-close ((stream file-simple-stream) abort) (with-stream-class (file-simple-stream stream) (let ((fd (or (sm input-handle stream) (sm output-handle stream)))) (when (sb-int:fixnump fd) - (cond (abort - (when (any-stream-instance-flags stream :output) - (revert-file (sm filename stream) (sm original stream)))) - (t - (when (sm delete-original stream) - (delete-original (sm filename stream) (sm original stream))))) - (sb-unix:unix-close fd)) + (cond (abort + (when (any-stream-instance-flags stream :output) + (revert-file (sm filename stream) (sm original stream)))) + (t + (when (sm delete-original stream) + (delete-original (sm filename stream) (sm original stream))))) + (sb-unix:unix-close fd)) (when (sm buffer stream) - (free-buffer (sm buffer stream)) - (setf (sm buffer stream) nil)))) + (free-buffer (sm buffer stream)) + (setf (sm buffer stream) nil)))) t) (defmethod device-file-position ((stream file-simple-stream)) (with-stream-class (file-simple-stream stream) (let ((fd (or (sm input-handle stream) (sm output-handle stream)))) (if (sb-int:fixnump fd) - (values (sb-unix:unix-lseek fd 0 sb-unix:l_incr)) - (file-position fd))))) + (values (sb-unix:unix-lseek fd 0 sb-unix:l_incr)) + (file-position fd))))) (defmethod (setf device-file-position) (value (stream file-simple-stream)) (declare (type fixnum value)) (with-stream-class (file-simple-stream stream) (let ((fd (or (sm input-handle stream) (sm output-handle stream)))) (if (sb-int:fixnump fd) - (values (sb-unix:unix-lseek fd + (values (sb-unix:unix-lseek fd (if (minusp value) (1+ value) value) (if (minusp value) sb-unix:l_xtnd sb-unix:l_set))) - (file-position fd value))))) + (file-position fd value))))) (defmethod device-file-length ((stream file-simple-stream)) (with-stream-class (file-simple-stream stream) (let ((fd (or (sm input-handle stream) (sm output-handle stream)))) (if (sb-int:fixnump fd) - (multiple-value-bind (okay dev ino mode nlink uid gid rdev size) - (sb-unix:unix-fstat (sm input-handle stream)) - (declare (ignore dev ino mode nlink uid gid rdev)) - (if okay size nil)) - (file-length fd))))) + (multiple-value-bind (okay dev ino mode nlink uid gid rdev size) + (sb-unix:unix-fstat (sm input-handle stream)) + (declare (ignore dev ino mode nlink uid gid rdev)) + (if okay size nil)) + (file-length fd))))) (defmethod device-open ((stream mapped-file-simple-stream) options) (with-stream-class (mapped-file-simple-stream stream) (when (open-file-stream stream options) (let* ((input (any-stream-instance-flags stream :input)) - (output (any-stream-instance-flags stream :output)) - (prot (logior (if input sb-posix::PROT-READ 0) - (if output sb-posix::PROT-WRITE 0))) - (fd (or (sm input-handle stream) (sm output-handle stream)))) - (unless (sb-int:fixnump fd) - (error "Can't memory-map an encapsulated stream.")) - (multiple-value-bind (okay dev ino mode nlink uid gid rdev size) - (sb-unix:unix-fstat fd) - (declare (ignore ino mode nlink uid gid rdev)) - (unless okay - (sb-unix:unix-close fd) - (sb-ext:cancel-finalization stream) - (error "Error fstating ~S: ~A" stream - (sb-int:strerror dev))) - (when (>= size most-positive-fixnum) - ;; Or else BUF-LEN has to be a general integer, or - ;; maybe (unsigned-byte 32). In any case, this means - ;; BUF-MAX and BUF-PTR have to be the same, which means - ;; number-consing every time BUF-PTR moves... - ;; Probably don't have the address space available to map - ;; bigger files, anyway. Maybe DEVICE-READ can adjust - ;; the mapped portion of the file when necessary? - (warn "Unable to memory-map entire file.") - (setf size (1- most-positive-fixnum))) - (let ((buffer - (handler-case + (output (any-stream-instance-flags stream :output)) + (prot (logior (if input sb-posix::PROT-READ 0) + (if output sb-posix::PROT-WRITE 0))) + (fd (or (sm input-handle stream) (sm output-handle stream)))) + (unless (sb-int:fixnump fd) + (error "Can't memory-map an encapsulated stream.")) + (multiple-value-bind (okay dev ino mode nlink uid gid rdev size) + (sb-unix:unix-fstat fd) + (declare (ignore ino mode nlink uid gid rdev)) + (unless okay + (sb-unix:unix-close fd) + (sb-ext:cancel-finalization stream) + (error "Error fstating ~S: ~A" stream + (sb-int:strerror dev))) + (when (>= size most-positive-fixnum) + ;; Or else BUF-LEN has to be a general integer, or + ;; maybe (unsigned-byte 32). In any case, this means + ;; BUF-MAX and BUF-PTR have to be the same, which means + ;; number-consing every time BUF-PTR moves... + ;; Probably don't have the address space available to map + ;; bigger files, anyway. Maybe DEVICE-READ can adjust + ;; the mapped portion of the file when necessary? + (warn "Unable to memory-map entire file.") + (setf size (1- most-positive-fixnum))) + (let ((buffer + (handler-case (sb-posix:mmap nil size prot sb-posix::MAP-SHARED fd 0) (sb-posix:syscall-error nil)))) - (when (null buffer) - (sb-unix:unix-close fd) - (sb-ext:cancel-finalization stream) - (error "Unable to map file.")) - (setf (sm buffer stream) buffer - (sm buffpos stream) 0 - (sm buffer-ptr stream) size - (sm buf-len stream) size) - (when (any-stream-instance-flags stream :output) - (setf (sm control-out stream) *std-control-out-table*)) - (let ((efmt (getf options :external-format :default))) + (when (null buffer) + (sb-unix:unix-close fd) + (sb-ext:cancel-finalization stream) + (error "Unable to map file.")) + (setf (sm buffer stream) buffer + (sm buffpos stream) 0 + (sm buffer-ptr stream) size + (sm buf-len stream) size) + (when (any-stream-instance-flags stream :output) + (setf (sm control-out stream) *std-control-out-table*)) + (let ((efmt (getf options :external-format :default))) (compose-encapsulating-streams stream efmt) (setf (stream-external-format stream) efmt) ;; overwrite the strategy installed in :after method of ;; (setf stream-external-format) - (install-single-channel-character-strategy - (melding-stream stream) efmt 'mapped)) - (sb-ext:finalize stream - (lambda () - (sb-posix:munmap buffer size) - (format *terminal-io* "~&;;; ** unmapped ~S" buffer)))))) + (install-single-channel-character-strategy + (melding-stream stream) efmt 'mapped)) + (sb-ext:finalize stream + (lambda () + (sb-posix:munmap buffer size) + (format *terminal-io* "~&;;; ** unmapped ~S" buffer)))))) stream))) @@ -257,7 +257,7 @@ t) (defmethod device-write ((stream mapped-file-simple-stream) buffer - start end blocking) + start end blocking) (assert (eq buffer :flush) (buffer)) ; finish/force-output (with-stream-class (mapped-file-simple-stream stream) (sb-posix:msync (sm buffer stream) (sm buf-len stream) @@ -268,5 +268,5 @@ (with-stream-class (probe-simple-stream stream) (add-stream-instance-flags stream :simple) (when (sb-unix:unix-access (sb-int:unix-namestring pathname nil) sb-unix:f_ok) - (setf (sm pathname stream) pathname) - t)))) + (setf (sm pathname stream) pathname) + t)))) diff --git a/contrib/sb-simple-streams/fndb.lisp b/contrib/sb-simple-streams/fndb.lisp index 2df6088..ad29bbc 100644 --- a/contrib/sb-simple-streams/fndb.lisp +++ b/contrib/sb-simple-streams/fndb.lisp @@ -22,24 +22,24 @@ Here's a (smarter) replacement: (defun result-type-open-class (call) (declare (type sb-c::combination call)) (let* ((not-set '#:not-set) - (not-constant '#:not-constant) - (direction not-set) - (if-exists not-set) - (if-does-not-exist not-set) - (class not-set)) + (not-constant '#:not-constant) + (direction not-set) + (if-exists not-set) + (if-does-not-exist not-set) + (class not-set)) ;; find (the first occurence of) each interesting keyword argument (do ((args (cdr (combination-args call)) (cddr args))) - ((null args)) + ((null args)) (macrolet ((maybe-set (var) - `(when (and (eq ,var not-set) (cadr args)) - (if (constant-continuation-p (cadr args)) - (setq ,var (continuation-value (cadr args))) - (setq ,var not-constant))))) - (case (continuation-value (car args)) - (:direction (maybe-set direction)) - (:if-exists (maybe-set if-exists)) - (:if-does-not-exist (maybe-set if-does-not-exist)) - (:class (maybe-set class))))) + `(when (and (eq ,var not-set) (cadr args)) + (if (constant-continuation-p (cadr args)) + (setq ,var (continuation-value (cadr args))) + (setq ,var not-constant))))) + (case (continuation-value (car args)) + (:direction (maybe-set direction)) + (:if-exists (maybe-set if-exists)) + (:if-does-not-exist (maybe-set if-does-not-exist)) + (:class (maybe-set class))))) ;; and set default values for any that weren't set above (when (eq direction not-set) (setq direction :input)) (when (eq if-exists not-constant) (setq if-exists nil)) @@ -51,11 +51,11 @@ Here's a (smarter) replacement: ;; direction is :output or :io or not-constant and :if-exists is nil ;; :if-does-not-exist is nil (if (or (and (or (eq direction :probe) (eq direction not-constant)) - (not (eq if-does-not-exist :error))) - (and (or (eq direction :output) (eq direction :io) - (eq direction not-constant)) - (eq if-exists nil)) - (eq if-does-not-exist nil)) + (not (eq if-does-not-exist :error))) + (and (or (eq direction :output) (eq direction :io) + (eq direction not-constant)) + (eq if-exists nil)) + (eq if-does-not-exist nil)) (specifier-type `(or null ,class)) (specifier-type class)))) diff --git a/contrib/sb-simple-streams/impl.lisp b/contrib/sb-simple-streams/impl.lisp index c37e141..1c7582e 100644 --- a/contrib/sb-simple-streams/impl.lisp +++ b/contrib/sb-simple-streams/impl.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. -;;; +;;; ;;; Sbcl port by Rudi Schlatte. @@ -19,19 +19,19 @@ (defun %check (stream kind) (declare (type simple-stream stream) - (optimize (speed 3) (space 1) (debug 0) (safety 0))) + (optimize (speed 3) (space 1) (debug 0) (safety 0))) (with-stream-class (simple-stream stream) (cond ((not (any-stream-instance-flags stream :simple)) - (%uninitialized stream)) - ((and (eq kind :open) - (not (any-stream-instance-flags stream :input :output))) - (sb-kernel:closed-flame stream)) - ((and (or (eq kind :input) (eq kind :io)) - (not (any-stream-instance-flags stream :input))) - (sb-kernel:ill-in stream)) - ((and (or (eq kind :output) (eq kind :io)) - (not (any-stream-instance-flags stream :output))) - (sb-kernel:ill-out stream))))) + (%uninitialized stream)) + ((and (eq kind :open) + (not (any-stream-instance-flags stream :input :output))) + (sb-kernel:closed-flame stream)) + ((and (or (eq kind :input) (eq kind :io)) + (not (any-stream-instance-flags stream :input))) + (sb-kernel:ill-in stream)) + ((and (or (eq kind :output) (eq kind :io)) + (not (any-stream-instance-flags stream :output))) + (sb-kernel:ill-out stream))))) (defmethod input-stream-p ((stream simple-stream)) (any-stream-instance-flags stream :input)) @@ -51,54 +51,54 @@ (defun %file-position (stream position) (declare (type simple-stream stream) - (type (or (integer 0 *) (member nil :start :end)) position)) + (type (or (integer 0 *) (member nil :start :end)) position)) (with-stream-class (simple-stream stream) (%check stream :open) (if position - ;; Adjust current position - (let ((position (case position (:start 0) (:end -1) - (otherwise position)))) - (etypecase stream - (single-channel-simple-stream + ;; Adjust current position + (let ((position (case position (:start 0) (:end -1) + (otherwise position)))) + (etypecase stream + (single-channel-simple-stream (when (sc-dirty-p stream) (flush-buffer stream t))) - (dual-channel-simple-stream + (dual-channel-simple-stream (with-stream-class (dual-channel-simple-stream stream) - (when (> (sm outpos stream) 0) + (when (> (sm outpos stream) 0) (device-write stream :flush 0 nil t)))) - (string-simple-stream + (string-simple-stream nil)) - (setf (sm last-char-read-size stream) 0) - (setf (sm buffpos stream) 0 ; set pointer to 0 to force a read - (sm buffer-ptr stream) 0) - (setf (sm charpos stream) nil) - (remove-stream-instance-flags stream :eof) - (setf (device-file-position stream) position)) - ;; Just report current position - (let ((posn (device-file-position stream))) - (when posn - (when (sm handler stream) - (dolist (queued (sm pending stream)) - (incf posn (- (the sb-int:index (third queued)) - (the sb-int:index (second queued)))))) - (etypecase stream - (single-channel-simple-stream + (setf (sm last-char-read-size stream) 0) + (setf (sm buffpos stream) 0 ; set pointer to 0 to force a read + (sm buffer-ptr stream) 0) + (setf (sm charpos stream) nil) + (remove-stream-instance-flags stream :eof) + (setf (device-file-position stream) position)) + ;; Just report current position + (let ((posn (device-file-position stream))) + (when posn + (when (sm handler stream) + (dolist (queued (sm pending stream)) + (incf posn (- (the sb-int:index (third queued)) + (the sb-int:index (second queued)))))) + (etypecase stream + (single-channel-simple-stream (case (sm mode stream) - ((0 3) ; read, read-modify + ((0 3) ; read, read-modify ;; Note that posn can increase here if we wrote ;; past the end of previously-read data (decf posn (- (sm buffer-ptr stream) (sm buffpos stream)))) - (1 ; write + (1 ; write (incf posn (sm buffpos stream))))) - (dual-channel-simple-stream + (dual-channel-simple-stream (with-stream-class (dual-channel-simple-stream stream) - (incf posn (sm outpos stream)) + (incf posn (sm outpos stream)) (when (>= (sm buffer-ptr stream) 0) (decf posn (- (sm buffer-ptr stream) (sm buffpos stream)))))) - (string-simple-stream + (string-simple-stream nil))) - posn)))) + posn)))) (defun %file-length (stream) (declare (type simple-stream stream)) @@ -125,9 +125,9 @@ (%check stream nil) (if (typep stream 'file-simple-stream) (with-stream-class (file-simple-stream stream) - (setf (sm pathname stream) new-name) - (setf (sm filename stream) (sb-int:unix-namestring new-name nil)) - t) + (setf (sm pathname stream) new-name) + (setf (sm filename stream) (sb-int:unix-namestring new-name nil)) + t) nil)) @@ -138,102 +138,102 @@ ;; FIXME: need to account for compositions on the stream... (let ((count 0)) (flet ((fn (octet) - (declare (ignore octet)) - (incf count))) - (etypecase object - (character - (let ((x nil)) - (char-to-octets (sm external-format stream) object x #'fn))) - (string - (let ((x nil) - (ef (sm external-format stream))) - (dotimes (i (length object)) - (declare (type sb-int:index i)) - (char-to-octets ef (char object i) x #'fn)))))) + (declare (ignore octet)) + (incf count))) + (etypecase object + (character + (let ((x nil)) + (char-to-octets (sm external-format stream) object x #'fn))) + (string + (let ((x nil) + (ef (sm external-format stream))) + (dotimes (i (length object)) + (declare (type sb-int:index i)) + (char-to-octets ef (char object i) x #'fn)))))) count))) (defun %read-line (stream eof-error-p eof-value recursive-p) (declare (optimize (speed 3) (space 1) (safety 0) (debug 0)) - (type simple-stream stream) - (ignore recursive-p)) + (type simple-stream stream) + (ignore recursive-p)) (with-stream-class (simple-stream stream) (%check stream :input) (when (any-stream-instance-flags stream :eof) (return-from %read-line - (sb-impl::eof-or-lose stream eof-error-p eof-value))) + (sb-impl::eof-or-lose stream eof-error-p eof-value))) ;; for interactive streams, finish output first to force prompt (when (and (any-stream-instance-flags stream :output) - (any-stream-instance-flags stream :interactive)) + (any-stream-instance-flags stream :interactive)) (%finish-output stream)) (let* ((encap (sm melded-stream stream)) ; encapsulating stream - (cbuf (make-string 80)) ; current buffer - (bufs (list cbuf)) ; list of buffers - (tail bufs) ; last cons of bufs list - (index 0) ; current index in current buffer - (total 0)) ; total characters + (cbuf (make-string 80)) ; current buffer + (bufs (list cbuf)) ; list of buffers + (tail bufs) ; last cons of bufs list + (index 0) ; current index in current buffer + (total 0)) ; total characters (declare (type simple-stream encap) - (type simple-string cbuf) - (type cons bufs tail) - (type sb-int:index index total)) + (type simple-string cbuf) + (type cons bufs tail) + (type sb-int:index index total)) (loop - (multiple-value-bind (chars done) - (funcall-stm-handler j-read-chars encap cbuf - #\Newline index (length cbuf) t) - (declare (type sb-int:index chars)) - (incf index chars) - (incf total chars) - (when (and (eq done :eof) (zerop total)) - (if eof-error-p - (error 'end-of-file :stream stream) - (return (values eof-value t)))) - (when done - ;; If there's only one buffer in use, return it directly - (when (null (cdr bufs)) - (return (values (sb-kernel:shrink-vector cbuf total) - (eq done :eof)))) - ;; If total fits in final buffer, use it - (when (<= total (length cbuf)) - (replace cbuf cbuf :start1 (- total index) :end2 index) - (let ((idx 0)) - (declare (type sb-int:index idx)) - (do ((list bufs (cdr list))) - ((eq list tail)) - (let ((buf (car list))) - (declare (type simple-string buf)) - (replace cbuf buf :start1 idx) - (incf idx (length buf))))) - (return (values (sb-kernel:shrink-vector cbuf total) - (eq done :eof)))) - ;; Allocate new string of appropriate length - (let ((string (make-string total)) - (index 0)) - (declare (type sb-int:index index)) - (dolist (buf bufs) - (declare (type simple-string buf)) - (replace string buf :start1 index) - (incf index (length buf))) - (return (values string (eq done :eof))))) - (when (>= index (length cbuf)) - (setf cbuf (make-string (the sb-int:index (* 2 index)))) - (setf index 0) - (setf (cdr tail) (cons cbuf nil)) - (setf tail (cdr tail)))))))) + (multiple-value-bind (chars done) + (funcall-stm-handler j-read-chars encap cbuf + #\Newline index (length cbuf) t) + (declare (type sb-int:index chars)) + (incf index chars) + (incf total chars) + (when (and (eq done :eof) (zerop total)) + (if eof-error-p + (error 'end-of-file :stream stream) + (return (values eof-value t)))) + (when done + ;; If there's only one buffer in use, return it directly + (when (null (cdr bufs)) + (return (values (sb-kernel:shrink-vector cbuf total) + (eq done :eof)))) + ;; If total fits in final buffer, use it + (when (<= total (length cbuf)) + (replace cbuf cbuf :start1 (- total index) :end2 index) + (let ((idx 0)) + (declare (type sb-int:index idx)) + (do ((list bufs (cdr list))) + ((eq list tail)) + (let ((buf (car list))) + (declare (type simple-string buf)) + (replace cbuf buf :start1 idx) + (incf idx (length buf))))) + (return (values (sb-kernel:shrink-vector cbuf total) + (eq done :eof)))) + ;; Allocate new string of appropriate length + (let ((string (make-string total)) + (index 0)) + (declare (type sb-int:index index)) + (dolist (buf bufs) + (declare (type simple-string buf)) + (replace string buf :start1 index) + (incf index (length buf))) + (return (values string (eq done :eof))))) + (when (>= index (length cbuf)) + (setf cbuf (make-string (the sb-int:index (* 2 index)))) + (setf index 0) + (setf (cdr tail) (cons cbuf nil)) + (setf tail (cdr tail)))))))) (defun %read-char (stream eof-error-p eof-value recursive-p blocking-p) (declare (type simple-stream stream) - (ignore recursive-p)) + (ignore recursive-p)) (with-stream-class (simple-stream stream) (%check stream :input) (when (any-stream-instance-flags stream :eof) (return-from %read-char - (sb-impl::eof-or-lose stream eof-error-p eof-value))) + (sb-impl::eof-or-lose stream eof-error-p eof-value))) ;; for interactive streams, finish output first to force prompt (when (and (any-stream-instance-flags stream :output) - (any-stream-instance-flags stream :interactive)) + (any-stream-instance-flags stream :interactive)) (%finish-output stream)) (funcall-stm-handler j-read-char (sm melded-stream stream) - eof-error-p eof-value blocking-p))) + eof-error-p eof-value blocking-p))) (defun %unread-char (stream character) @@ -241,45 +241,45 @@ (with-stream-class (simple-stream stream) (%check stream :input) (if (zerop (sm last-char-read-size stream)) - (error "Nothing to unread.") - (progn - (funcall-stm-handler j-unread-char (sm melded-stream stream) nil) - (remove-stream-instance-flags stream :eof) - (setf (sm last-char-read-size stream) 0))))) + (error "Nothing to unread.") + (progn + (funcall-stm-handler j-unread-char (sm melded-stream stream) nil) + (remove-stream-instance-flags stream :eof) + (setf (sm last-char-read-size stream) 0))))) (defun %peek-char (stream peek-type eof-error-p eof-value recursive-p) (declare (type simple-stream stream) - (ignore recursive-p)) + (ignore recursive-p)) (with-stream-class (simple-stream stream) (%check stream :input) (when (any-stream-instance-flags stream :eof) (return-from %peek-char - (sb-impl::eof-or-lose stream eof-error-p eof-value))) + (sb-impl::eof-or-lose stream eof-error-p eof-value))) (let* ((encap (sm melded-stream stream)) - (char (funcall-stm-handler j-read-char encap - eof-error-p stream t))) + (char (funcall-stm-handler j-read-char encap + eof-error-p stream t))) (cond ((eq char stream) eof-value) - ((characterp peek-type) - (do ((char char (funcall-stm-handler j-read-char encap - eof-error-p - stream t))) - ((or (eq char stream) (char= char peek-type)) - (unless (eq char stream) - (funcall-stm-handler j-unread-char encap t)) - (if (eq char stream) eof-value char)))) - ((eq peek-type t) - (do ((char char (funcall-stm-handler j-read-char encap - eof-error-p - stream t))) - ((or (eq char stream) - (not (sb-impl::whitespacep char))) - (unless (eq char stream) - (funcall-stm-handler j-unread-char encap t)) - (if (eq char stream) eof-value char)))) - (t - (funcall-stm-handler j-unread-char encap t) - char))))) + ((characterp peek-type) + (do ((char char (funcall-stm-handler j-read-char encap + eof-error-p + stream t))) + ((or (eq char stream) (char= char peek-type)) + (unless (eq char stream) + (funcall-stm-handler j-unread-char encap t)) + (if (eq char stream) eof-value char)))) + ((eq peek-type t) + (do ((char char (funcall-stm-handler j-read-char encap + eof-error-p + stream t))) + ((or (eq char stream) + (not (sb-impl::whitespacep char))) + (unless (eq char stream) + (funcall-stm-handler j-unread-char encap t)) + (if (eq char stream) eof-value char)))) + (t + (funcall-stm-handler j-unread-char encap t) + char))))) (defun %listen (stream width) (declare (type simple-stream stream)) @@ -290,24 +290,24 @@ (when (any-stream-instance-flags stream :eof) (return-from %listen nil)) (if (not (or (eql width 1) (null width))) - (funcall-stm-handler j-listen (sm melded-stream stream)) - (or (< (sm buffpos stream) (sm buffer-ptr stream)) - ;; Attempt buffer refill - (let ((lcrs (sm last-char-read-size stream))) - (when (and (not (any-stream-instance-flags stream :dual :string)) - (>= (sm mode stream) 0)) - ;; single-channel stream dirty -> write data before reading - (flush-buffer stream nil)) - (>= (refill-buffer stream nil) width)))))) + (funcall-stm-handler j-listen (sm melded-stream stream)) + (or (< (sm buffpos stream) (sm buffer-ptr stream)) + ;; Attempt buffer refill + (let ((lcrs (sm last-char-read-size stream))) + (when (and (not (any-stream-instance-flags stream :dual :string)) + (>= (sm mode stream) 0)) + ;; single-channel stream dirty -> write data before reading + (flush-buffer stream nil)) + (>= (refill-buffer stream nil) width)))))) (defun %clear-input (stream buffer-only) (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :input) (setf (sm buffpos stream) 0 - (sm buffer-ptr stream) 0 - (sm last-char-read-size stream) 0 - #|(sm unread-past-soft-eof stream) nil|#) + (sm buffer-ptr stream) 0 + (sm last-char-read-size stream) 0 + #|(sm unread-past-soft-eof stream) nil|#) #| (setf (sm reread-count stream) 0) on dual-channel streams? |# ) (device-clear-input stream buffer-only)) @@ -318,15 +318,15 @@ (with-stream-class (simple-stream stream) (%check stream :input) (if (any-stream-instance-flags stream :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - (etypecase stream - (single-channel-simple-stream + (sb-impl::eof-or-lose stream eof-error-p eof-value) + (etypecase stream + (single-channel-simple-stream (read-byte-internal stream eof-error-p eof-value t)) (dual-channel-simple-stream (read-byte-internal stream eof-error-p eof-value t)) - (string-simple-stream + (string-simple-stream (with-stream-class (string-simple-stream stream) - (let ((encap (sm input-handle stream))) + (let ((encap (sm input-handle stream))) (unless encap (error 'simple-type-error :datum stream @@ -360,7 +360,7 @@ (with-stream-class (simple-stream stream) (%check stream :output) (funcall-stm-handler-2 j-write-chars string (sm melded-stream stream) - start end))) + start end))) (defun %line-length (stream) @@ -376,8 +376,8 @@ (%check stream :output) (when (sm handler stream) (do () - ((null (sm pending stream))) - (sb-sys:serve-all-events))) + ((null (sm pending stream))) + (sb-sys:serve-all-events))) (etypecase stream (single-channel-simple-stream ;(when (and (> (sm mode stream) 0) (> (sm buffer-ptr stream) 0)) @@ -389,7 +389,7 @@ (dual-channel-simple-stream (with-stream-class (dual-channel-simple-stream stream) (device-write stream :flush 0 nil t) - (setf (sm outpos stream) 0))) + (setf (sm outpos stream) 0))) (string-simple-stream (device-write stream :flush 0 nil t)))) nil) @@ -410,7 +410,7 @@ (dual-channel-simple-stream (with-stream-class (dual-channel-simple-stream stream) (device-write stream :flush 0 nil nil) - (setf (sm outpos stream) 0))) + (setf (sm outpos stream) 0))) (string-simple-stream (device-write stream :flush 0 nil nil)))) nil) @@ -423,11 +423,11 @@ (when (sm handler stream) (sb-sys:remove-fd-handler (sm handler stream)) (setf (sm handler stream) nil - (sm pending stream) nil)) + (sm pending stream) nil)) (etypecase stream (single-channel-simple-stream (with-stream-class (single-channel-simple-stream stream) - (case (sm mode stream) + (case (sm mode stream) (1 (setf (sm buffpos stream) 0)) (3 (setf (sm mode stream) 0))))) (dual-channel-simple-stream @@ -444,16 +444,16 @@ (etypecase stream (single-channel-simple-stream (with-stream-class (single-channel-simple-stream stream) - (let ((ptr (sm buffpos stream))) - (when (>= ptr (sm buf-len stream)) - (setf ptr (flush-buffer stream t))) - (setf (sm buffpos stream) (1+ ptr)) + (let ((ptr (sm buffpos stream))) + (when (>= ptr (sm buf-len stream)) + (setf ptr (flush-buffer stream t))) + (setf (sm buffpos stream) (1+ ptr)) (setf (sm charpos stream) nil) - (setf (bref (sm buffer stream) ptr) integer) + (setf (bref (sm buffer stream) ptr) integer) (sc-set-dirty stream)))) (dual-channel-simple-stream (with-stream-class (dual-channel-simple-stream stream) - (let ((ptr (sm outpos stream))) + (let ((ptr (sm outpos stream))) (when (>= ptr (sm max-out-pos stream)) (setf ptr (flush-out-buffer stream t))) (setf (sm outpos stream) (1+ ptr)) @@ -461,7 +461,7 @@ (setf (bref (sm out-buffer stream) ptr) integer)))) (string-simple-stream (with-stream-class (string-simple-stream stream) - (let ((encap (sm output-handle stream))) + (let ((encap (sm output-handle stream))) (unless encap (error 'simple-type-error :datum stream @@ -473,9 +473,9 @@ (defun %read-sequence (stream seq start end partial-fill) (declare (type simple-stream stream) - (type sequence seq) - (type sb-int:index start end) - (type boolean partial-fill)) + (type sequence seq) + (type sb-int:index start end) + (type boolean partial-fill)) (with-stream-class (simple-stream stream) (%check stream :input) (when (any-stream-instance-flags stream :eof) @@ -486,12 +486,12 @@ (etypecase seq (string (funcall-stm-handler j-read-chars (sm melded-stream stream) seq nil - start end - (if partial-fill :bnb t))) + start end + (if partial-fill :bnb t))) ((or (simple-array (unsigned-byte 8) (*)) - (simple-array (signed-byte 8) (*))) + (simple-array (signed-byte 8) (*))) (when (any-stream-instance-flags stream :string) - (error "Can't read into byte sequence from a string stream.")) + (error "Can't read into byte sequence from a string stream.")) ;; "read-vector" equivalent, but blocking if partial-fill is NIL ;; FIXME: this could be implemented faster via buffer-copy (loop with encap = (sm melded-stream stream) @@ -506,16 +506,16 @@ (defun %write-sequence (stream seq start end) (declare (type simple-stream stream) - (type sequence seq) - (type sb-int:index start end)) + (type sequence seq) + (type sb-int:index start end)) (with-stream-class (simple-stream stream) (%check stream :output) (etypecase seq (string (funcall-stm-handler-2 j-write-chars seq (sm melded-stream stream) - start end)) + start end)) ((or (simple-array (unsigned-byte 8) (*)) - (simple-array (signed-byte 8) (*))) + (simple-array (signed-byte 8) (*))) ;; "write-vector" equivalent (setf (sm charpos stream) nil) (etypecase stream @@ -562,7 +562,7 @@ (defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8)) (declare (type (sb-kernel:simple-unboxed-array (*)) vector) - (type stream stream)) + (type stream stream)) ;; START and END are octet offsets, not vector indices! [Except for strings] ;; Return value is index of next octet to be read into (i.e., start+count) (etypecase stream @@ -591,8 +591,8 @@ (setf (bref vector (logxor index endian-swap)) byte)))))) ((or ansi-stream fundamental-stream) (unless (typep vector '(or string - (simple-array (signed-byte 8) (*)) - (simple-array (unsigned-byte 8) (*)))) + (simple-array (signed-byte 8) (*)) + (simple-array (unsigned-byte 8) (*)))) (error "Wrong vector type for read-vector on stream not of type simple-stream.")) (read-sequence vector stream :start (or start 0) :end end)))) @@ -687,16 +687,16 @@ (declare (ignore element-type external-format input-handle output-handle if-exists if-does-not-exist)) (let ((class (or class 'sb-sys:fd-stream)) - (options (copy-list options)) + (options (copy-list options)) (filespec (merge-pathnames filename))) (cond ((eq class 'sb-sys:fd-stream) - (remf options :class) + (remf options :class) (remf options :mapped) (remf options :input-handle) (remf options :output-handle) (apply #'open-fd-stream filespec options)) - ((subtypep class 'simple-stream) - (when element-type-given + ((subtypep class 'simple-stream) + (when element-type-given (cerror "Do it anyway." "Can't create simple-streams with an element-type.")) (when (and (eq class 'file-simple-stream) mapped) @@ -706,12 +706,12 @@ (when (eq direction :probe) (setq class 'probe-simple-stream))) (apply #'make-instance class :filename filespec options)) - ((subtypep class 'sb-gray:fundamental-stream) - (remf options :class) + ((subtypep class 'sb-gray:fundamental-stream) + (remf options :class) (remf options :mapped) (remf options :input-handle) (remf options :output-handle) - (make-instance class :lisp-stream + (make-instance class :lisp-stream (apply #'open-fd-stream filespec options)))))) @@ -727,12 +727,12 @@ (sb-impl::ansi-stream-read-byte stream eof-error-p eof-value nil)) (fundamental-stream (let ((char (sb-gray:stream-read-byte stream))) - (if (eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))))) + (if (eq char :eof) + (sb-impl::eof-or-lose stream eof-error-p eof-value) + char)))))) (defun read-char (&optional (stream *standard-input*) (eof-error-p t) - eof-value recursive-p) + eof-value recursive-p) "Inputs a character from Stream and returns it." (let ((stream (sb-impl::in-synonym-of stream))) (etypecase stream @@ -743,12 +743,12 @@ recursive-p)) (fundamental-stream (let ((char (sb-gray:stream-read-char stream))) - (if (eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))))) + (if (eq char :eof) + (sb-impl::eof-or-lose stream eof-error-p eof-value) + char)))))) (defun read-char-no-hang (&optional (stream *standard-input*) (eof-error-p t) - eof-value recursive-p) + eof-value recursive-p) "Returns the next character from the Stream if one is availible, or nil." (declare (ignore recursive-p)) (let ((stream (sb-impl::in-synonym-of stream))) @@ -756,15 +756,15 @@ (simple-stream (%check stream :input) (with-stream-class (simple-stream) - (funcall-stm-handler j-read-char stream eof-error-p eof-value nil))) + (funcall-stm-handler j-read-char stream eof-error-p eof-value nil))) (ansi-stream (sb-impl::ansi-stream-read-char-no-hang stream eof-error-p eof-value recursive-p)) (fundamental-stream (let ((char (sb-gray:stream-read-char-no-hang stream))) - (if (eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))))) + (if (eq char :eof) + (sb-impl::eof-or-lose stream eof-error-p eof-value) + char)))))) (defun unread-char (character &optional (stream *standard-input*)) "Puts the Character back on the front of the input Stream." @@ -781,7 +781,7 @@ (declaim (notinline read-byte read-char read-char-no-hang unread-char)) (defun peek-char (&optional (peek-type nil) (stream *standard-input*) - (eof-error-p t) eof-value recursive-p) + (eof-error-p t) eof-value recursive-p) "Peeks at the next character in the input Stream. See manual for details." (let ((stream (sb-impl::in-synonym-of stream))) (etypecase stream @@ -794,28 +794,28 @@ recursive-p)) (fundamental-stream (cond ((characterp peek-type) - (do ((char (sb-gray:stream-read-char stream) - (sb-gray:stream-read-char stream))) - ((or (eq char :eof) (char= char peek-type)) - (cond ((eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value)) - (t - (sb-gray:stream-unread-char stream char) - char))))) - ((eq peek-type t) - (do ((char (sb-gray:stream-read-char stream) - (sb-gray:stream-read-char stream))) - ((or (eq char :eof) (not (sb-impl::whitespacep char))) - (cond ((eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value)) - (t - (sb-gray:stream-unread-char stream char) - char))))) - (t - (let ((char (sb-gray:stream-peek-char stream))) - (if (eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))))))) + (do ((char (sb-gray:stream-read-char stream) + (sb-gray:stream-read-char stream))) + ((or (eq char :eof) (char= char peek-type)) + (cond ((eq char :eof) + (sb-impl::eof-or-lose stream eof-error-p eof-value)) + (t + (sb-gray:stream-unread-char stream char) + char))))) + ((eq peek-type t) + (do ((char (sb-gray:stream-read-char stream) + (sb-gray:stream-read-char stream))) + ((or (eq char :eof) (not (sb-impl::whitespacep char))) + (cond ((eq char :eof) + (sb-impl::eof-or-lose stream eof-error-p eof-value)) + (t + (sb-gray:stream-unread-char stream char) + char))))) + (t + (let ((char (sb-gray:stream-peek-char stream))) + (if (eq char :eof) + (sb-impl::eof-or-lose stream eof-error-p eof-value) + char)))))))) (defun listen (&optional (stream *standard-input*) (width 1)) "Returns T if WIDTH octets are available on STREAM. If WIDTH is @@ -834,7 +834,7 @@ is supported only on simple-streams." (defun read-line (&optional (stream *standard-input*) (eof-error-p t) - eof-value recursive-p) + eof-value recursive-p) "Returns a line of text read from the Stream as a string, discarding the newline character." (let ((stream (sb-impl::in-synonym-of stream))) @@ -846,9 +846,9 @@ is supported only on simple-streams." recursive-p)) (fundamental-stream (multiple-value-bind (string eof) (sb-gray:stream-read-line stream) - (if (and eof (zerop (length string))) - (values (sb-impl::eof-or-lose stream eof-error-p eof-value) t) - (values string eof))))))) + (if (and eof (zerop (length string))) + (values (sb-impl::eof-or-lose stream eof-error-p eof-value) t) + (values string eof))))))) (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill) "Destructively modify SEQ by reading elements from STREAM. @@ -858,11 +858,11 @@ is supported only on simple-streams." then the extra elements near the end of sequence are not updated, and the index of the next element is returned." (let ((stream (sb-impl::in-synonym-of stream)) - (end (or end (length seq)))) + (end (or end (length seq)))) (etypecase stream (simple-stream (with-stream-class (simple-stream stream) - (%read-sequence stream seq start end partial-fill))) + (%read-sequence stream seq start end partial-fill))) (ansi-stream (sb-impl::ansi-stream-read-sequence seq stream start end)) (fundamental-stream @@ -905,10 +905,10 @@ is supported only on simple-streams." character) (defun write-string (string &optional (stream *standard-output*) - &key (start 0) (end nil)) + &key (start 0) (end nil)) "Outputs the String to the given Stream." (let ((stream (sb-impl::out-synonym-of stream)) - (end (sb-impl::%check-vector-sequence-bounds string start end))) + (end (sb-impl::%check-vector-sequence-bounds string start end))) (etypecase stream (simple-stream (%write-string stream string start end) @@ -919,16 +919,16 @@ is supported only on simple-streams." (sb-gray:stream-write-string stream string start end))))) (defun write-line (string &optional (stream *standard-output*) - &key (start 0) end) + &key (start 0) end) (declare (type string string)) (let ((stream (sb-impl::out-synonym-of stream)) - (end (sb-impl::%check-vector-sequence-bounds string start end))) + (end (sb-impl::%check-vector-sequence-bounds string start end))) (etypecase stream (simple-stream (%check stream :output) (with-stream-class (simple-stream stream) - (funcall-stm-handler-2 j-write-chars string stream start end) - (funcall-stm-handler-2 j-write-char #\Newline stream))) + (funcall-stm-handler-2 j-write-chars string stream start end) + (funcall-stm-handler-2 j-write-char #\Newline stream))) (ansi-stream (sb-impl::ansi-stream-write-string string stream start end) (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline)) @@ -940,7 +940,7 @@ is supported only on simple-streams." (defun write-sequence (seq stream &key (start 0) (end nil)) "Write the elements of SEQ bounded by START and END to STREAM." (let ((stream (sb-impl::out-synonym-of stream)) - (end (or end (length seq)))) + (end (or end (length seq)))) (etypecase stream (simple-stream (%write-sequence stream seq start end)) @@ -956,7 +956,7 @@ is supported only on simple-streams." (simple-stream (%check stream :output) (with-stream-class (simple-stream stream) - (funcall-stm-handler-2 j-write-char #\Newline stream))) + (funcall-stm-handler-2 j-write-char #\Newline stream))) (ansi-stream (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline)) (fundamental-stream @@ -1074,17 +1074,17 @@ is supported only on simple-streams." (simple-stream (%check stream :input) (with-stream-class (simple-stream stream) - (or (< (sm buffpos stream) (sm buffer-ptr stream)) - (wait-for-input-available (sm input-handle stream) timeout)))) + (or (< (sm buffpos stream) (sm buffer-ptr stream)) + (wait-for-input-available (sm input-handle stream) timeout)))) (two-way-stream (wait-for-input-available (two-way-stream-input-stream stream) timeout)) (synonym-stream (wait-for-input-available (symbol-value (synonym-stream-symbol stream)) - timeout)) + timeout)) (sb-sys:fd-stream (or (< (sb-impl::fd-stream-in-index stream) - (length (sb-impl::fd-stream-in-buffer stream))) - (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout)))))) + (length (sb-impl::fd-stream-in-buffer stream))) + (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout)))))) ;; Make PATHNAME and NAMESTRING work (defun sb-int:file-name (stream &optional new-name) @@ -1093,13 +1093,13 @@ is supported only on simple-streams." (with-stream-class (file-simple-stream stream) (cond (new-name (%file-rename stream new-name)) - (t - (%file-name stream))))) + (t + (%file-name stream))))) (sb-sys:fd-stream (cond (new-name - (setf (sb-impl::fd-stream-pathname stream) new-name) - (setf (sb-impl::fd-stream-file stream) - (sb-int:unix-namestring new-name nil)) - t) - (t - (sb-impl::fd-stream-pathname stream)))))) + (setf (sb-impl::fd-stream-pathname stream) new-name) + (setf (sb-impl::fd-stream-file stream) + (sb-int:unix-namestring new-name nil)) + t) + (t + (sb-impl::fd-stream-pathname stream)))))) diff --git a/contrib/sb-simple-streams/internal.lisp b/contrib/sb-simple-streams/internal.lisp index 659f2db..dacfb86 100644 --- a/contrib/sb-simple-streams/internal.lisp +++ b/contrib/sb-simple-streams/internal.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. -;;; +;;; ;;; Sbcl port by Rudi Schlatte. @@ -14,34 +14,34 @@ ;;; ;;; Various functions needed by simple-streams (declaim (inline buffer-sap bref (setf bref) buffer-copy - allocate-buffer free-buffer)) + allocate-buffer free-buffer)) (defun buffer-sap (thing &optional offset) (declare (type simple-stream-buffer thing) (type (or fixnum null) offset) - (optimize (speed 3) (space 2) (debug 0) (safety 0) - ;; Suppress the note about having to box up the return: - (sb-ext:inhibit-warnings 3))) + (optimize (speed 3) (space 2) (debug 0) (safety 0) + ;; Suppress the note about having to box up the return: + (sb-ext:inhibit-warnings 3))) (let ((sap (if (vectorp thing) (sb-sys:vector-sap thing) thing))) (if offset (sb-sys:sap+ sap offset) sap))) (defun bref (buffer index) (declare (type simple-stream-buffer buffer) - (type (integer 0 #.most-positive-fixnum) index)) + (type (integer 0 #.most-positive-fixnum) index)) (if (vectorp buffer) (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index) (sb-sys:sap-ref-8 buffer index))) (defun (setf bref) (octet buffer index) (declare (type (unsigned-byte 8) octet) - (type simple-stream-buffer buffer) - (type (integer 0 #.most-positive-fixnum) index)) + (type simple-stream-buffer buffer) + (type (integer 0 #.most-positive-fixnum) index)) (if (vectorp buffer) (setf (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index) octet) (setf (sb-sys:sap-ref-8 buffer index) octet))) (defun buffer-copy (src soff dst doff length) (declare (type simple-stream-buffer src dst) - (type fixnum soff doff length)) + (type fixnum soff doff length)) (sb-sys:without-gcing ;; is this necessary?? (sb-kernel:system-area-ub8-copy (buffer-sap src) soff (buffer-sap dst) doff @@ -61,10 +61,10 @@ (defun make-control-table (&rest inits) (let ((table (make-array 32 :initial-element nil))) (do* ((char (pop inits) (pop inits)) - (func (pop inits) (pop inits))) - ((null char)) + (func (pop inits) (pop inits))) + ((null char)) (when (< (char-code char) 32) - (setf (aref table (char-code char)) func))) + (setf (aref table (char-code char)) func))) table)) (defun std-newline-out-handler (stream character) @@ -78,7 +78,7 @@ (with-stream-class (simple-stream stream) (let ((col (sm charpos stream))) (when col - (setf (sm charpos stream) (1- (* 8 (1+ (floor col 8))))))) + (setf (sm charpos stream) (1- (* 8 (1+ (floor col 8))))))) nil)) (defun std-dc-newline-in-handler (stream character) @@ -94,7 +94,7 @@ (defvar *std-control-out-table* (make-control-table #\Newline #'std-newline-out-handler - #\Tab #'std-tab-out-handler)) + #\Tab #'std-tab-out-handler)) (defvar *default-external-format* :iso8859-1) @@ -102,8 +102,8 @@ (defvar *external-format-aliases* (make-hash-table)) (defstruct (external-format - (:conc-name ef-) - (:print-function %print-external-format) + (:conc-name ef-) + (:print-function %print-external-format) (:constructor make-external-format (name octets-to-char char-to-octets))) (name (sb-int:missing-arg) :type keyword :read-only t) @@ -117,36 +117,36 @@ (defmacro define-external-format (name octets-to-char char-to-octets) `(macrolet ((octets-to-char ((state input unput) &body body) - `(lambda (,state ,input ,unput) - (declare (type (function () (unsigned-byte 8)) ,input) - (type (function (sb-int:index) t) ,unput) - (ignorable ,state ,input ,unput) - (values character sb-int:index t)) - ,@body)) - (char-to-octets ((char state output) &body body) - `(lambda (,char ,state ,output) - (declare (type character ,char) - (type (function ((unsigned-byte 8)) t) ,output) - (ignorable state ,output) - (values t)) - ,@body))) + `(lambda (,state ,input ,unput) + (declare (type (function () (unsigned-byte 8)) ,input) + (type (function (sb-int:index) t) ,unput) + (ignorable ,state ,input ,unput) + (values character sb-int:index t)) + ,@body)) + (char-to-octets ((char state output) &body body) + `(lambda (,char ,state ,output) + (declare (type character ,char) + (type (function ((unsigned-byte 8)) t) ,output) + (ignorable state ,output) + (values t)) + ,@body))) (setf (gethash ,name *external-formats*) - (make-external-format ,name ,octets-to-char ,char-to-octets)))) + (make-external-format ,name ,octets-to-char ,char-to-octets)))) ;;; TODO: make this work (defun load-external-format-aliases () (let ((*package* (find-package "KEYWORD"))) (with-open-file (stm "ef:aliases" :if-does-not-exist nil) (when stm - (do ((alias (read stm nil stm) (read stm nil stm)) - (value (read stm nil stm) (read stm nil stm))) - ((or (eq alias stm) (eq value stm)) - (unless (eq alias stm) - (warn "External-format aliases file ends early."))) - (if (and (keywordp alias) (keywordp value)) - (setf (gethash alias *external-format-aliases*) value) - (warn "Bad entry in external-format aliases file: ~S => ~S." - alias value))))))) + (do ((alias (read stm nil stm) (read stm nil stm)) + (value (read stm nil stm) (read stm nil stm))) + ((or (eq alias stm) (eq value stm)) + (unless (eq alias stm) + (warn "External-format aliases file ends early."))) + (if (and (keywordp alias) (keywordp value)) + (setf (gethash alias *external-format-aliases*) value) + (warn "Bad entry in external-format aliases file: ~S => ~S." + alias value))))))) (defun find-external-format (name &optional (error-p t)) (when (external-format-p name) @@ -167,17 +167,17 @@ (load-external-format-aliases)) (do ((tmp (gethash name *external-format-aliases*) - (gethash tmp *external-format-aliases*)) + (gethash tmp *external-format-aliases*)) (cnt 0 (1+ cnt))) ((or (null tmp) (= cnt 50)) (unless (null tmp) - (error "External-format aliasing depth exceeded."))) + (error "External-format aliasing depth exceeded."))) (setq name tmp)) (or (gethash name *external-formats*) (and (let ((*package* (find-package "SB-SIMPLE-STREAMS"))) - (load (format nil "ef:~(~A~)" name) :if-does-not-exist nil)) - (gethash name *external-formats*)) + (load (format nil "ef:~(~A~)" name) :if-does-not-exist nil)) + (gethash name *external-formats*)) (if error-p (error "External format ~S not found." name) nil))) (define-condition void-external-format (error) @@ -206,58 +206,58 @@ (funcall output code) #+(or) (if (< code 256) - (funcall output code) - (funcall output (char-code #\?)))) + (funcall output code) + (funcall output (char-code #\?)))) state)) (defmacro octets-to-char (external-format state count input unput) (let ((tmp1 (gensym)) (tmp2 (gensym)) (tmp3 (gensym))) `(multiple-value-bind (,tmp1 ,tmp2 ,tmp3) - (funcall (ef-octets-to-char ,external-format) ,state ,input ,unput) + (funcall (ef-octets-to-char ,external-format) ,state ,input ,unput) (setf ,state ,tmp3 ,count ,tmp2) ,tmp1))) (defmacro char-to-octets (external-format char state output) `(progn (setf ,state (funcall (ef-char-to-octets ,external-format) - ,char ,state ,output)) + ,char ,state ,output)) nil)) (defun string-to-octets (string &key (start 0) end (external-format :default)) (declare (type string string) - (type sb-int:index start) - (type (or null sb-int:index) end)) + (type sb-int:index start) + (type (or null sb-int:index) end)) (let ((ef (find-external-format external-format)) - (buffer (make-array (length string) :element-type '(unsigned-byte 8))) - (ptr 0) - (state nil)) + (buffer (make-array (length string) :element-type '(unsigned-byte 8))) + (ptr 0) + (state nil)) (flet ((out (b) - (setf (aref buffer ptr) b) - (when (= (incf ptr) (length buffer)) - (setq buffer (adjust-array buffer (* 2 ptr)))))) + (setf (aref buffer ptr) b) + (when (= (incf ptr) (length buffer)) + (setq buffer (adjust-array buffer (* 2 ptr)))))) (dotimes (i (- (or end (length string)) start)) - (declare (type sb-int:index i)) - (char-to-octets ef (char string (+ start i)) state #'out)) + (declare (type sb-int:index i)) + (char-to-octets ef (char string (+ start i)) state #'out)) (sb-kernel:shrink-vector buffer ptr)))) (defun octets-to-string (octets &key (start 0) end (external-format :default)) (declare (type vector octets) - (type sb-int:index start) - (type (or null sb-int:index) end)) + (type sb-int:index start) + (type (or null sb-int:index) end)) (let ((ef (find-external-format external-format)) - (end (1- (or end (length octets)))) - (string (make-string (length octets))) - (ptr (1- start)) - (pos -1) - (count 0) - (state nil)) + (end (1- (or end (length octets)))) + (string (make-string (length octets))) + (ptr (1- start)) + (pos -1) + (count 0) + (state nil)) (flet ((input () - (aref octets (incf ptr))) - (unput (n) - (decf ptr n))) + (aref octets (incf ptr))) + (unput (n) + (decf ptr n))) (loop until (>= ptr end) - do (setf (schar string (incf pos)) - (octets-to-char ef state count #'input #'unput)))) + do (setf (schar string (incf pos)) + (octets-to-char ef state count #'input #'unput)))) (sb-kernel:shrink-vector string (1+ pos)))) (defun vector-elt-width (vector) @@ -287,7 +287,7 @@ #+big-endian (declare (ignore vector)) (case endian-swap (:network-order #+big-endian 0 - #+little-endian (1- (vector-elt-width vector))) + #+little-endian (1- (vector-elt-width vector))) (:byte-8 0) (:byte-16 1) (:byte-32 3) @@ -298,7 +298,7 @@ #+(or) (defun %read-vector (vector stream start end endian-swap blocking) (declare (type (kernel:simple-unboxed-array (*)) vector) - (type stream stream)) + (type stream stream)) ;; move code from read-vector ) @@ -309,320 +309,320 @@ (defun read-octets (stream buffer start end blocking) (declare (type simple-stream stream) - (type (or null simple-stream-buffer) buffer) - (type fixnum start) - (type (or null fixnum) end) + (type (or null simple-stream-buffer) buffer) + (type fixnum start) + (type (or null fixnum) end) (type blocking blocking) - (optimize (speed 3) (space 2) (safety 0) (debug 0))) + (optimize (speed 3) (space 2) (safety 0) (debug 0))) (with-stream-class (simple-stream stream) (let ((fd (sm input-handle stream)) - (end (or end (sm buf-len stream))) - (buffer (or buffer (sm buffer stream)))) + (end (or end (sm buf-len stream))) + (buffer (or buffer (sm buffer stream)))) (declare (fixnum end)) (typecase fd - (fixnum - (let ((flag (sb-sys:wait-until-fd-usable fd :input + (fixnum + (let ((flag (sb-sys:wait-until-fd-usable fd :input (if blocking nil 0)))) - (cond - ((and (not blocking) (= start end)) (if flag -3 0)) - ((and (not blocking) (not flag)) 0) - (t (block nil - (let ((count 0)) - (declare (type fixnum count)) - (tagbody - again - ;; Avoid CMUCL gengc write barrier - (do ((i start (+ i (the fixnum #.(sb-posix:getpagesize))))) - ((>= i end)) - (declare (type fixnum i)) - (setf (bref buffer i) 0)) - (setf (bref buffer (1- end)) 0) - (multiple-value-bind (bytes errno) - (sb-unix:unix-read fd (buffer-sap buffer start) + (cond + ((and (not blocking) (= start end)) (if flag -3 0)) + ((and (not blocking) (not flag)) 0) + (t (block nil + (let ((count 0)) + (declare (type fixnum count)) + (tagbody + again + ;; Avoid CMUCL gengc write barrier + (do ((i start (+ i (the fixnum #.(sb-posix:getpagesize))))) + ((>= i end)) + (declare (type fixnum i)) + (setf (bref buffer i) 0)) + (setf (bref buffer (1- end)) 0) + (multiple-value-bind (bytes errno) + (sb-unix:unix-read fd (buffer-sap buffer start) (the fixnum (- end start))) - (declare (type (or null fixnum) bytes) - (type (integer 0 100) errno)) - (when bytes - (incf count bytes) - (incf start bytes)) - (cond ((null bytes) - (format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno) - (cond ((= errno sb-unix:eintr) (go again)) - ((and blocking - (or (= errno ;;sb-unix:eagain + (declare (type (or null fixnum) bytes) + (type (integer 0 100) errno)) + (when bytes + (incf count bytes) + (incf start bytes)) + (cond ((null bytes) + (format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno) + (cond ((= errno sb-unix:eintr) (go again)) + ((and blocking + (or (= errno ;;sb-unix:eagain ;; TODO: move ;; eagain into ;; sb-unix 11) - (= errno sb-unix:ewouldblock))) - (sb-sys:wait-until-fd-usable fd :input nil) - (go again)) - (t (return (- -10 errno))))) - ((zerop count) (return -1)) - (t (return count))))))))))) - (t (%read-vector buffer fd start end :byte-8 - (if blocking :bnb nil))))))) + (= errno sb-unix:ewouldblock))) + (sb-sys:wait-until-fd-usable fd :input nil) + (go again)) + (t (return (- -10 errno))))) + ((zerop count) (return -1)) + (t (return count))))))))))) + (t (%read-vector buffer fd start end :byte-8 + (if blocking :bnb nil))))))) (defun write-octets (stream buffer start end blocking) (declare (type simple-stream stream) - (type simple-stream-buffer buffer) - (type fixnum start) - (type (or null fixnum) end)) + (type simple-stream-buffer buffer) + (type fixnum start) + (type (or null fixnum) end)) (with-stream-class (simple-stream stream) (when (sm handler stream) (do () - ((null (sm pending stream))) - (sb-sys:serve-all-events))) + ((null (sm pending stream))) + (sb-sys:serve-all-events))) (let ((fd (sm output-handle stream)) - (end (or end (length buffer)))) + (end (or end (length buffer)))) (typecase fd - (fixnum - (let ((flag (sb-sys:wait-until-fd-usable fd :output + (fixnum + (let ((flag (sb-sys:wait-until-fd-usable fd :output (if blocking nil 0)))) - (cond - ((and (not blocking) (= start end)) (if flag -3 0)) - ((and (not blocking) (not flag)) 0) - (t - (block nil - (let ((count 0)) - (tagbody again - (multiple-value-bind (bytes errno) - (sb-unix:unix-write fd (buffer-sap buffer) start - (- end start)) - (when bytes - (incf count bytes) - (incf start bytes)) - (cond ((null bytes) - (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%" errno) - (cond ((= errno sb-unix:eintr) (go again)) - ;; don't block for subsequent chars - (t (return (- -10 errno))))) - (t (return count))))))))))) - (t (error "implement me")))))) + (cond + ((and (not blocking) (= start end)) (if flag -3 0)) + ((and (not blocking) (not flag)) 0) + (t + (block nil + (let ((count 0)) + (tagbody again + (multiple-value-bind (bytes errno) + (sb-unix:unix-write fd (buffer-sap buffer) start + (- end start)) + (when bytes + (incf count bytes) + (incf start bytes)) + (cond ((null bytes) + (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%" errno) + (cond ((= errno sb-unix:eintr) (go again)) + ;; don't block for subsequent chars + (t (return (- -10 errno))))) + (t (return count))))))))))) + (t (error "implement me")))))) (defun do-some-output (stream) ;; Do some pending output; return T if completed, NIL if more to do (with-stream-class (simple-stream stream) (let ((fd (sm output-handle stream))) (loop - (let ((list (pop (sm pending stream)))) - (unless list - (sb-sys:remove-fd-handler (sm handler stream)) - (setf (sm handler stream) nil) - (return t)) - (let* ((buffer (first list)) - (start (second list)) - (end (third list)) - (len (- end start))) - (declare (type simple-stream-buffer buffer) - (type sb-int:index start end len)) - (tagbody again - (multiple-value-bind (bytes errno) - (sb-unix:unix-write fd (buffer-sap buffer) start len) - (cond ((null bytes) - (if (= errno sb-unix:eintr) - (go again) - (progn (push list (sm pending stream)) - (return nil)))) - ((< bytes len) - (setf (second list) (+ start bytes)) - (push list (sm pending stream)) - (return nil)) - ((= bytes len) - (free-buffer buffer))))))))))) + (let ((list (pop (sm pending stream)))) + (unless list + (sb-sys:remove-fd-handler (sm handler stream)) + (setf (sm handler stream) nil) + (return t)) + (let* ((buffer (first list)) + (start (second list)) + (end (third list)) + (len (- end start))) + (declare (type simple-stream-buffer buffer) + (type sb-int:index start end len)) + (tagbody again + (multiple-value-bind (bytes errno) + (sb-unix:unix-write fd (buffer-sap buffer) start len) + (cond ((null bytes) + (if (= errno sb-unix:eintr) + (go again) + (progn (push list (sm pending stream)) + (return nil)))) + ((< bytes len) + (setf (second list) (+ start bytes)) + (push list (sm pending stream)) + (return nil)) + ((= bytes len) + (free-buffer buffer))))))))))) (defun queue-write (stream buffer start end) ;; Queue a write; return T if buffer needs changing, NIL otherwise (declare (type simple-stream stream) - (type simple-stream-buffer buffer) - (type sb-int:index start end)) + (type simple-stream-buffer buffer) + (type sb-int:index start end)) (with-stream-class (simple-stream stream) (when (sm handler stream) (unless (do-some-output stream) - (let ((last (last (sm pending stream)))) - (setf (cdr last) (list (list buffer start end))) - (return-from queue-write t)))) + (let ((last (last (sm pending stream)))) + (setf (cdr last) (list (list buffer start end))) + (return-from queue-write t)))) (let ((bytes (write-octets stream buffer start end nil))) (unless (or (= bytes (- end start)) ; completed - (= bytes -3)) ; empty buffer; shouldn't happen - (setf (sm pending stream) (list (list buffer start end))) - (setf (sm handler stream) - (sb-sys:add-fd-handler (sm output-handle stream) :output + (= bytes -3)) ; empty buffer; shouldn't happen + (setf (sm pending stream) (list (list buffer start end))) + (setf (sm handler stream) + (sb-sys:add-fd-handler (sm output-handle stream) :output (lambda (fd) (declare (ignore fd)) (do-some-output stream)))) - t)))) + t)))) (defun %fd-open (pathname direction if-exists if-exists-given - if-does-not-exist if-does-not-exist-given) + if-does-not-exist if-does-not-exist-given) (declare (type pathname pathname) - (type (member :input :output :io :probe) direction) - (type (member :error :new-version :rename :rename-and-delete - :overwrite :append :supersede nil) if-exists) - (type (member :error :create nil) if-does-not-exist)) + (type (member :input :output :io :probe) direction) + (type (member :error :new-version :rename :rename-and-delete + :overwrite :append :supersede nil) if-exists) + (type (member :error :create nil) if-does-not-exist)) (multiple-value-bind (input output mask) (ecase direction - (:input (values t nil sb-unix:o_rdonly)) - (:output (values nil t sb-unix:o_wronly)) - (:io (values t t sb-unix:o_rdwr)) - (:probe (values t nil sb-unix:o_rdonly))) + (:input (values t nil sb-unix:o_rdonly)) + (:output (values nil t sb-unix:o_wronly)) + (:io (values t t sb-unix:o_rdwr)) + (:probe (values t nil sb-unix:o_rdonly))) (declare (type sb-int:index mask)) (let ((name (cond ((sb-int:unix-namestring pathname input)) - ((and input (eq if-does-not-exist :create)) - (sb-int:unix-namestring pathname nil)) - ((and (eq direction :io) (not if-does-not-exist-given)) - (sb-int:unix-namestring pathname nil))))) + ((and input (eq if-does-not-exist :create)) + (sb-int:unix-namestring pathname nil)) + ((and (eq direction :io) (not if-does-not-exist-given)) + (sb-int:unix-namestring pathname nil))))) ;; Process if-exists argument if we are doing any output. (cond (output - (unless if-exists-given - (setf if-exists - (if (eq (pathname-version pathname) :newest) - :new-version - :error))) - (case if-exists - ((:error nil :new-version) - (setf mask (logior mask sb-unix:o_excl))) - ((:rename :rename-and-delete) - (setf mask (logior mask sb-unix:o_creat))) - ((:supersede) - (setf mask (logior mask sb-unix:o_trunc))))) - (t - (setf if-exists nil))) ; :ignore-this-arg + (unless if-exists-given + (setf if-exists + (if (eq (pathname-version pathname) :newest) + :new-version + :error))) + (case if-exists + ((:error nil :new-version) + (setf mask (logior mask sb-unix:o_excl))) + ((:rename :rename-and-delete) + (setf mask (logior mask sb-unix:o_creat))) + ((:supersede) + (setf mask (logior mask sb-unix:o_trunc))))) + (t + (setf if-exists nil))) ; :ignore-this-arg (unless if-does-not-exist-given - (setf if-does-not-exist - (cond ((eq direction :input) :error) - ((and output - (member if-exists '(:overwrite :append))) - :error) - ((eq direction :probe) - nil) - (t - :create)))) + (setf if-does-not-exist + (cond ((eq direction :input) :error) + ((and output + (member if-exists '(:overwrite :append))) + :error) + ((eq direction :probe) + nil) + (t + :create)))) (if (eq if-does-not-exist :create) - (setf mask (logior mask sb-unix:o_creat))) + (setf mask (logior mask sb-unix:o_creat))) (let ((original (if (member if-exists '(:rename :rename-and-delete)) (sb-impl::pick-backup-name name) nil)) - (delete-original (eq if-exists :rename-and-delete)) - (mode #o666)) - (when original - ;; We are doing a :rename or :rename-and-delete. - ;; Determine if the file already exists, make sure the original - ;; file is not a directory and keep the mode - (let ((exists - (and name - (multiple-value-bind - (okay err/dev inode orig-mode) - (sb-unix:unix-stat name) - (declare (ignore inode) - (type (or sb-int:index null) orig-mode)) - (cond - (okay - (when (and output (= (logand orig-mode #o170000) - #o40000)) - (error 'sb-int:simple-file-error - :pathname pathname - :format-control - "Cannot open ~S for output: Is a directory." - :format-arguments (list name))) - (setf mode (logand orig-mode #o777)) - t) - ((eql err/dev sb-unix:enoent) - nil) - (t - (error 'sb-int:simple-file-error - :pathname pathname - :format-control "Cannot find ~S: ~A" - :format-arguments - (list name - (sb-int:strerror err/dev))))))))) - (unless (and exists - (rename-file name original)) - (setf original nil) - (setf delete-original nil) - ;; In order to use SUPERSEDE instead, we have - ;; to make sure unix:o_creat corresponds to - ;; if-does-not-exist. unix:o_creat was set - ;; before because of if-exists being :rename. - (unless (eq if-does-not-exist :create) - (setf mask (logior (logandc2 mask sb-unix:o_creat) - sb-unix:o_trunc))) - (setf if-exists :supersede)))) - - ;; Okay, now we can try the actual open. - (loop - (multiple-value-bind (fd errno) - (if name - (sb-unix:unix-open name mask mode) - (values nil sb-unix:enoent)) - (cond ((sb-int:fixnump fd) + (delete-original (eq if-exists :rename-and-delete)) + (mode #o666)) + (when original + ;; We are doing a :rename or :rename-and-delete. + ;; Determine if the file already exists, make sure the original + ;; file is not a directory and keep the mode + (let ((exists + (and name + (multiple-value-bind + (okay err/dev inode orig-mode) + (sb-unix:unix-stat name) + (declare (ignore inode) + (type (or sb-int:index null) orig-mode)) + (cond + (okay + (when (and output (= (logand orig-mode #o170000) + #o40000)) + (error 'sb-int:simple-file-error + :pathname pathname + :format-control + "Cannot open ~S for output: Is a directory." + :format-arguments (list name))) + (setf mode (logand orig-mode #o777)) + t) + ((eql err/dev sb-unix:enoent) + nil) + (t + (error 'sb-int:simple-file-error + :pathname pathname + :format-control "Cannot find ~S: ~A" + :format-arguments + (list name + (sb-int:strerror err/dev))))))))) + (unless (and exists + (rename-file name original)) + (setf original nil) + (setf delete-original nil) + ;; In order to use SUPERSEDE instead, we have + ;; to make sure unix:o_creat corresponds to + ;; if-does-not-exist. unix:o_creat was set + ;; before because of if-exists being :rename. + (unless (eq if-does-not-exist :create) + (setf mask (logior (logandc2 mask sb-unix:o_creat) + sb-unix:o_trunc))) + (setf if-exists :supersede)))) + + ;; Okay, now we can try the actual open. + (loop + (multiple-value-bind (fd errno) + (if name + (sb-unix:unix-open name mask mode) + (values nil sb-unix:enoent)) + (cond ((sb-int:fixnump fd) (when (eql if-exists :append) (sb-unix:unix-lseek fd 0 sb-unix:l_xtnd)) - (return (values fd name original delete-original))) - ((eql errno sb-unix:enoent) - (case if-does-not-exist - (:error - (cerror "Return NIL." - 'sb-int:simple-file-error - :pathname pathname - :format-control "Error opening ~S, ~A." - :format-arguments - (list pathname - (sb-int:strerror errno)))) - (:create + (return (values fd name original delete-original))) + ((eql errno sb-unix:enoent) + (case if-does-not-exist + (:error + (cerror "Return NIL." + 'sb-int:simple-file-error + :pathname pathname + :format-control "Error opening ~S, ~A." + :format-arguments + (list pathname + (sb-int:strerror errno)))) + (:create (cerror "Return NIL." - 'sb-int:simple-file-error - :pathname pathname - :format-control - "Error creating ~S, path does not exist." - :format-arguments (list pathname)))) - (return nil)) - ((eql errno sb-unix:eexist) - (unless (eq nil if-exists) - (cerror "Return NIL." - 'sb-int:simple-file-error - :pathname pathname - :format-control "Error opening ~S, ~A." - :format-arguments - (list pathname - (sb-int:strerror errno)))) - (return nil)) + 'sb-int:simple-file-error + :pathname pathname + :format-control + "Error creating ~S, path does not exist." + :format-arguments (list pathname)))) + (return nil)) + ((eql errno sb-unix:eexist) + (unless (eq nil if-exists) + (cerror "Return NIL." + 'sb-int:simple-file-error + :pathname pathname + :format-control "Error opening ~S, ~A." + :format-arguments + (list pathname + (sb-int:strerror errno)))) + (return nil)) #+nil ; FIXME: reinstate this; error reporting is nice. - ((eql errno sb-unix:eacces) - (cerror "Try again." - 'sb-int:simple-file-error - :pathname pathname - :format-control "Error opening ~S, ~A." - :format-arguments - (list pathname - (sb-int:strerror errno)))) - (t - (cerror "Return NIL." - 'sb-int:simple-file-error - :pathname pathname - :format-control "Error opening ~S, ~A." - :format-arguments - (list pathname - (sb-int:strerror errno))) - (return nil))))))))) + ((eql errno sb-unix:eacces) + (cerror "Try again." + 'sb-int:simple-file-error + :pathname pathname + :format-control "Error opening ~S, ~A." + :format-arguments + (list pathname + (sb-int:strerror errno)))) + (t + (cerror "Return NIL." + 'sb-int:simple-file-error + :pathname pathname + :format-control "Error opening ~S, ~A." + :format-arguments + (list pathname + (sb-int:strerror errno))) + (return nil))))))))) (defun open-fd-stream (pathname &key (direction :input) - (element-type 'base-char) - (if-exists nil if-exists-given) - (if-does-not-exist nil if-does-not-exist-given) - (external-format :default)) + (element-type 'base-char) + (if-exists nil if-exists-given) + (if-does-not-exist nil if-does-not-exist-given) + (external-format :default)) (declare (type (or pathname string stream) pathname) - (type (member :input :output :io :probe) direction) - (type (member :error :new-version :rename :rename-and-delete - :overwrite :append :supersede nil) if-exists) - (type (member :error :create nil) if-does-not-exist) - (ignore external-format)) + (type (member :input :output :io :probe) direction) + (type (member :error :new-version :rename :rename-and-delete + :overwrite :append :supersede nil) if-exists) + (type (member :error :create nil) if-does-not-exist) + (ignore external-format)) (let ((filespec (merge-pathnames pathname))) (multiple-value-bind (fd namestring original delete-original) (%fd-open filespec direction if-exists if-exists-given @@ -638,7 +638,7 @@ :original original :delete-original delete-original :pathname pathname - :dual-channel-p nil + :dual-channel-p nil :input-buffer-p t :auto-close t)) (:probe @@ -654,7 +654,7 @@ ;; sat: Hooks to parse URIs etc apparently go here (defstruct (filespec-parser - (:constructor make-filespec-parser (name priority function))) + (:constructor make-filespec-parser (name priority function))) name priority function) @@ -664,24 +664,24 @@ (defun add-filespec (name priority function) (let ((filespec (make-filespec-parser name priority function))) (setf *filespec-parsers* - (stable-sort (cons filespec (delete name *filespec-parsers* - :key #'filespec-parser-name)) - #'> - :key #'filespec-parser-priority))) + (stable-sort (cons filespec (delete name *filespec-parsers* + :key #'filespec-parser-name)) + #'> + :key #'filespec-parser-priority))) t) (defmacro define-filespec (name lambda-list &body body) (let ((truename (if (consp name) (first name) name)) - (priority (if (consp name) (second name) 0))) + (priority (if (consp name) (second name) 0))) `(add-filespec ',truename ,priority (lambda ,lambda-list - (block ,truename - ,@body))))) + (block ,truename + ,@body))))) (defun parse-filespec (string &optional (errorp t)) (dolist (i *filespec-parsers* (when errorp - (error "~S not recognised." string))) + (error "~S not recognised." string))) (let ((result (ignore-errors - (funcall (filespec-parser-function i) string)))) + (funcall (filespec-parser-function i) string)))) (when result (return result))))) (define-filespec pathname (string) diff --git a/contrib/sb-simple-streams/iodefs.lisp b/contrib/sb-simple-streams/iodefs.lisp index 1cbb1a8..daff1a9 100644 --- a/contrib/sb-simple-streams/iodefs.lisp +++ b/contrib/sb-simple-streams/iodefs.lisp @@ -23,7 +23,7 @@ (sb-int:defconstant-eqx +flag-bits+ '(:simple ; instance is valid :input :output ; direction - :dual :string ; type of stream + :dual :string ; type of stream :eof ; latched EOF :dirty ; output buffer needs write :interactive) ; interactive stream @@ -32,17 +32,17 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defun %flags (flags) (loop for flag in flags - as pos = (position flag +flag-bits+) - when (eq flag :gray) do - (error "Gray streams not supported.") - if pos - sum (ash 1 pos) into bits - else - collect flag into unused + as pos = (position flag +flag-bits+) + when (eq flag :gray) do + (error "Gray streams not supported.") + if pos + sum (ash 1 pos) into bits + else + collect flag into unused finally (when unused - (warn "Invalid stream instance flag~P: ~{~S~^, ~}" - (length unused) unused)) - (return bits)))) + (warn "Invalid stream instance flag~P: ~{~S~^, ~}" + (length unused) unused)) + (return bits)))) ;;; Setup an environment where sm, funcall-stm-handler and ;;; funcall-stm-handler-2 are valid and efficient for a stream of type @@ -55,36 +55,36 @@ (defmacro with-stream-class ((class-name &optional stream) &body body) (if stream (let ((stm (gensym "STREAM")) - (slt (gensym "SV"))) + (slt (gensym "SV"))) `(let* ((,stm ,stream) - (,slt (sb-kernel:%instance-ref ,stm 1))) - (declare (type ,class-name ,stm) - (type simple-vector ,slt) - (ignorable ,slt)) - (macrolet ((sm (slot-name stream) - (declare (ignore stream)) - #-count-sm - `(slot-value ,',stm ',slot-name) - #+count-sm - `(%sm ',slot-name ,',stm)) - (add-stream-instance-flags (stream &rest flags) - (declare (ignore stream)) - `(setf (sm %flags ,',stm) (logior (the fixnum (sm %flags ,',stm)) - ,(%flags flags)))) - (remove-stream-instance-flags (stream &rest flags) - (declare (ignore stream)) - `(setf (sm %flags ,',stm) (logandc2 (the fixnum (sm %flags ,',stm)) - ,(%flags flags)))) - (any-stream-instance-flags (stream &rest flags) - (declare (ignore stream)) - `(not (zerop (logand (the fixnum (sm %flags ,',stm)) - ,(%flags flags)))))) - ,@body))) + (,slt (sb-kernel:%instance-ref ,stm 1))) + (declare (type ,class-name ,stm) + (type simple-vector ,slt) + (ignorable ,slt)) + (macrolet ((sm (slot-name stream) + (declare (ignore stream)) + #-count-sm + `(slot-value ,',stm ',slot-name) + #+count-sm + `(%sm ',slot-name ,',stm)) + (add-stream-instance-flags (stream &rest flags) + (declare (ignore stream)) + `(setf (sm %flags ,',stm) (logior (the fixnum (sm %flags ,',stm)) + ,(%flags flags)))) + (remove-stream-instance-flags (stream &rest flags) + (declare (ignore stream)) + `(setf (sm %flags ,',stm) (logandc2 (the fixnum (sm %flags ,',stm)) + ,(%flags flags)))) + (any-stream-instance-flags (stream &rest flags) + (declare (ignore stream)) + `(not (zerop (logand (the fixnum (sm %flags ,',stm)) + ,(%flags flags)))))) + ,@body))) `(macrolet ((sm (slot-name stream) - #-count-sm - `(slot-value ,stream ',slot-name) - #+count-sm - `(%sm ',slot-name ,stream))) + #-count-sm + `(slot-value ,stream ',slot-name) + #+count-sm + `(%sm ',slot-name ,stream))) ,@body))) (defmacro sm (slot-name stream) @@ -109,43 +109,43 @@ (let ((s (gensym "STREAM"))) `(let ((,s ,stream)) (with-stream-class (simple-stream ,s) - (add-stream-instance-flags ,s ,@flags))))) + (add-stream-instance-flags ,s ,@flags))))) (defmacro remove-stream-instance-flags (stream &rest flags) "Clear the given Flags in Stream." (let ((s (gensym "STREAM"))) `(let ((,s ,stream)) (with-stream-class (simple-stream ,s) - (remove-stream-instance-flags ,s ,@flags))))) + (remove-stream-instance-flags ,s ,@flags))))) (defmacro any-stream-instance-flags (stream &rest flags) "Determine whether any one of the Flags is set in Stream." (let ((s (gensym "STREAM"))) `(let ((,s ,stream)) (with-stream-class (simple-stream ,s) - (any-stream-instance-flags ,s ,@flags))))) + (any-stream-instance-flags ,s ,@flags))))) (defmacro simple-stream-dispatch (stream single dual string) (let ((s (gensym "STREAM"))) `(let ((,s ,stream)) (with-stream-class (simple-stream ,s) - (let ((%flags (sm %flags ,s))) - (cond ((zerop (logand %flags ,(%flags '(:string :dual)))) - ,single) - ((zerop (logand %flags ,(%flags '(:string)))) - ,dual) - (t - ,string))))))) + (let ((%flags (sm %flags ,s))) + (cond ((zerop (logand %flags ,(%flags '(:string :dual)))) + ,single) + ((zerop (logand %flags ,(%flags '(:string)))) + ,dual) + (t + ,string))))))) (defmacro simple-stream-dispatch-2 (stream non-string string) (let ((s (gensym "STREAM"))) `(let ((,s ,stream)) (with-stream-class (simple-stream ,s) - (let ((%flags (sm %flags ,s))) - (cond ((zerop (logand %flags ,(%flags '(:string)))) - ,non-string) - (t - ,string))))))) + (let ((%flags (sm %flags ,s))) + (cond ((zerop (logand %flags ,(%flags '(:string)))) + ,non-string) + (t + ,string))))))) ;;;; The following two forms are for Franz source-compatibility, @@ -155,11 +155,11 @@ (defpackage "EXCL" (:use "SB-SIMPLE-STREAMS") (:import-from "SB-SIMPLE-STREAMS" - "BUFFER" "BUFFPOS" "BUFFER-PTR" - "OUT-BUFFER" "MAX-OUT-POS" - "INPUT-HANDLE" "OUTPUT-HANDLE" - "MELDED-STREAM" - "J-READ-CHARS")) + "BUFFER" "BUFFPOS" "BUFFER-PTR" + "OUT-BUFFER" "MAX-OUT-POS" + "INPUT-HANDLE" "OUTPUT-HANDLE" + "MELDED-STREAM" + "J-READ-CHARS")) #+nil (provide :iodefs) diff --git a/contrib/sb-simple-streams/null.lisp b/contrib/sb-simple-streams/null.lisp index a820e96..4747189 100644 --- a/contrib/sb-simple-streams/null.lisp +++ b/contrib/sb-simple-streams/null.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. -;;; +;;; ;;; Sbcl port by Rudi Schlatte. @@ -52,22 +52,22 @@ ;;(install-single-channel-character-strategy ;; stream (getf options :external-format :default) nil) (setf (sm j-read-char stream) #'null-read-char - (sm j-read-chars stream) #'null-read-chars - (sm j-unread-char stream) #'null-unread-char - (sm j-write-char stream) #'null-write-char - (sm j-write-chars stream) #'null-write-chars - (sm j-listen stream) #'null-listen)) + (sm j-read-chars stream) #'null-read-chars + (sm j-unread-char stream) #'null-unread-char + (sm j-write-char stream) #'null-write-char + (sm j-write-chars stream) #'null-write-chars + (sm j-listen stream) #'null-listen)) stream) (defmethod device-buffer-length ((stream null-simple-stream)) 256) (defmethod device-read ((stream null-simple-stream) buffer - start end blocking) + start end blocking) (declare (ignore buffer start end blocking)) -1) (defmethod device-write ((stream null-simple-stream) buffer - start end blocking) + start end blocking) (declare (ignore buffer blocking)) (- end start)) diff --git a/contrib/sb-simple-streams/simple-stream-tests.lisp b/contrib/sb-simple-streams/simple-stream-tests.lisp index a845bd5..0577d03 100644 --- a/contrib/sb-simple-streams/simple-stream-tests.lisp +++ b/contrib/sb-simple-streams/simple-stream-tests.lisp @@ -118,11 +118,11 @@ (deftest write-read-inet (handler-case (with-open-stream (s (make-instance 'socket-simple-stream - :remote-host #(127 0 0 1) - :remote-port 7 + :remote-host #(127 0 0 1) + :remote-port 7 :direction :io)) - (string= (prog1 (write-line "Got it!" s) (finish-output s)) - (read-line s))) + (string= (prog1 (write-line "Got it!" s) (finish-output s)) + (read-line s))) ;; Fail gracefully if echo isn't activated on the system (sb-bsd-sockets::connection-refused-error () t)) t) @@ -428,7 +428,7 @@ Nothing to see here, move along.") T) (deftest line-length-dc-1 - ;; does LINE-LENGTH support simple streams? + ;; does LINE-LENGTH support simple streams? (with-dc-test-stream (s) (eql (sb-simple-streams:line-length s) (sb-kernel:line-length s))) diff --git a/contrib/sb-simple-streams/socket.lisp b/contrib/sb-simple-streams/socket.lisp index b39fe67..120f375 100644 --- a/contrib/sb-simple-streams/socket.lisp +++ b/contrib/sb-simple-streams/socket.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. -;;; +;;; ;;; Sbcl port by Rudi Schlatte. @@ -28,7 +28,7 @@ ((not (any-stream-instance-flags object :input :output)) (princ "Closed " stream))) (format stream "~:(~A~)" - (type-of object)) + (type-of object)) (when (any-stream-instance-flags object :input :output) (multiple-value-bind (host port) (sb-bsd-sockets:socket-peername (sm socket object)) @@ -47,41 +47,41 @@ 'socket-simple-stream)) (with-stream-class (socket-simple-stream stream) (ecase (getf options :direction :input) - (:input (add-stream-instance-flags stream :input)) - (:output (add-stream-instance-flags stream :output)) - (:io (add-stream-instance-flags stream :input :output))) + (:input (add-stream-instance-flags stream :input)) + (:output (add-stream-instance-flags stream :output)) + (:io (add-stream-instance-flags stream :input :output))) (setf (sm socket stream) socket) (sb-bsd-sockets:socket-connect socket remote-host remote-port) (let ((fd (sb-bsd-sockets:socket-file-descriptor socket))) (when fd - (add-stream-instance-flags stream :dual :simple) - (when (any-stream-instance-flags stream :input) - (setf (sm input-handle stream) fd) - (unless (sm buffer stream) - (let ((length (device-buffer-length stream))) - (setf (sm buffer stream) (allocate-buffer length) - (sm buffpos stream) 0 - (sm buffer-ptr stream) 0 - (sm buf-len stream) length)))) - (when (any-stream-instance-flags stream :output) - (setf (sm output-handle stream) fd) - (unless (sm out-buffer stream) - (let ((length (device-buffer-length stream))) - (setf (sm out-buffer stream) (allocate-buffer length) - (sm outpos stream) 0 - (sm max-out-pos stream) length))) - (setf (sm control-out stream) *std-control-out-table*)) + (add-stream-instance-flags stream :dual :simple) + (when (any-stream-instance-flags stream :input) + (setf (sm input-handle stream) fd) + (unless (sm buffer stream) + (let ((length (device-buffer-length stream))) + (setf (sm buffer stream) (allocate-buffer length) + (sm buffpos stream) 0 + (sm buffer-ptr stream) 0 + (sm buf-len stream) length)))) + (when (any-stream-instance-flags stream :output) + (setf (sm output-handle stream) fd) + (unless (sm out-buffer stream) + (let ((length (device-buffer-length stream))) + (setf (sm out-buffer stream) (allocate-buffer length) + (sm outpos stream) 0 + (sm max-out-pos stream) length))) + (setf (sm control-out stream) *std-control-out-table*)) (sb-ext:cancel-finalization socket) (sb-ext:finalize stream (lambda () (sb-unix:unix-close fd) (format *debug-io* "~&;;; ** closed socket (fd ~D)~%" fd))) - ;; this should be done with (setf stream-external-format) - (let ((efmt (getf options :external-format :default))) - (compose-encapsulating-streams stream efmt) - (install-dual-channel-character-strategy (melding-stream stream) - efmt)) + ;; this should be done with (setf stream-external-format) + (let ((efmt (getf options :external-format :default))) + (compose-encapsulating-streams stream efmt) + (install-dual-channel-character-strategy (melding-stream stream) + efmt)) stream))))) (defmethod device-close ((stream socket-simple-stream) abort) diff --git a/contrib/sb-simple-streams/strategy.lisp b/contrib/sb-simple-streams/strategy.lisp index b080292..38c4e93 100644 --- a/contrib/sb-simple-streams/strategy.lisp +++ b/contrib/sb-simple-streams/strategy.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. -;;; +;;; ;;; Sbcl port by Rudi Schlatte. @@ -21,7 +21,7 @@ (with-stream-class (simple-stream stream) (let* ((unread (sm last-char-read-size stream)) (buffer (sm buffer stream)) - (bufptr (sm buffer-ptr stream))) + (bufptr (sm buffer-ptr stream))) (unless (or (zerop unread) (zerop bufptr)) (buffer-copy buffer (- bufptr unread) buffer 0 unread)) (let ((bytes (device-read stream nil unread nil blocking))) @@ -105,70 +105,70 @@ (defun sc-listen-ef (stream) (with-stream-class (simple-stream stream) (let ((lcrs (sm last-char-read-size stream)) - (buffer (sm buffer stream)) - (buffpos (sm buffpos stream)) - (cnt 0) - (char nil)) + (buffer (sm buffer stream)) + (buffpos (sm buffpos stream)) + (cnt 0) + (char nil)) (unwind-protect - (flet ((input () - (when (>= buffpos (sm buffer-ptr stream)) - (let ((bytes (refill-buffer stream nil))) - (cond ((= bytes 0) - (return-from sc-listen-ef nil)) - ((< bytes 0) - (return-from sc-listen-ef t)) - (t - (setf buffpos (sm buffpos stream)))))) - (incf (sm last-char-read-size stream)) - (prog1 (bref buffer buffpos) - (incf buffpos))) - (unput (n) - (decf buffpos n))) - (setq char (octets-to-char (sm external-format stream) - (sm oc-state stream) - cnt #'input #'unput)) - (characterp char)) - (setf (sm last-char-read-size stream) lcrs))))) + (flet ((input () + (when (>= buffpos (sm buffer-ptr stream)) + (let ((bytes (refill-buffer stream nil))) + (cond ((= bytes 0) + (return-from sc-listen-ef nil)) + ((< bytes 0) + (return-from sc-listen-ef t)) + (t + (setf buffpos (sm buffpos stream)))))) + (incf (sm last-char-read-size stream)) + (prog1 (bref buffer buffpos) + (incf buffpos))) + (unput (n) + (decf buffpos n))) + (setq char (octets-to-char (sm external-format stream) + (sm oc-state stream) + cnt #'input #'unput)) + (characterp char)) + (setf (sm last-char-read-size stream) lcrs))))) (declaim (ftype j-read-char-fn sc-read-char-ef)) (defun sc-read-char-ef (stream eof-error-p eof-value blocking) #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|# (with-stream-class (simple-stream stream) (let* ((buffer (sm buffer stream)) - (buffpos (sm buffpos stream)) - (ctrl (sm control-in stream)) - (ef (sm external-format stream)) - (state (sm oc-state stream))) + (buffpos (sm buffpos stream)) + (ctrl (sm control-in stream)) + (ef (sm external-format stream)) + (state (sm oc-state stream))) (flet ((input () - (when (>= buffpos (sm buffer-ptr stream)) + (when (>= buffpos (sm buffer-ptr stream)) (when (and (not (any-stream-instance-flags stream :dual :string)) (sc-dirty-p stream)) (flush-buffer stream t)) - (let ((bytes (refill-buffer stream blocking))) - (cond ((= bytes 0) - (return-from sc-read-char-ef nil)) - ((minusp bytes) - (return-from sc-read-char-ef - (sb-impl::eof-or-lose stream eof-error-p eof-value))) - (t - (setf buffpos (sm buffpos stream)))))) - (incf (sm last-char-read-size stream)) - (prog1 (bref buffer buffpos) - (incf buffpos))) - (unput (n) - (decf buffpos n))) - (let* ((cnt 0) - (char (octets-to-char ef state cnt #'input #'unput)) - (code (char-code char))) - (setf (sm buffpos stream) buffpos - (sm last-char-read-size stream) cnt - (sm oc-state stream) state) - (when (and (< code 32) ctrl (svref ctrl code)) - (setq char (funcall (the (or symbol function) (svref ctrl code)) - stream char))) - (if (null char) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))))) + (let ((bytes (refill-buffer stream blocking))) + (cond ((= bytes 0) + (return-from sc-read-char-ef nil)) + ((minusp bytes) + (return-from sc-read-char-ef + (sb-impl::eof-or-lose stream eof-error-p eof-value))) + (t + (setf buffpos (sm buffpos stream)))))) + (incf (sm last-char-read-size stream)) + (prog1 (bref buffer buffpos) + (incf buffpos))) + (unput (n) + (decf buffpos n))) + (let* ((cnt 0) + (char (octets-to-char ef state cnt #'input #'unput)) + (code (char-code char))) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) cnt + (sm oc-state stream) state) + (when (and (< code 32) ctrl (svref ctrl code)) + (setq char (funcall (the (or symbol function) (svref ctrl code)) + stream char))) + (if (null char) + (sb-impl::eof-or-lose stream eof-error-p eof-value) + char)))))) (declaim (ftype j-read-char-fn sc-read-char-ef-mapped)) @@ -177,31 +177,31 @@ (declare (ignore blocking)) (with-stream-class (simple-stream stream) (let* ((buffer (sm buffer stream)) - (buffpos (sm buffpos stream)) - (ctrl (sm control-in stream)) - (ef (sm external-format stream)) - (state (sm oc-state stream))) + (buffpos (sm buffpos stream)) + (ctrl (sm control-in stream)) + (ef (sm external-format stream)) + (state (sm oc-state stream))) (flet ((input () - (when (>= buffpos (sm buffer-ptr stream)) - (return-from sc-read-char-ef-mapped + (when (>= buffpos (sm buffer-ptr stream)) + (return-from sc-read-char-ef-mapped (sb-impl::eof-or-lose stream eof-error-p eof-value))) - (incf (sm last-char-read-size stream)) - (prog1 (bref buffer buffpos) - (incf buffpos))) - (unput (n) - (decf buffpos n))) - (let* ((cnt 0) - (char (octets-to-char ef state cnt #'input #'unput)) - (code (char-code char))) - (setf (sm buffpos stream) buffpos - (sm last-char-read-size stream) cnt - (sm oc-state stream) state) - (when (and (< code 32) ctrl (svref ctrl code)) - (setq char (funcall (the (or symbol function) (svref ctrl code)) - stream char))) - (if (null char) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))))) + (incf (sm last-char-read-size stream)) + (prog1 (bref buffer buffpos) + (incf buffpos))) + (unput (n) + (decf buffpos n))) + (let* ((cnt 0) + (char (octets-to-char ef state cnt #'input #'unput)) + (code (char-code char))) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) cnt + (sm oc-state stream) state) + (when (and (< code 32) ctrl (svref ctrl code)) + (setq char (funcall (the (or symbol function) (svref ctrl code)) + stream char))) + (if (null char) + (sb-impl::eof-or-lose stream eof-error-p eof-value) + char)))))) (declaim (ftype j-read-chars-fn sc-read-chars-ef)) @@ -216,7 +216,7 @@ (type (or null character) search) (type fixnum start end) (type boolean blocking) - #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#) + #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#) (with-stream-class (simple-stream stream) (when (and (not (any-stream-instance-flags stream :dual :string)) (sc-dirty-p stream)) @@ -224,56 +224,56 @@ (do ((buffer (sm buffer stream)) (buffpos (sm buffpos stream)) (buffer-ptr (sm buffer-ptr stream)) - (lcrs 0) - (ctrl (sm control-in stream)) - (ef (sm external-format stream)) - (state (sm oc-state stream)) + (lcrs 0) + (ctrl (sm control-in stream)) + (ef (sm external-format stream)) + (state (sm oc-state stream)) (posn start (1+ posn)) (count 0 (1+ count))) ((>= posn end) - (setf (sm buffpos stream) buffpos - (sm last-char-read-size stream) lcrs - (sm oc-state stream) state) - (values count nil)) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs + (sm oc-state stream) state) + (values count nil)) (declare (type sb-int:index buffpos buffer-ptr posn count)) (flet ((input () - (when (>= buffpos buffer-ptr) - (setf (sm last-char-read-size stream) lcrs) - (let ((bytes (refill-buffer stream blocking))) - (declare (type fixnum bytes)) - (setf buffpos (sm buffpos stream) - buffer-ptr (sm buffer-ptr stream)) - (unless (plusp bytes) - (setf (sm buffpos stream) buffpos - (sm last-char-read-size stream) lcrs - (sm oc-state stream) state) - (if (zerop bytes) - (return (values count nil)) - (return (values count :eof)))))) - (prog1 (bref buffer buffpos) - (incf buffpos) - (incf lcrs))) - (unput (n) - (decf buffpos n))) - (let* ((cnt 0) - (char (octets-to-char ef state cnt #'input #'unput)) - (code (char-code char))) - (setq lcrs cnt) - (when (and (< code 32) ctrl (svref ctrl code)) - (setq char (funcall (the (or symbol function) (svref ctrl code)) - stream char))) - (cond ((null char) - (setf (sm buffpos stream) buffpos - (sm last-char-read-size stream) lcrs - (sm oc-state stream) state) - (return (values count :eof))) - ((and search (char= char search)) - (setf (sm buffpos stream) buffpos - (sm last-char-read-size stream) lcrs - (sm oc-state stream) state) - (return (values count t))) - (t - (setf (char string posn) char)))))))) + (when (>= buffpos buffer-ptr) + (setf (sm last-char-read-size stream) lcrs) + (let ((bytes (refill-buffer stream blocking))) + (declare (type fixnum bytes)) + (setf buffpos (sm buffpos stream) + buffer-ptr (sm buffer-ptr stream)) + (unless (plusp bytes) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs + (sm oc-state stream) state) + (if (zerop bytes) + (return (values count nil)) + (return (values count :eof)))))) + (prog1 (bref buffer buffpos) + (incf buffpos) + (incf lcrs))) + (unput (n) + (decf buffpos n))) + (let* ((cnt 0) + (char (octets-to-char ef state cnt #'input #'unput)) + (code (char-code char))) + (setq lcrs cnt) + (when (and (< code 32) ctrl (svref ctrl code)) + (setq char (funcall (the (or symbol function) (svref ctrl code)) + stream char))) + (cond ((null char) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs + (sm oc-state stream) state) + (return (values count :eof))) + ((and search (char= char search)) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs + (sm oc-state stream) state) + (return (values count t))) + (t + (setf (char string posn) char)))))))) (declaim (ftype j-read-chars-fn sc-read-chars-ef-mapped)) @@ -289,51 +289,51 @@ (type fixnum start end) (type boolean blocking) (ignore blocking) - #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#) + #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#) (with-stream-class (simple-stream stream) ;; if stream is single-channel and mode == 3, flush buffer (if dirty) (do ((buffer (sm buffer stream)) (buffpos (sm buffpos stream)) (buffer-ptr (sm buffer-ptr stream)) - (lcrs 0) - (ctrl (sm control-in stream)) - (ef (sm external-format stream)) - (state (sm oc-state stream)) + (lcrs 0) + (ctrl (sm control-in stream)) + (ef (sm external-format stream)) + (state (sm oc-state stream)) (posn start (1+ posn)) (count 0 (1+ count))) ((>= posn end) - (setf (sm buffpos stream) buffpos - (sm last-char-read-size stream) lcrs - (sm oc-state stream) state) - (values count nil)) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs + (sm oc-state stream) state) + (values count nil)) (declare (type sb-int:index buffpos buffer-ptr posn count)) (flet ((input () - (when (>= buffpos buffer-ptr) + (when (>= buffpos buffer-ptr) (return (values count :eof))) - (prog1 (bref buffer buffpos) - (incf buffpos) - (incf lcrs))) - (unput (n) - (decf buffpos n))) - (let* ((cnt 0) - (char (octets-to-char ef state cnt #'input #'unput)) - (code (char-code char))) - (setq lcrs cnt) - (when (and (< code 32) ctrl (svref ctrl code)) - (setq char (funcall (the (or symbol function) (svref ctrl code)) - stream char))) - (cond ((null char) - (setf (sm buffpos stream) buffpos - (sm last-char-read-size stream) lcrs - (sm oc-state stream) state) - (return (values count :eof))) - ((and search (char= char search)) - (setf (sm buffpos stream) buffpos - (sm last-char-read-size stream) lcrs - (sm oc-state stream) state) - (return (values count t))) - (t - (setf (char string posn) char)))))))) + (prog1 (bref buffer buffpos) + (incf buffpos) + (incf lcrs))) + (unput (n) + (decf buffpos n))) + (let* ((cnt 0) + (char (octets-to-char ef state cnt #'input #'unput)) + (code (char-code char))) + (setq lcrs cnt) + (when (and (< code 32) ctrl (svref ctrl code)) + (setq char (funcall (the (or symbol function) (svref ctrl code)) + stream char))) + (cond ((null char) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs + (sm oc-state stream) state) + (return (values count :eof))) + ((and search (char= char search)) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs + (sm oc-state stream) state) + (return (values count t))) + (t + (setf (char string posn) char)))))))) (declaim (ftype j-unread-char-fn sc-unread-char-ef)) @@ -350,25 +350,25 @@ (when character (with-stream-class (single-channel-simple-stream stream) (let ((buffer (sm buffer stream)) - (buffpos (sm buffpos stream)) - (buf-len (sm buf-len stream)) - (code (char-code character)) - (ctrl (sm control-out stream))) - (when (and (< code 32) ctrl (svref ctrl code) - (funcall (the (or symbol function) (svref ctrl code)) - stream character)) - (return-from sc-write-char-ef character)) - (flet ((output (byte) - (when (>= buffpos buf-len) - (setf (sm buffpos stream) buffpos) - (setq buffpos (flush-buffer stream t))) - (setf (bref buffer buffpos) byte) - (incf buffpos))) - (char-to-octets (sm external-format stream) character - (sm co-state stream) #'output)) - (setf (sm buffpos stream) buffpos) + (buffpos (sm buffpos stream)) + (buf-len (sm buf-len stream)) + (code (char-code character)) + (ctrl (sm control-out stream))) + (when (and (< code 32) ctrl (svref ctrl code) + (funcall (the (or symbol function) (svref ctrl code)) + stream character)) + (return-from sc-write-char-ef character)) + (flet ((output (byte) + (when (>= buffpos buf-len) + (setf (sm buffpos stream) buffpos) + (setq buffpos (flush-buffer stream t))) + (setf (bref buffer buffpos) byte) + (incf buffpos))) + (char-to-octets (sm external-format stream) character + (sm co-state stream) #'output)) + (setf (sm buffpos stream) buffpos) (sc-set-dirty stream) - (if (sm charpos stream) (incf (sm charpos stream)))))) + (if (sm charpos stream) (incf (sm charpos stream)))))) character) (declaim (ftype j-write-chars-fn sc-write-chars-ef)) @@ -377,7 +377,7 @@ (do ((buffer (sm buffer stream)) (buffpos (sm buffpos stream)) (buf-len (sm buf-len stream)) - (ef (sm external-format stream)) + (ef (sm external-format stream)) (ctrl (sm control-out stream)) (posn start (1+ posn)) (count 0 (1+ count))) @@ -388,15 +388,15 @@ (unless (and (< code 32) ctrl (svref ctrl code) (funcall (the (or symbol function) (svref ctrl code)) stream char)) - (flet ((output (byte) - (when (>= buffpos buf-len) - (setf (sm buffpos stream) buffpos) - (setq buffpos (flush-buffer stream t))) - (setf (bref buffer buffpos) byte) - (incf buffpos))) - (char-to-octets ef char (sm co-state stream) #'output)) - (setf (sm buffpos stream) buffpos) - (if (sm charpos stream) (incf (sm charpos stream))) + (flet ((output (byte) + (when (>= buffpos buf-len) + (setf (sm buffpos stream) buffpos) + (setq buffpos (flush-buffer stream t))) + (setf (bref buffer buffpos) byte) + (incf buffpos))) + (char-to-octets ef char (sm co-state stream) #'output)) + (setf (sm buffpos stream) buffpos) + (if (sm charpos stream) (incf (sm charpos stream))) (sc-set-dirty stream)))))) @@ -409,24 +409,24 @@ (when character (with-stream-class (dual-channel-simple-stream stream) (let ((out-buffer (sm out-buffer stream)) - (outpos (sm outpos stream)) - (max-out-pos (sm max-out-pos stream)) - (code (char-code character)) - (ctrl (sm control-out stream))) - (when (and (< code 32) ctrl (svref ctrl code) - (funcall (the (or symbol function) (svref ctrl code)) - stream character)) - (return-from dc-write-char-ef character)) - (flet ((output (byte) - (when (>= outpos max-out-pos) - (setf (sm outpos stream) outpos) - (setq outpos (flush-out-buffer stream t))) - (setf (bref out-buffer outpos) byte) - (incf outpos))) - (char-to-octets (sm external-format stream) character - (sm co-state stream) #'output)) - (setf (sm outpos stream) outpos) - (if (sm charpos stream) (incf (sm charpos stream)))))) + (outpos (sm outpos stream)) + (max-out-pos (sm max-out-pos stream)) + (code (char-code character)) + (ctrl (sm control-out stream))) + (when (and (< code 32) ctrl (svref ctrl code) + (funcall (the (or symbol function) (svref ctrl code)) + stream character)) + (return-from dc-write-char-ef character)) + (flet ((output (byte) + (when (>= outpos max-out-pos) + (setf (sm outpos stream) outpos) + (setq outpos (flush-out-buffer stream t))) + (setf (bref out-buffer outpos) byte) + (incf outpos))) + (char-to-octets (sm external-format stream) character + (sm co-state stream) #'output)) + (setf (sm outpos stream) outpos) + (if (sm charpos stream) (incf (sm charpos stream)))))) character) @@ -436,7 +436,7 @@ (do ((buffer (sm out-buffer stream)) (outpos (sm outpos stream)) (max-out-pos (sm max-out-pos stream)) - (ef (sm external-format stream)) + (ef (sm external-format stream)) (ctrl (sm control-out stream)) (posn start (1+ posn)) (count 0 (1+ count))) @@ -447,15 +447,15 @@ (unless (and (< code 32) ctrl (svref ctrl code) (funcall (the (or symbol function) (svref ctrl code)) stream char)) - (flet ((output (byte) - (when (>= outpos max-out-pos) - (setf (sm outpos stream) outpos) - (setq outpos (flush-out-buffer stream t))) - (setf (bref buffer outpos) byte) - (incf outpos))) - (char-to-octets ef char (sm co-state stream) #'output)) - (setf (sm outpos stream) outpos) - (if (sm charpos stream) (incf (sm charpos stream)))))))) + (flet ((output (byte) + (when (>= outpos max-out-pos) + (setf (sm outpos stream) outpos) + (setq outpos (flush-out-buffer stream t))) + (setf (bref buffer outpos) byte) + (incf outpos))) + (char-to-octets ef char (sm co-state stream) #'output)) + (setf (sm outpos stream) outpos) + (if (sm charpos stream) (incf (sm charpos stream)))))))) ;;;; String-Simple-Stream strategy functions @@ -497,7 +497,7 @@ (defun str-read-char-e-crlf (stream eof-error-p eof-value blocking) (with-stream-class (composing-stream stream) (let* ((encap (sm melded-stream stream)) - (ctrl (sm control-in stream)) + (ctrl (sm control-in stream)) (char (funcall-stm-handler j-read-char encap nil stream blocking))) ;; if CHAR is STREAM, we hit EOF; if NIL, blocking is NIL and no ;; character was available... @@ -517,13 +517,13 @@ (setq char #\Newline) (funcall-stm-handler j-unread-char encap nil)))) (when (characterp char) - (let ((code (char-code char))) - (when (and (< code 32) ctrl (svref ctrl code)) - (setq char (funcall (the (or symbol function) (svref ctrl code)) - stream char))))) + (let ((code (char-code char))) + (when (and (< code 32) ctrl (svref ctrl code)) + (setq char (funcall (the (or symbol function) (svref ctrl code)) + stream char))))) (if (eq char stream) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))) + (sb-impl::eof-or-lose stream eof-error-p eof-value) + char)))) (declaim (ftype j-unread-char-fn str-unread-char-e-crlf)) (defun str-unread-char-e-crlf (stream relaxed) @@ -537,7 +537,7 @@ (defun melding-stream (stream) (with-stream-class (simple-stream) (do ((stm stream (sm melded-stream stm))) - ((eq (sm melded-stream stm) stream) stm)))) + ((eq (sm melded-stream stm) stream) stm)))) (defun meld (stream encap) (with-stream-class (simple-stream) @@ -555,24 +555,24 @@ (with-stream-class (simple-stream) (let ((encap (sm melded-stream stream))) (unless (eq encap (sm melding-base stream)) - (setf (sm melding-base encap) encap) - (setf (sm melded-stream stream) (sm melded-stream encap)) - (setf (sm melded-stream encap) encap) - (rotatef (sm j-listen stream) (sm j-listen encap)) - (rotatef (sm j-read-char encap) (sm j-read-char stream)) - (rotatef (sm j-read-chars stream) (sm j-read-chars encap)) - (rotatef (sm j-unread-char stream) (sm j-unread-char encap)) - (rotatef (sm j-write-char stream) (sm j-write-char encap)) - (rotatef (sm j-write-chars stream) (sm j-write-chars encap)))))) + (setf (sm melding-base encap) encap) + (setf (sm melded-stream stream) (sm melded-stream encap)) + (setf (sm melded-stream encap) encap) + (rotatef (sm j-listen stream) (sm j-listen encap)) + (rotatef (sm j-read-char encap) (sm j-read-char stream)) + (rotatef (sm j-read-chars stream) (sm j-read-chars encap)) + (rotatef (sm j-unread-char stream) (sm j-unread-char encap)) + (rotatef (sm j-write-char stream) (sm j-write-char encap)) + (rotatef (sm j-write-chars stream) (sm j-write-chars encap)))))) ;;; In cmucl, this is done with define-function-name-syntax (lists as ;;; function names), we make do with symbol frobbing. (defun %sf (kind name format &optional access) (flet ((find-strategy-function (&rest args) - (let ((name - (find-symbol (format nil "~{~A~^-~}" (mapcar #'string args)) - #.*package*))) - (if (fboundp name) (fdefinition name) nil)))) + (let ((name + (find-symbol (format nil "~{~A~^-~}" (mapcar #'string args)) + #.*package*))) + (if (fboundp name) (fdefinition name) nil)))) (or (find-strategy-function kind name format access) (find-strategy-function kind name format) (find-strategy-function kind name :ef access) @@ -589,34 +589,34 @@ ;; (Avoids checking "mode" flags by installing special strategy) (with-stream-class (simple-stream stream) (setf (sm j-listen stream) - (%sf 'sc 'listen (ef-name format) access) - (sm j-read-char stream) - (%sf 'sc 'read-char (ef-name format) access) - (sm j-read-chars stream) - (%sf 'sc 'read-chars (ef-name format) access) - (sm j-unread-char stream) - (%sf 'sc 'unread-char (ef-name format) access) - (sm j-write-char stream) - (%sf 'sc 'write-char (ef-name format) access) - (sm j-write-chars stream) - (%sf 'sc 'write-chars (ef-name format) access)))) + (%sf 'sc 'listen (ef-name format) access) + (sm j-read-char stream) + (%sf 'sc 'read-char (ef-name format) access) + (sm j-read-chars stream) + (%sf 'sc 'read-chars (ef-name format) access) + (sm j-unread-char stream) + (%sf 'sc 'unread-char (ef-name format) access) + (sm j-write-char stream) + (%sf 'sc 'write-char (ef-name format) access) + (sm j-write-chars stream) + (%sf 'sc 'write-chars (ef-name format) access)))) stream) (defun install-dual-channel-character-strategy (stream external-format) (let ((format (find-external-format external-format))) (with-stream-class (simple-stream stream) (setf (sm j-listen stream) - (%sf 'sc 'listen (ef-name format)) - (sm j-read-char stream) - (%sf 'sc 'read-char (ef-name format)) - (sm j-read-chars stream) - (%sf 'sc 'read-chars (ef-name format)) - (sm j-unread-char stream) - (%sf 'sc 'unread-char (ef-name format)) - (sm j-write-char stream) - (%sf 'dc 'write-char (ef-name format)) - (sm j-write-chars stream) - (%sf 'dc 'write-chars (ef-name format))))) + (%sf 'sc 'listen (ef-name format)) + (sm j-read-char stream) + (%sf 'sc 'read-char (ef-name format)) + (sm j-read-chars stream) + (%sf 'sc 'read-chars (ef-name format)) + (sm j-unread-char stream) + (%sf 'sc 'unread-char (ef-name format)) + (sm j-write-char stream) + (%sf 'dc 'write-char (ef-name format)) + (sm j-write-chars stream) + (%sf 'dc 'write-chars (ef-name format))))) stream) ;; Deprecated -- use install-string-{input,output}-character-strategy instead! @@ -641,8 +641,8 @@ (let ((format composing-format)) (with-stream-class (simple-stream stream) (case format - (:e-crlf (setf (sm j-read-char stream) #'str-read-char-e-crlf - (sm j-unread-char stream) #'str-unread-char-e-crlf)))) + (:e-crlf (setf (sm j-read-char stream) #'str-read-char-e-crlf + (sm j-unread-char stream) #'str-unread-char-e-crlf)))) #| implement me |#) stream) @@ -650,16 +650,16 @@ (when (consp external-format) (with-stream-class (simple-stream) (let ((encap (if (eq (sm melded-stream stream) stream) - nil - (sm melded-stream stream)))) - (when (null encap) - (setq encap (make-instance 'composing-stream)) - (meld stream encap)) - (setf (stream-external-format encap) (car (last external-format))) - (setf (sm external-format stream) external-format) - (install-composing-format-character-strategy stream - (butlast external-format)) - )))) + nil + (sm melded-stream stream)))) + (when (null encap) + (setq encap (make-instance 'composing-stream)) + (meld stream encap)) + (setf (stream-external-format encap) (car (last external-format))) + (setf (sm external-format stream) external-format) + (install-composing-format-character-strategy stream + (butlast external-format)) + )))) (defmethod (setf stream-external-format) (ef (stream simple-stream)) (with-stream-class (simple-stream stream) diff --git a/contrib/sb-simple-streams/string.lisp b/contrib/sb-simple-streams/string.lisp index e4ebad1..3b85a2b 100644 --- a/contrib/sb-simple-streams/string.lisp +++ b/contrib/sb-simple-streams/string.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. -;;; +;;; ;;; Sbcl port by Rudi Schlatte. @@ -40,11 +40,11 @@ (with-stream-class (string-input-simple-stream stream) (let ((string (getf options :string))) (when (and string (null (sm buffer stream))) - (let ((start (getf options :start)) - (end (or (getf options :end) (length string)))) - (setf (sm buffer stream) string - (sm buffpos stream) start - (sm buffer-ptr stream) end)))) + (let ((start (getf options :start)) + (end (or (getf options :end) (length string)))) + (setf (sm buffer stream) string + (sm buffpos stream) start + (sm buffer-ptr stream) end)))) (install-string-input-character-strategy stream) (add-stream-instance-flags stream :string :input :simple))) @@ -53,12 +53,12 @@ (with-stream-class (string-output-simple-stream stream) (unless (sm out-buffer stream) (let ((string (getf options :string))) - (if string - (setf (sm out-buffer stream) string - (sm max-out-pos stream) (length string)) - (let ((buflen (max (device-buffer-length stream) 16))) - (setf (sm out-buffer stream) (make-string buflen) - (sm max-out-pos stream) buflen))))) + (if string + (setf (sm out-buffer stream) string + (sm max-out-pos stream) (length string)) + (let ((buflen (max (device-buffer-length stream) 16))) + (setf (sm out-buffer stream) (make-string buflen) + (sm max-out-pos stream) buflen))))) (unless (sm control-out stream) (setf (sm control-out stream) *std-control-out-table*)) (install-string-output-character-strategy stream) @@ -68,9 +68,9 @@ (declare (ignore options)) (with-stream-class (string-simple-stream stream) (if (and (any-stream-instance-flags stream :simple) - (any-stream-instance-flags stream :input :output)) - t - nil))) + (any-stream-instance-flags stream :input :output)) + t + nil))) (defmethod device-file-position ((stream string-simple-stream)) (with-stream-class (simple-stream stream) @@ -79,14 +79,14 @@ (defmethod (setf device-file-position) (value (stream string-simple-stream)) (with-stream-class (simple-stream stream) (cond ((or (> value (sm buffer-ptr stream)) - (< value (- -1 (sm buffer-ptr stream)))) - nil) - ((>= value 0) - (setf (sm buffpos stream) value) - t) - (t - (setf (sm buffpos stream) (+ (sm buffer-ptr stream) value 1)) - t)))) + (< value (- -1 (sm buffer-ptr stream)))) + nil) + ((>= value 0) + (setf (sm buffpos stream) value) + t) + (t + (setf (sm buffpos stream) (+ (sm buffer-ptr stream) value 1)) + t)))) (defmethod device-file-length ((stream string-simple-stream)) (with-stream-class (simple-stream stream) @@ -105,13 +105,13 @@ (with-stream-class (fill-pointer-output-simple-stream stream) (let ((buffer (sm out-buffer stream))) (cond ((or (> value (array-total-size buffer)) - (< value (- -1 (array-total-size buffer)))) - nil) - ((>= value 0) - (setf (fill-pointer buffer) value)) - (t - (setf (fill-pointer buffer) - (+ (array-total-size buffer) value 1))))))) + (< value (- -1 (array-total-size buffer)))) + nil) + ((>= value 0) + (setf (fill-pointer buffer) value)) + (t + (setf (fill-pointer buffer) + (+ (array-total-size buffer) value 1))))))) (defmethod device-open ((stream xp-simple-stream) options) #| do something |# diff --git a/contrib/sb-simple-streams/terminal.lisp b/contrib/sb-simple-streams/terminal.lisp index b4b82d9..fc16adc 100644 --- a/contrib/sb-simple-streams/terminal.lisp +++ b/contrib/sb-simple-streams/terminal.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. -;;; +;;; ;;; Sbcl port by Rudi Schlatte. @@ -26,7 +26,7 @@ (setf (sm input-handle stream) (getf options :input-handle)) (add-stream-instance-flags stream :simple :dual :input) (when (sb-unix:unix-isatty (sm input-handle stream)) - (add-stream-instance-flags stream :interactive)) + (add-stream-instance-flags stream :interactive)) (unless (sm buffer stream) (let ((length (device-buffer-length stream))) (setf (sm buffer stream) (allocate-buffer length) @@ -55,7 +55,7 @@ (unless buffer-only (let ((buffer (allocate-buffer sb-impl::bytes-per-buffer))) (unwind-protect - (loop until (<= (read-octets stream buffer - 0 sb-impl::bytes-per-buffer nil) - 0)) - (free-buffer buffer))))) + (loop until (<= (read-octets stream buffer + 0 sb-impl::bytes-per-buffer nil) + 0)) + (free-buffer buffer))))) diff --git a/contrib/sb-sprof/sb-sprof.lisp b/contrib/sb-sprof/sb-sprof.lisp index 42ea024..0fc7423 100644 --- a/contrib/sb-sprof/sb-sprof.lisp +++ b/contrib/sb-sprof/sb-sprof.lisp @@ -51,7 +51,7 @@ ;;; 18: pop dword ptr [ebp-8] ;;; 1B: lea esp, [ebp-32] ;;; 1E: mov edi, edx -;;; +;;; ;;; 20: cmp ecx, 4 ;;; 23: jne L4 ;;; 29: mov [ebp-12], edi @@ -82,7 +82,7 @@ ;;; the stack is something x86-call-context can't really cope with, ;;; this is not a general solution. ;;; -;;; Random ideas for implementation: +;;; Random ideas for implementation: ;;; ;;; * Space profiler. Sample when new pages are allocated instead of ;;; at SIGPROF. @@ -100,9 +100,9 @@ (defpackage #:sb-sprof (:use #:cl #:sb-ext #:sb-unix #:sb-alien #:sb-sys) (:export #:*sample-interval* #:*max-samples* - #:start-sampling #:stop-sampling #:with-sampling - #:with-profiling #:start-profiling #:stop-profiling - #:reset #:report)) + #:start-sampling #:stop-sampling #:with-sampling + #:with-profiling #:start-profiling #:stop-profiling + #:reset #:report)) (in-package #:sb-sprof) @@ -110,7 +110,7 @@ ;;;; Graph Utilities (defstruct (vertex (:constructor make-vertex) - (:constructor make-scc (scc-vertices edges))) + (:constructor make-scc (scc-vertices edges))) (visited nil :type boolean) (root nil :type (or null vertex)) (dfn 0 :type fixnum) @@ -155,42 +155,42 @@ ;;; Tarjan. (defun strong-components (vertices) (let ((in-component (make-array (length vertices) - :element-type 'boolean - :initial-element nil)) - (stack ()) - (components ()) - (dfn -1)) + :element-type 'boolean + :initial-element nil)) + (stack ()) + (components ()) + (dfn -1)) (labels ((min-root (x y) - (let ((rx (vertex-root x)) - (ry (vertex-root y))) - (if (< (vertex-dfn rx) (vertex-dfn ry)) - rx - ry))) - (in-component (v) - (aref in-component (vertex-dfn v))) - ((setf in-component) (in v) - (setf (aref in-component (vertex-dfn v)) in)) - (vertex-> (x y) - (> (vertex-dfn x) (vertex-dfn y))) - (visit (v) - (setf (vertex-dfn v) (incf dfn) - (in-component v) nil - (vertex-root v) v - (vertex-visited v) t) - (do-edges (e w v) - (unless (vertex-visited w) - (visit w)) - (unless (in-component w) - (setf (vertex-root v) (min-root v w)))) - (if (eq v (vertex-root v)) - (loop while (and stack (vertex-> (car stack) v)) - as w = (pop stack) - collect w into this-component - do (setf (in-component w) t) - finally - (setf (in-component v) t) - (push (cons v this-component) components)) - (push v stack)))) + (let ((rx (vertex-root x)) + (ry (vertex-root y))) + (if (< (vertex-dfn rx) (vertex-dfn ry)) + rx + ry))) + (in-component (v) + (aref in-component (vertex-dfn v))) + ((setf in-component) (in v) + (setf (aref in-component (vertex-dfn v)) in)) + (vertex-> (x y) + (> (vertex-dfn x) (vertex-dfn y))) + (visit (v) + (setf (vertex-dfn v) (incf dfn) + (in-component v) nil + (vertex-root v) v + (vertex-visited v) t) + (do-edges (e w v) + (unless (vertex-visited w) + (visit w)) + (unless (in-component w) + (setf (vertex-root v) (min-root v w)))) + (if (eq v (vertex-root v)) + (loop while (and stack (vertex-> (car stack) v)) + as w = (pop stack) + collect w into this-component + do (setf (in-component w) t) + finally + (setf (in-component v) t) + (push (cons v this-component) components)) + (push v stack)))) (map-vertices #'visit vertices) components))) @@ -198,14 +198,14 @@ ;;; topologically, children first. (defun topological-sort (dag) (let ((sorted ()) - (dfn -1)) + (dfn -1)) (labels ((rec-sort (v) - (setf (vertex-visited v) t) - (setf (vertex-dfn v) (incf dfn)) - (dolist (e (vertex-edges v)) - (unless (vertex-visited (edge-vertex e)) - (rec-sort (edge-vertex e)))) - (push v sorted))) + (setf (vertex-visited v) t) + (setf (vertex-dfn v) (incf dfn)) + (dolist (e (vertex-edges v)) + (unless (vertex-visited (edge-vertex e)) + (rec-sort (edge-vertex e)))) + (push v sorted))) (map-vertices #'rec-sort dag) (nreverse sorted)))) @@ -215,20 +215,20 @@ (sb-int:collect ((sccs) (trivial)) (dolist (c (strong-components (graph-vertices graph))) (if (or (cdr c) (self-cycle-p (car c))) - (sb-int:collect ((outgoing)) - (dolist (v c) - (do-edges (e w v) - (unless (member w c) - (outgoing e)))) - (sccs (funcall scc-constructor c (outgoing)))) - (trivial (car c)))) + (sb-int:collect ((outgoing)) + (dolist (v c) + (do-edges (e w v) + (unless (member w c) + (outgoing e)))) + (sccs (funcall scc-constructor c (outgoing)))) + (trivial (car c)))) (dolist (scc (sccs)) (dolist (v (trivial)) - (do-edges (e w v) - (when (member w (vertex-scc-vertices scc)) - (setf (edge-vertex e) scc))))) + (do-edges (e w v) + (when (member w (vertex-scc-vertices scc)) + (setf (edge-vertex e) scc))))) (setf (graph-vertices graph) - (topological-sort (nconc (sccs) (trivial)))))) + (topological-sort (nconc (sccs) (trivial)))))) ;;;; AA Trees @@ -274,93 +274,93 @@ (defun split (aa) (when (= (aa-level (aa-right (aa-right aa))) - (aa-level aa)) + (aa-level aa)) (setq aa (rotate-with-right-child aa)) (incf (aa-level aa))) aa) (macrolet ((def (name () &body body) - (let ((name (sb-int::symbolicate 'aa- name))) - `(defun ,name (item tree &key - (test-< #'<) (test-= #'=) - (node-key #'identity) (item-key #'identity)) - (let ((.item-key. (funcall item-key item))) - (flet ((item-< (node) - (funcall test-< .item-key. - (funcall node-key (aa-data node)))) - (item-= (node) - (funcall test-= .item-key. - (funcall node-key (aa-data node))))) - (declare (inline item-< item-=)) - ,@body)))))) - + (let ((name (sb-int::symbolicate 'aa- name))) + `(defun ,name (item tree &key + (test-< #'<) (test-= #'=) + (node-key #'identity) (item-key #'identity)) + (let ((.item-key. (funcall item-key item))) + (flet ((item-< (node) + (funcall test-< .item-key. + (funcall node-key (aa-data node)))) + (item-= (node) + (funcall test-= .item-key. + (funcall node-key (aa-data node))))) + (declare (inline item-< item-=)) + ,@body)))))) + (def insert () (labels ((insert-into (aa) - (cond ((eq aa *null-node*) - (setq aa (make-aa-node :data item - :left *null-node* - :right *null-node*))) - ((item-= aa) - (return-from insert-into aa)) - ((item-< aa) - (setf (aa-left aa) (insert-into (aa-left aa)))) - (t - (setf (aa-right aa) (insert-into (aa-right aa))))) - (split (skew aa)))) + (cond ((eq aa *null-node*) + (setq aa (make-aa-node :data item + :left *null-node* + :right *null-node*))) + ((item-= aa) + (return-from insert-into aa)) + ((item-< aa) + (setf (aa-left aa) (insert-into (aa-left aa)))) + (t + (setf (aa-right aa) (insert-into (aa-right aa))))) + (split (skew aa)))) (setf (aa-tree-root tree) - (insert-into (aa-tree-root tree))))) - + (insert-into (aa-tree-root tree))))) + (def delete () (let ((deleted-node *null-node*) - (last-node nil)) + (last-node nil)) (labels ((remove-from (aa) - (unless (eq aa *null-node*) - (setq last-node aa) - (if (item-< aa) - (setf (aa-left aa) (remove-from (aa-left aa))) - (progn - (setq deleted-node aa) - (setf (aa-right aa) (remove-from (aa-right aa))))) - (cond ((eq aa last-node) - ;; - ;; If at the bottom of the tree, and item - ;; is present, delete it. - (when (and (not (eq deleted-node *null-node*)) - (item-= deleted-node)) - (setf (aa-data deleted-node) (aa-data aa)) - (setq deleted-node *null-node*) - (setq aa (aa-right aa)))) - ;; - ;; Otherwise not at bottom of tree; rebalance. - ((or (< (aa-level (aa-left aa)) - (1- (aa-level aa))) - (< (aa-level (aa-right aa)) - (1- (aa-level aa)))) - (decf (aa-level aa)) - (when (> (aa-level (aa-right aa)) (aa-level aa)) - (setf (aa-level (aa-right aa)) (aa-level aa))) - (setq aa (skew aa)) - (setf (aa-right aa) (skew (aa-right aa))) - (setf (aa-right (aa-right aa)) - (skew (aa-right (aa-right aa)))) - (setq aa (split aa)) - (setf (aa-right aa) (split (aa-right aa)))))) - aa)) - (setf (aa-tree-root tree) - (remove-from (aa-tree-root tree)))))) + (unless (eq aa *null-node*) + (setq last-node aa) + (if (item-< aa) + (setf (aa-left aa) (remove-from (aa-left aa))) + (progn + (setq deleted-node aa) + (setf (aa-right aa) (remove-from (aa-right aa))))) + (cond ((eq aa last-node) + ;; + ;; If at the bottom of the tree, and item + ;; is present, delete it. + (when (and (not (eq deleted-node *null-node*)) + (item-= deleted-node)) + (setf (aa-data deleted-node) (aa-data aa)) + (setq deleted-node *null-node*) + (setq aa (aa-right aa)))) + ;; + ;; Otherwise not at bottom of tree; rebalance. + ((or (< (aa-level (aa-left aa)) + (1- (aa-level aa))) + (< (aa-level (aa-right aa)) + (1- (aa-level aa)))) + (decf (aa-level aa)) + (when (> (aa-level (aa-right aa)) (aa-level aa)) + (setf (aa-level (aa-right aa)) (aa-level aa))) + (setq aa (skew aa)) + (setf (aa-right aa) (skew (aa-right aa))) + (setf (aa-right (aa-right aa)) + (skew (aa-right (aa-right aa)))) + (setq aa (split aa)) + (setf (aa-right aa) (split (aa-right aa)))))) + aa)) + (setf (aa-tree-root tree) + (remove-from (aa-tree-root tree)))))) (def find () (let ((current (aa-tree-root tree))) (setf (aa-data *null-node*) item) (loop - (cond ((eq current *null-node*) - (return (values nil nil))) - ((item-= current) - (return (values (aa-data current) t))) - ((item-< current) - (setq current (aa-left current))) - (t - (setq current (aa-right current)))))))) + (cond ((eq current *null-node*) + (return (values nil nil))) + ((item-= current) + (return (values (aa-data current) t))) + ((item-< current) + (setq current (aa-left current))) + (t + (setq current (aa-right current)))))))) ;;;; Other Utilities @@ -370,50 +370,50 @@ ;;; Element-Size array slots, and that the slot Key-Offset contains ;;; the sort key. (defun qsort (vec &key (element-size 1) (key-offset 0) - (from 0) (to (- (length vec) element-size))) + (from 0) (to (- (length vec) element-size))) (declare (type fixnum to from element-size key-offset)) (declare (type (simple-array address) vec)) (labels ((rotate (i j) - (declare (fixnum i j)) - (loop repeat element-size - for i from i and j from j do - (rotatef (aref vec i) (aref vec j)))) - (key (i) - (aref vec (+ i key-offset))) - (rec-sort (from to) - (declare (fixnum to from)) - (when (> to from) - (let* ((mid (* element-size - (round (+ (/ from element-size) - (/ to element-size)) - 2))) - (i from) - (j (+ to element-size)) - (p (key mid))) - (declare (fixnum mid i j)) - (rotate mid from) - (loop - (loop do (incf i element-size) - until (or (> i to) - ;; QSORT used to take a test - ;; parameter which was funcalled - ;; here. This caused some consing, - ;; which is problematic since - ;; QSORT is indirectly called in - ;; an after-gc-hook. So just - ;; hardcode >, which would've been - ;; used for the test anyway. - ;; --JES, 2004-07-09 - (> p (key i)))) - (loop do (decf j element-size) - until (or (<= j from) - ;; As above. - (> (key j) p))) - (when (< j i) (return)) - (rotate i j)) - (rotate from j) - (rec-sort from (- j element-size)) - (rec-sort i to))))) + (declare (fixnum i j)) + (loop repeat element-size + for i from i and j from j do + (rotatef (aref vec i) (aref vec j)))) + (key (i) + (aref vec (+ i key-offset))) + (rec-sort (from to) + (declare (fixnum to from)) + (when (> to from) + (let* ((mid (* element-size + (round (+ (/ from element-size) + (/ to element-size)) + 2))) + (i from) + (j (+ to element-size)) + (p (key mid))) + (declare (fixnum mid i j)) + (rotate mid from) + (loop + (loop do (incf i element-size) + until (or (> i to) + ;; QSORT used to take a test + ;; parameter which was funcalled + ;; here. This caused some consing, + ;; which is problematic since + ;; QSORT is indirectly called in + ;; an after-gc-hook. So just + ;; hardcode >, which would've been + ;; used for the test anyway. + ;; --JES, 2004-07-09 + (> p (key i)))) + (loop do (decf j element-size) + until (or (<= j from) + ;; As above. + (> (key j) p))) + (when (< j i) (return)) + (rotate i j)) + (rotate from j) + (rec-sort from (- j element-size)) + (rec-sort i to))))) (rec-sort from to) vec)) @@ -431,7 +431,7 @@ ;;; A call graph. Vertices are NODE structures, edges are CALL ;;; structures. (defstruct (call-graph (:include graph) - (:constructor %make-call-graph)) + (:constructor %make-call-graph)) ;; the value of *Sample-Interval* at the time the graph was created (sample-interval (sb-impl::missing-arg) :type number) ;; number of samples taken @@ -445,7 +445,7 @@ ;;; sampled. The edges of a node are CALL structures that represent ;;; functions called from a given node. (defstruct (node (:include vertex) - (:constructor %make-node)) + (:constructor %make-node)) ;; A numeric label for the node. The most frequently called function ;; gets label 1. This is just for identification purposes in the ;; profiling report. @@ -469,7 +469,7 @@ ;;; An edge in a call graph. EDGE-VERTEX is the function being ;;; called. (defstruct (call (:include edge) - (:constructor make-call (vertex))) + (:constructor make-call (vertex))) ;; number of times the call was sampled (count 1 :type sb-impl::index)) @@ -495,7 +495,7 @@ (defmethod print-object ((call call) stream) (print-unreadable-object (call stream :type t :identity t) (format stream "~s [~d]" (node-name (call-vertex call)) - (node-index (call-vertex call))))) + (node-index (call-vertex call))))) (deftype report-type () '(member nil :flat :graph)) @@ -538,7 +538,7 @@ (defun show-progress (format-string &rest args) (when *show-progress* - (apply #'format t format-string args) + (apply #'format t format-string args) (finish-output))) (defun start-sampling () @@ -559,10 +559,10 @@ :Pc or :Return-Pc for sorting by pc or return pc." (when (plusp *samples-index*) (qsort *samples* - :from 0 - :to (- *samples-index* +sample-size+) - :element-size +sample-size+ - :key-offset key-offset))) + :from 0 + :to (- *samples-index* +sample-size+) + :element-size +sample-size+ + :key-offset key-offset))) (defun record (pc) (declare (type address pc)) @@ -575,36 +575,36 @@ (defun sigprof-handler (signal code scp) (declare (ignore signal code) (type system-area-pointer scp)) (when (and *sampling* - (< *samples-index* (length *samples*))) + (< *samples-index* (length *samples*))) (sb-sys:without-gcing - (locally (declare (optimize (inhibit-warnings 2))) - (with-alien ((scp (* os-context-t) :local scp)) - ;; For some reason completely bogus small values for the - ;; frame pointer are returned every now and then, leading - ;; to segfaults. Try to avoid these cases. - ;; - ;; FIXME: Do a more thorough sanity check on ebp, or figure - ;; out why this is happening. - ;; -- JES, 2005-01-11 - (when (< (sb-vm::context-register scp #.sb-vm::ebp-offset) - 4096) - (dotimes (i +sample-size+) - (record 0)) - (return-from sigprof-handler nil)) - (let* ((pc-ptr (sb-vm:context-pc scp)) - (fp (sb-vm::context-register scp #.sb-vm::ebp-offset))) - (record (sap-int pc-ptr)) - (let ((fp (int-sap fp)) - ra) - (dotimes (i (1- +sample-size+)) - (cond (fp - (setf (values ra fp) - (sb-di::x86-call-context fp :depth i)) - (record (if ra - (sap-int ra) - 0))) - (t - (record 0))))))))))) + (locally (declare (optimize (inhibit-warnings 2))) + (with-alien ((scp (* os-context-t) :local scp)) + ;; For some reason completely bogus small values for the + ;; frame pointer are returned every now and then, leading + ;; to segfaults. Try to avoid these cases. + ;; + ;; FIXME: Do a more thorough sanity check on ebp, or figure + ;; out why this is happening. + ;; -- JES, 2005-01-11 + (when (< (sb-vm::context-register scp #.sb-vm::ebp-offset) + 4096) + (dotimes (i +sample-size+) + (record 0)) + (return-from sigprof-handler nil)) + (let* ((pc-ptr (sb-vm:context-pc scp)) + (fp (sb-vm::context-register scp #.sb-vm::ebp-offset))) + (record (sap-int pc-ptr)) + (let ((fp (int-sap fp)) + ra) + (dotimes (i (1- +sample-size+)) + (cond (fp + (setf (values ra fp) + (sb-di::x86-call-context fp :depth i)) + (record (if ra + (sap-int ra) + 0))) + (t + (record 0))))))))))) ;; FIXME: On non-x86 platforms we don't yet walk the call stack deeper ;; than one level. @@ -612,25 +612,25 @@ (defun sigprof-handler (signal code scp) (declare (ignore signal code)) (when (and *sampling* - (< *samples-index* (length *samples*))) + (< *samples-index* (length *samples*))) (sb-sys:without-gcing (with-alien ((scp (* os-context-t) :local scp)) (locally (declare (optimize (inhibit-warnings 2))) - (let* ((pc-ptr (sb-vm:context-pc scp)) - (fp (sb-vm::context-register scp #.sb-vm::cfp-offset)) - (ra (sap-ref-word - (int-sap fp) - (* sb-vm::lra-save-offset sb-vm::n-word-bytes)))) - (record (sap-int pc-ptr)) - (record ra))))))) + (let* ((pc-ptr (sb-vm:context-pc scp)) + (fp (sb-vm::context-register scp #.sb-vm::cfp-offset)) + (ra (sap-ref-word + (int-sap fp) + (* sb-vm::lra-save-offset sb-vm::n-word-bytes)))) + (record (sap-int pc-ptr)) + (record ra))))))) ;;; Map function FN over code objects in dynamic-space. FN is called ;;; with two arguments, the object and its size in bytes. (defun map-dynamic-space-code (fn) (flet ((call-if-code (obj obj-type size) - (declare (ignore obj-type)) - (when (sb-kernel:code-component-p obj) - (funcall fn obj size)))) + (declare (ignore obj-type)) + (when (sb-kernel:code-component-p obj) + (funcall fn obj size)))) (sb-vm::map-allocated-objects #'call-if-code :dynamic))) ;;; Return the start address of CODE. @@ -642,18 +642,18 @@ (defun code-bounds (code) (declare (type sb-kernel:code-component code)) (let* ((start (code-start code)) - (end (+ start (sb-kernel:%code-code-size code)))) + (end (+ start (sb-kernel:%code-code-size code)))) (values start end))) ;;; Record the addresses of dynamic-space code objects in ;;; *DYNAMIC-SPACE-CODE-INFO*. Call this with GC disabled. (defun record-dyninfo () (flet ((record-address (code size) - (declare (ignore size)) - (multiple-value-bind (start end) - (code-bounds code) - (push (make-dyninfo code start end) - *dynamic-space-code-info*)))) + (declare (ignore size)) + (multiple-value-bind (start end) + (code-bounds code) + (push (make-dyninfo code start end) + *dynamic-space-code-info*)))) (map-dynamic-space-code #'record-address))) (defun adjust-samples (offset) @@ -662,22 +662,22 @@ (declare (type sb-impl::index sidx)) (dolist (info *dynamic-space-code-info*) (unless (= (dyninfo-new-start info) (dyninfo-start info)) - (let ((pos (do ((i sidx (+ i +sample-size+))) - ((= i *samples-index*) nil) - (declare (type sb-impl::index i)) - (when (<= (dyninfo-start info) - (aref *samples* (+ i offset)) - (dyninfo-end info)) - (return i))))) - (when pos - (setq sidx pos) - (loop with delta = (- (dyninfo-new-start info) - (dyninfo-start info)) - for j from sidx below *samples-index* by +sample-size+ - as pc = (aref *samples* (+ j offset)) - while (<= (dyninfo-start info) pc (dyninfo-end info)) do - (incf (aref *samples* (+ j offset)) delta) - (incf sidx +sample-size+)))))))) + (let ((pos (do ((i sidx (+ i +sample-size+))) + ((= i *samples-index*) nil) + (declare (type sb-impl::index i)) + (when (<= (dyninfo-start info) + (aref *samples* (+ i offset)) + (dyninfo-end info)) + (return i))))) + (when pos + (setq sidx pos) + (loop with delta = (- (dyninfo-new-start info) + (dyninfo-start info)) + for j from sidx below *samples-index* by +sample-size+ + as pc = (aref *samples* (+ j offset)) + while (<= (dyninfo-start info) pc (dyninfo-end info)) do + (incf (aref *samples* (+ j offset)) delta) + (incf sidx +sample-size+)))))))) ;;; This runs from *AFTER-GC-HOOKS*. Adjust *SAMPLES* for address ;;; changes of dynamic-space code objects. @@ -685,10 +685,10 @@ (sb-sys:without-gcing (turn-off-sampling) (setq *dynamic-space-code-info* - (sort *dynamic-space-code-info* #'> :key #'dyninfo-start)) + (sort *dynamic-space-code-info* #'> :key #'dyninfo-start)) (dolist (info *dynamic-space-code-info*) (setf (dyninfo-new-start info) - (code-start (dyninfo-code info)))) + (code-start (dyninfo-code info)))) (progn (dotimes (i +sample-size+) (adjust-samples i))) @@ -699,11 +699,11 @@ (turn-on-sampling))) (defmacro with-profiling ((&key (sample-interval '*sample-interval*) - (max-samples '*max-samples*) - (reset nil) - show-progress - (report nil report-p)) - &body body) + (max-samples '*max-samples*) + (reset nil) + show-progress + (report nil report-p)) + &body body) "Repeatedly evaluate Body with statistical profiling turned on. The following keyword args are recognized: @@ -722,27 +722,27 @@ It true, call Reset at the beginning." (declare (type report-type report)) `(let ((*sample-interval* ,sample-interval) - (*max-samples* ,max-samples)) + (*max-samples* ,max-samples)) ,@(when reset '((reset))) (start-profiling) (loop - (when (>= *samples-index* (length *samples*)) - (return)) - ,@(when show-progress - `((format t "~&===> ~d of ~d samples taken.~%" - (/ *samples-index* +sample-size+) - *max-samples*))) - (let ((.last-index. *samples-index*)) - ,@body - (when (= .last-index. *samples-index*) - (warn "No sampling progress; possibly a profiler bug.") - (return)))) + (when (>= *samples-index* (length *samples*)) + (return)) + ,@(when show-progress + `((format t "~&===> ~d of ~d samples taken.~%" + (/ *samples-index* +sample-size+) + *max-samples*))) + (let ((.last-index. *samples-index*)) + ,@body + (when (= .last-index. *samples-index*) + (warn "No sampling progress; possibly a profiler bug.") + (return)))) (stop-profiling) ,@(when report-p `((report :type ,report))))) (defun start-profiling (&key (max-samples *max-samples*) - (sample-interval *sample-interval*) - (sampling t)) + (sample-interval *sample-interval*) + (sampling t)) "Start profiling statistically if not already profiling. The following keyword args are recognized: @@ -758,11 +758,11 @@ If false, Start-Sampling can be used to turn sampling on." (unless *profiling* (multiple-value-bind (secs usecs) - (multiple-value-bind (secs rest) - (truncate sample-interval) - (values secs (truncate (* rest 1000000)))) + (multiple-value-bind (secs rest) + (truncate sample-interval) + (values secs (truncate (* rest 1000000)))) (setq *samples* (make-array (* max-samples +sample-size+) - :element-type 'address)) + :element-type 'address)) (setq *samples-index* 0) (setq *sampling* sampling) ;; Disabled for now, since this was causing some problems with the @@ -783,7 +783,7 @@ "Stop profiling if profiling." (when *profiling* (setq *after-gc-hooks* - (delete 'adjust-samples-for-address-changes *after-gc-hooks*)) + (delete 'adjust-samples-for-address-changes *after-gc-hooks*)) (unix-setitimer :profile 0 0 0 0) (sb-sys:enable-interrupt sb-unix::sigprof :default) (setq *sampling* nil) @@ -804,23 +804,23 @@ (typecase info (sb-kernel::code-component (multiple-value-bind (start end) - (code-bounds info) + (code-bounds info) (%make-node :name (or (sb-disassem::find-assembler-routine start) - (format nil "~a" info)) - :start-pc start :end-pc end))) + (format nil "~a" info)) + :start-pc start :end-pc end))) (sb-di::compiled-debug-fun (let* ((name (sb-di::debug-fun-name info)) - (cdf (sb-di::compiled-debug-fun-compiler-debug-fun info)) - (start-offset (sb-c::compiled-debug-fun-start-pc cdf)) - (end-offset (sb-c::compiled-debug-fun-elsewhere-pc cdf)) - (component (sb-di::compiled-debug-fun-component info)) - (start-pc (code-start component))) + (cdf (sb-di::compiled-debug-fun-compiler-debug-fun info)) + (start-offset (sb-c::compiled-debug-fun-start-pc cdf)) + (end-offset (sb-c::compiled-debug-fun-elsewhere-pc cdf)) + (component (sb-di::compiled-debug-fun-component info)) + (start-pc (code-start component))) (%make-node :name name - :start-pc (+ start-pc start-offset) - :end-pc (+ start-pc end-offset)))) + :start-pc (+ start-pc start-offset) + :end-pc (+ start-pc end-offset)))) (sb-di::debug-fun (%make-node :name (sb-di::debug-fun-name info))) - (t + (t (%make-node :name (coerce info 'string))))) ;;; Return something serving as debug info for address PC. If we can @@ -831,22 +831,22 @@ (declare (type address pc)) (let ((ptr (sb-di::component-ptr-from-pc (int-sap pc)))) (cond ((sap= ptr (int-sap 0)) - (let ((name (sap-foreign-symbol (int-sap pc)))) - (when name - (format nil "foreign function ~a" name)))) - (t - (let* ((code (sb-di::component-from-component-ptr ptr)) - (code-header-len (* (sb-kernel:get-header-data code) - sb-vm:n-word-bytes)) - (pc-offset (- pc - (- (sb-kernel:get-lisp-obj-address code) - sb-vm:other-pointer-lowtag) - code-header-len)) - (df (ignore-errors (sb-di::debug-fun-from-pc code - pc-offset)))) - (or df - code)))))) - + (let ((name (sap-foreign-symbol (int-sap pc)))) + (when name + (format nil "foreign function ~a" name)))) + (t + (let* ((code (sb-di::component-from-component-ptr ptr)) + (code-header-len (* (sb-kernel:get-header-data code) + sb-vm:n-word-bytes)) + (pc-offset (- pc + (- (sb-kernel:get-lisp-obj-address code) + sb-vm:other-pointer-lowtag) + code-header-len)) + (df (ignore-errors (sb-di::debug-fun-from-pc code + pc-offset)))) + (or df + code)))))) + ;;; One function can have more than one COMPILED-DEBUG-FUNCTION with ;;; the same name. Reduce the number of calls to Debug-Info by first @@ -859,21 +859,21 @@ (defmacro with-lookup-tables (() &body body) `(let ((*node-tree* (make-aa-tree)) - (*name->node* (make-hash-table :test 'equal))) + (*name->node* (make-hash-table :test 'equal))) ,@body)) (defun tree-find (item) (flet ((pc/node-= (pc node) - (<= (node-start-pc node) pc (node-end-pc node))) - (pc/node-< (pc node) - (< pc (node-start-pc node)))) + (<= (node-start-pc node) pc (node-end-pc node))) + (pc/node-< (pc node) + (< pc (node-start-pc node)))) (aa-find item *node-tree* :test-= #'pc/node-= :test-< #'pc/node-<))) - + (defun tree-insert (item) (flet ((node/node-= (x y) - (<= (node-start-pc y) (node-start-pc x) (node-end-pc y))) - (node/node-< (x y) - (< (node-start-pc x) (node-start-pc y)))) + (<= (node-start-pc y) (node-start-pc x) (node-end-pc y))) + (node/node-< (x y) + (< (node-start-pc x) (node-start-pc y)))) (aa-insert item *node-tree* :test-= #'node/node-= :test-< #'node/node-<))) ;;; Find or make a new node for address PC. Value is the NODE found @@ -883,86 +883,86 @@ (declare (type address pc)) (or (tree-find pc) (let ((info (debug-info pc))) - (when info - (let* ((new (make-node info)) - (found (gethash (node-name new) *name->node*))) - (cond (found - (setf (node-start-pc found) - (min (node-start-pc found) (node-start-pc new))) - (setf (node-end-pc found) - (max (node-end-pc found) (node-end-pc new))) - found) - (t - (setf (gethash (node-name new) *name->node*) new) - (tree-insert new) - new))))))) + (when info + (let* ((new (make-node info)) + (found (gethash (node-name new) *name->node*))) + (cond (found + (setf (node-start-pc found) + (min (node-start-pc found) (node-start-pc new))) + (setf (node-end-pc found) + (max (node-end-pc found) (node-end-pc new))) + found) + (t + (setf (gethash (node-name new) *name->node*) new) + (tree-insert new) + new))))))) ;;; Return a list of all nodes created by LOOKUP-NODE. (defun collect-nodes () (loop for node being the hash-values of *name->node* - collect node)) + collect node)) ;;; Value is a CALL-GRAPH for the current contents of *SAMPLES*. (defun make-call-graph-1 (depth) (let ((elsewhere-count 0) - visited-nodes) + visited-nodes) (with-lookup-tables () (loop for i below (1- *samples-index*) ;; by +sample-size+ - as pc = (aref *samples* i) - as return-pc = (aref *samples* (1+ i)) - as callee = (lookup-node pc) - as caller = - (when (and callee (/= return-pc +unknown-address+)) - (let ((caller (lookup-node return-pc))) - (when caller - caller))) - do - (when (and *show-progress* (plusp i)) - (cond ((zerop (mod i 1000)) - (show-progress "~d" i)) - ((zerop (mod i 100)) - (show-progress ".")))) - (when (< (mod i +sample-size+) depth) - (when (= (mod i +sample-size+) 0) - (setf visited-nodes nil) - (cond (callee - (incf (node-accrued-count callee)) - (incf (node-count callee))) - (t - (incf elsewhere-count)))) - (when callee - (push callee visited-nodes)) - (when caller - (unless (member caller visited-nodes) - (incf (node-accrued-count caller))) - (when callee - (let ((call (find callee (node-edges caller) - :key #'call-vertex))) - (pushnew caller (node-callers callee)) - (if call - (unless (member caller visited-nodes) - (incf (call-count call))) - (push (make-call callee) (node-edges caller)))))))) + as pc = (aref *samples* i) + as return-pc = (aref *samples* (1+ i)) + as callee = (lookup-node pc) + as caller = + (when (and callee (/= return-pc +unknown-address+)) + (let ((caller (lookup-node return-pc))) + (when caller + caller))) + do + (when (and *show-progress* (plusp i)) + (cond ((zerop (mod i 1000)) + (show-progress "~d" i)) + ((zerop (mod i 100)) + (show-progress ".")))) + (when (< (mod i +sample-size+) depth) + (when (= (mod i +sample-size+) 0) + (setf visited-nodes nil) + (cond (callee + (incf (node-accrued-count callee)) + (incf (node-count callee))) + (t + (incf elsewhere-count)))) + (when callee + (push callee visited-nodes)) + (when caller + (unless (member caller visited-nodes) + (incf (node-accrued-count caller))) + (when callee + (let ((call (find callee (node-edges caller) + :key #'call-vertex))) + (pushnew caller (node-callers callee)) + (if call + (unless (member caller visited-nodes) + (incf (call-count call))) + (push (make-call callee) (node-edges caller)))))))) (let ((sorted-nodes (sort (collect-nodes) #'> :key #'node-count))) - (loop for node in sorted-nodes and i from 1 do - (setf (node-index node) i)) - (%make-call-graph :nsamples (/ *samples-index* +sample-size+) - :sample-interval *sample-interval* - :elsewhere-count elsewhere-count - :vertices sorted-nodes))))) + (loop for node in sorted-nodes and i from 1 do + (setf (node-index node) i)) + (%make-call-graph :nsamples (/ *samples-index* +sample-size+) + :sample-interval *sample-interval* + :elsewhere-count elsewhere-count + :vertices sorted-nodes))))) ;;; Reduce CALL-GRAPH to a dag, creating CYCLE structures for call ;;; cycles. (defun reduce-call-graph (call-graph) (let ((cycle-no 0)) (flet ((make-one-cycle (vertices edges) - (let* ((name (format nil "" (incf cycle-no))) - (count (loop for v in vertices sum (node-count v)))) - (make-cycle :name name - :index cycle-no - :count count - :scc-vertices vertices - :edges edges)))) + (let* ((name (format nil "" (incf cycle-no))) + (count (loop for v in vertices sum (node-count v)))) + (make-cycle :name name + :index cycle-no + :count count + :scc-vertices vertices + :edges edges)))) (reduce-graph call-graph #'make-one-cycle)))) ;;; For all nodes in CALL-GRAPH, compute times including the time @@ -975,8 +975,8 @@ (setf (node-accrued-count from) (node-count from)) (do-edges (call to from) (incf (node-accrued-count from) - (round (* (/ (call-count call) (node-count to)) - (node-accrued-count to))))))) + (round (* (/ (call-count call) (node-count to)) + (node-accrued-count to))))))) ;;; Return a CALL-GRAPH structure for the current contents of ;;; *SAMPLES*. The result contain a list of nodes sorted by self-time @@ -987,7 +987,7 @@ (show-progress "~&Computing call graph ") (let ((call-graph (without-gcing (make-call-graph-1 depth)))) (setf (call-graph-flat-nodes call-graph) - (copy-list (graph-vertices call-graph))) + (copy-list (graph-vertices call-graph))) (show-progress "~&Finding cycles") (reduce-call-graph call-graph) (show-progress "~&Propagating counts") @@ -1005,59 +1005,59 @@ (defun print-call-graph-header (call-graph) (let ((nsamples (call-graph-nsamples call-graph)) - (interval (call-graph-sample-interval call-graph)) - (ncycles (loop for v in (graph-vertices call-graph) - count (scc-p v)))) + (interval (call-graph-sample-interval call-graph)) + (ncycles (loop for v in (graph-vertices call-graph) + count (scc-p v)))) (format t "~2&Number of samples: ~d~%~ Sample interval: ~f seconds~%~ Total sampling time: ~f seconds~%~ Number of cycles: ~d~2%" - nsamples - interval - (* nsamples interval) - ncycles))) + nsamples + interval + (* nsamples interval) + ncycles))) (defun print-flat (call-graph &key (stream *standard-output*) max - min-percent (print-header t)) + min-percent (print-header t)) (let ((*standard-output* stream) - (*print-pretty* nil) - (total-count 0) - (total-percent 0) - (min-count (if min-percent - (round (* (/ min-percent 100.0) - (call-graph-nsamples call-graph))) - 0))) + (*print-pretty* nil) + (total-count 0) + (total-percent 0) + (min-count (if min-percent + (round (* (/ min-percent 100.0) + (call-graph-nsamples call-graph))) + 0))) (when print-header (print-call-graph-header call-graph)) (format t "~& Self Cumul Total~%") (format t "~& Nr Count % Count % Count % Function~%") (print-separator) (let ((elsewhere-count (call-graph-elsewhere-count call-graph)) - (i 0)) + (i 0)) (dolist (node (call-graph-flat-nodes call-graph)) - (when (or (and max (> (incf i) max)) - (< (node-count node) min-count)) - (return)) - (let* ((count (node-count node)) - (percent (samples-percent call-graph count)) - (accrued-count (node-accrued-count node)) - (accrued-percent (samples-percent call-graph accrued-count))) - (incf total-count count) - (incf total-percent percent) - (format t "~&~4d ~6d ~5,1f ~6d ~5,1f ~6d ~5,1f ~s~%" - (node-index node) - count - percent - accrued-count - accrued-percent - total-count - total-percent - (node-name node)) - (finish-output))) + (when (or (and max (> (incf i) max)) + (< (node-count node) min-count)) + (return)) + (let* ((count (node-count node)) + (percent (samples-percent call-graph count)) + (accrued-count (node-accrued-count node)) + (accrued-percent (samples-percent call-graph accrued-count))) + (incf total-count count) + (incf total-percent percent) + (format t "~&~4d ~6d ~5,1f ~6d ~5,1f ~6d ~5,1f ~s~%" + (node-index node) + count + percent + accrued-count + accrued-percent + total-count + total-percent + (node-name node)) + (finish-output))) (print-separator) (format t "~& ~6d ~5,1f elsewhere~%" - elsewhere-count - (samples-percent call-graph elsewhere-count))))) + elsewhere-count + (samples-percent call-graph elsewhere-count))))) (defun print-cycles (call-graph) (when (some #'cycle-p (graph-vertices call-graph)) @@ -1065,66 +1065,66 @@ (format t "~& Count % Parts~%") (do-vertices (node call-graph) (when (cycle-p node) - (flet ((print-info (indent index count percent name) - (format t "~&~6d ~5,1f ~11@t ~V@t ~s [~d]~%" - count percent indent name index))) - (print-separator) - (format t "~&~6d ~5,1f ~a...~%" - (node-count node) - (samples-percent call-graph (cycle-count node)) - (node-name node)) - (dolist (v (vertex-scc-vertices node)) - (print-info 4 (node-index v) (node-count v) + (flet ((print-info (indent index count percent name) + (format t "~&~6d ~5,1f ~11@t ~V@t ~s [~d]~%" + count percent indent name index))) + (print-separator) + (format t "~&~6d ~5,1f ~a...~%" + (node-count node) + (samples-percent call-graph (cycle-count node)) + (node-name node)) + (dolist (v (vertex-scc-vertices node)) + (print-info 4 (node-index v) (node-count v) (samples-percent call-graph (node-count v)) (node-name v)))))) (print-separator) (format t "~2%"))) (defun print-graph (call-graph &key (stream *standard-output*) - max min-percent) + max min-percent) (let ((*standard-output* stream) - (*print-pretty* nil)) + (*print-pretty* nil)) (print-call-graph-header call-graph) (print-cycles call-graph) (flet ((find-call (from to) - (find to (node-edges from) :key #'call-vertex)) - (print-info (indent index count percent name) - (format t "~&~6d ~5,1f ~11@t ~V@t ~s [~d]~%" - count percent indent name index))) + (find to (node-edges from) :key #'call-vertex)) + (print-info (indent index count percent name) + (format t "~&~6d ~5,1f ~11@t ~V@t ~s [~d]~%" + count percent indent name index))) (format t "~& Callers~%") (format t "~& Cumul. Function~%") (format t "~& Count % Count % Callees~%") (do-vertices (node call-graph) - (print-separator) - ;; - ;; Print caller information. - (dolist (caller (node-callers node)) - (let ((call (find-call caller node))) - (print-info 4 (node-index caller) + (print-separator) + ;; + ;; Print caller information. + (dolist (caller (node-callers node)) + (let ((call (find-call caller node))) + (print-info 4 (node-index caller) (call-count call) (samples-percent call-graph (call-count call)) (node-name caller)))) - ;; Print the node itself. - (format t "~&~6d ~5,1f ~6d ~5,1f ~s [~d]~%" - (node-count node) - (samples-percent call-graph (node-count node)) - (node-accrued-count node) - (samples-percent call-graph (node-accrued-count node)) - (node-name node) - (node-index node)) - ;; Print callees. - (do-edges (call called node) - (print-info 4 (node-index called) + ;; Print the node itself. + (format t "~&~6d ~5,1f ~6d ~5,1f ~s [~d]~%" + (node-count node) + (samples-percent call-graph (node-count node)) + (node-accrued-count node) + (samples-percent call-graph (node-accrued-count node)) + (node-name node) + (node-index node)) + ;; Print callees. + (do-edges (call called node) + (print-info 4 (node-index called) (call-count call) (samples-percent call-graph (call-count call)) (node-name called)))) (print-separator) (format t "~2%") (print-flat call-graph :stream stream :max max - :min-percent min-percent :print-header nil)))) + :min-percent min-percent :print-header nil)))) (defun report (&key (type :graph) max min-percent call-graph - (stream *standard-output*) ((:show-progress *show-progress*))) + (stream *standard-output*) ((:show-progress *show-progress*))) "Report statistical profiling results. The following keyword args are recognized: @@ -1168,17 +1168,17 @@ (declare (ignore chunk stream)) (unless (zerop *samples-index*) (let* ((location - (+ (sb-disassem::seg-virtual-location - (sb-disassem:dstate-segment dstate)) - (sb-disassem::dstate-cur-offs dstate))) - (samples (loop for x from 0 below *samples-index* by +sample-size+ - summing (if (= (aref *samples* x) location) - 1 - 0)))) + (+ (sb-disassem::seg-virtual-location + (sb-disassem:dstate-segment dstate)) + (sb-disassem::dstate-cur-offs dstate))) + (samples (loop for x from 0 below *samples-index* by +sample-size+ + summing (if (= (aref *samples* x) location) + 1 + 0)))) (unless (zerop samples) - (sb-disassem::note (format nil "~A/~A samples" - samples (/ *samples-index* +sample-size+)) - dstate))))) + (sb-disassem::note (format nil "~A/~A samples" + samples (/ *samples-index* +sample-size+)) + dstate))))) (pushnew 'add-disassembly-profile-note sb-disassem::*default-dstate-hooks*) diff --git a/contrib/stale-symbols.lisp b/contrib/stale-symbols.lisp index 374e836..e59e795 100644 --- a/contrib/stale-symbols.lisp +++ b/contrib/stale-symbols.lisp @@ -44,12 +44,12 @@ ((sb-c::compiled-debug-fun-p obj) (format stream "#" (sb-c::compiled-debug-fun-name obj))) - ((sb-kernel:code-component-p obj) - (format stream "#" - (let ((dinfo (sb-kernel:%code-debug-info obj))) - (cond - ((eq dinfo :bogus-lra) "BOGUS-LRA") - (t (sb-c::debug-info-name dinfo)))))) + ((sb-kernel:code-component-p obj) + (format stream "#" + (let ((dinfo (sb-kernel:%code-debug-info obj))) + (cond + ((eq dinfo :bogus-lra) "BOGUS-LRA") + (t (sb-c::debug-info-name dinfo)))))) (t (format stream "~w" obj)))) @@ -57,8 +57,8 @@ (declare (type symbol obj)) (let ((package (symbol-package obj))) (and package - (eq (nth-value 1 (find-symbol (symbol-name obj) package)) - :external)))) + (eq (nth-value 1 (find-symbol (symbol-name obj) package)) + :external)))) (defun find-stale-objects () (dolist (space '(:static :dynamic :read-only)) @@ -67,34 +67,34 @@ (declare (optimize (safety 0)) (ignore size)) (block mapper - (when (eql type sb-vm:symbol-header-widetag) - (ignore-errors - (let ((refs (let ((res nil) - (count 0)) - (dolist (space '(:static :dynamic :read-only)) - (sb-vm::map-referencing-objects - (lambda (o) - (when (> (incf count) 1) - (return-from mapper nil)) - (push (cons space o) res)) - space obj)) - res))) - (let ((externalp (external-symbol-p obj))) - (format t "~:[S~;External s~]ymbol ~:[#~;~:*~A:~]~2:*~:[:~;~]~*~A~%" - externalp - (and (symbol-package obj) - (package-name (symbol-package obj))) - (symbol-name obj))) - (if (null refs) - (progn (princ " No references found") (terpri)) - (progn - (ecase (caar refs) - (:read-only - (princ " Reference in read-only space: ")) - (:static - (princ " Reference in static space: ")) - (:dynamic - (princ " Reference in dynamic space: "))) - (print-stale-reference (cdar refs) t) - (terpri)))))))) + (when (eql type sb-vm:symbol-header-widetag) + (ignore-errors + (let ((refs (let ((res nil) + (count 0)) + (dolist (space '(:static :dynamic :read-only)) + (sb-vm::map-referencing-objects + (lambda (o) + (when (> (incf count) 1) + (return-from mapper nil)) + (push (cons space o) res)) + space obj)) + res))) + (let ((externalp (external-symbol-p obj))) + (format t "~:[S~;External s~]ymbol ~:[#~;~:*~A:~]~2:*~:[:~;~]~*~A~%" + externalp + (and (symbol-package obj) + (package-name (symbol-package obj))) + (symbol-name obj))) + (if (null refs) + (progn (princ " No references found") (terpri)) + (progn + (ecase (caar refs) + (:read-only + (princ " Reference in read-only space: ")) + (:static + (princ " Reference in static space: ")) + (:dynamic + (princ " Reference in dynamic space: "))) + (print-stale-reference (cdar refs) t) + (terpri)))))))) space))) diff --git a/doc/manual/docstrings.lisp b/doc/manual/docstrings.lisp index 2ee1dda..3e9b54c 100644 --- a/doc/manual/docstrings.lisp +++ b/doc/manual/docstrings.lisp @@ -94,13 +94,13 @@ you deserve to lose.") (defun flatten (list) (cond ((null list) - nil) - ((consp (car list)) - (nconc (flatten (car list)) (flatten (cdr list)))) - ((null (cdr list)) - (cons (car list) nil)) - (t - (cons (car list) (flatten (cdr list)))))) + nil) + ((consp (car list)) + (nconc (flatten (car list)) (flatten (cdr list)))) + ((null (cdr list)) + (cons (car list) nil)) + (t + (cons (car list) (flatten (cdr list)))))) (defun whitespacep (char) (find char #(#\tab #\space #\page))) @@ -120,15 +120,15 @@ you deserve to lose.") (defun specialized-lambda-list (method) ;; courtecy of AMOP p. 61 (let* ((specializers (method-specializers method)) - (lambda-list (method-lambda-list method)) - (n-required (length specializers))) + (lambda-list (method-lambda-list method)) + (n-required (length specializers))) (append (mapcar (lambda (arg specializer) - (if (eq specializer (find-class 't)) - arg - `(,arg ,(specializer-name specializer)))) - (subseq lambda-list 0 n-required) - specializers) - (subseq lambda-list n-required)))) + (if (eq specializer (find-class 't)) + arg + `(,arg ,(specializer-name specializer)))) + (subseq lambda-list 0 n-required) + specializers) + (subseq lambda-list n-required)))) (defun string-lines (string) "Lines in STRING as a vector." @@ -152,9 +152,9 @@ you deserve to lose.") up filename handling. See `*character-replacements*' and `*characters-to-drop*' for customization." (let ((name (remove-if (lambda (x) (member x *characters-to-drop*)) - (if (listp original) - (flatten-to-string original) - (string original)))) + (if (listp original) + (flatten-to-string original) + (string original)))) (chars-to-replace (mapcar #'car *character-replacements*))) (flet ((replacement-delimiter (index) (cond ((or (< index 0) (>= index (length name))) "") @@ -211,9 +211,9 @@ symbols or lists of symbols.")) (defmethod name-using-kind/name ((kind (eql 'method)) name doc) (format nil "~A~{ ~A~} ~A" - (name-using-kind/name nil (first name) doc) - (second name) - (third name))) + (name-using-kind/name nil (first name) doc) + (second name) + (third name))) (defun node-name (doc) "Returns TexInfo node name as a string for a DOCUMENTATION instance." @@ -239,8 +239,8 @@ symbols or lists of symbols.")) (defmethod title-using-kind/name ((kind (eql 'method)) name doc) (format nil "~{~A ~}~A" - (second name) - (title-using-kind/name nil (first name) doc))) + (second name) + (title-using-kind/name nil (first name) doc))) (defun title-name (doc) "Returns a string to be used as name of the definition." @@ -248,17 +248,17 @@ symbols or lists of symbols.")) (defun include-pathname (doc) (let* ((kind (get-kind doc)) - (name (nstring-downcase - (if (eq 'package kind) - (format nil "package-~A" (alphanumize (get-name doc))) - (format nil "~A-~A-~A" - (case (get-kind doc) - ((function generic-function) "fun") - (structure "struct") - (variable "var") - (otherwise (symbol-name (get-kind doc)))) - (alphanumize (package-name (get-package doc))) - (alphanumize (get-name doc))))))) + (name (nstring-downcase + (if (eq 'package kind) + (format nil "package-~A" (alphanumize (get-name doc))) + (format nil "~A-~A-~A" + (case (get-kind doc) + ((function generic-function) "fun") + (structure "struct") + (variable "var") + (otherwise (symbol-name (get-kind doc)))) + (alphanumize (package-name (get-package doc))) + (alphanumize (get-name doc))))))) (make-pathname :name name :type "texinfo"))) ;;;; documentation class and related methods @@ -275,69 +275,69 @@ symbols or lists of symbols.")) (defmethod make-documentation ((x package) doc-type string) (declare (ignore doc-type)) (make-instance 'documentation - :name (name x) - :kind 'package - :string string)) + :name (name x) + :kind 'package + :string string)) (defmethod make-documentation (x (doc-type (eql 'function)) string) (declare (ignore doc-type)) (let* ((fdef (and (fboundp x) (fdefinition x))) - (name x) - (kind (cond ((and (symbolp x) (special-operator-p x)) - 'special-operator) - ((and (symbolp x) (macro-function x)) - 'macro) - ((typep fdef 'generic-function) - (assert (or (symbolp name) (setf-name-p name))) - 'generic-function) - (t - (assert (or (symbolp name) (setf-name-p name))) - 'function))) - (children (when (eq kind 'generic-function) - (collect-gf-documentation fdef)))) + (name x) + (kind (cond ((and (symbolp x) (special-operator-p x)) + 'special-operator) + ((and (symbolp x) (macro-function x)) + 'macro) + ((typep fdef 'generic-function) + (assert (or (symbolp name) (setf-name-p name))) + 'generic-function) + (t + (assert (or (symbolp name) (setf-name-p name))) + 'function))) + (children (when (eq kind 'generic-function) + (collect-gf-documentation fdef)))) (make-instance 'documentation - :name (name x) - :string string - :kind kind - :children children))) + :name (name x) + :string string + :kind kind + :children children))) (defmethod make-documentation ((x method) doc-type string) (declare (ignore doc-type)) (make-instance 'documentation - :name (name x) - :kind 'method - :string string)) + :name (name x) + :kind 'method + :string string)) (defmethod make-documentation (x (doc-type (eql 'type)) string) (make-instance 'documentation - :name (name x) - :string string - :kind (etypecase (find-class x nil) - (structure-class 'structure) - (standard-class 'class) - (sb-pcl::condition-class 'condition) - ((or built-in-class null) 'type)))) + :name (name x) + :string string + :kind (etypecase (find-class x nil) + (structure-class 'structure) + (standard-class 'class) + (sb-pcl::condition-class 'condition) + ((or built-in-class null) 'type)))) (defmethod make-documentation (x (doc-type (eql 'variable)) string) (make-instance 'documentation - :name (name x) - :string string - :kind (if (constantp x) - 'constant - 'variable))) + :name (name x) + :string string + :kind (if (constantp x) + 'constant + 'variable))) (defmethod make-documentation (x (doc-type (eql 'setf)) string) (declare (ignore doc-type)) (make-instance 'documentation - :name (name x) - :kind 'setf-expander - :string string)) + :name (name x) + :kind 'setf-expander + :string string)) (defmethod make-documentation (x doc-type string) (make-instance 'documentation - :name (name x) - :kind doc-type - :string string)) + :name (name x) + :kind doc-type + :string string)) (defun maybe-documentation (x doc-type) "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if @@ -347,45 +347,45 @@ there is no corresponding docstring." (make-documentation x doc-type docstring)))) (defun lambda-list (doc) - (case (get-kind doc) + (case (get-kind doc) ((package constant variable type structure class condition) nil) (method (third (get-name doc))) (t ;; KLUDGE: Eugh. - ;; + ;; ;; believe it or not, the above comment was written before CSR ;; came along and obfuscated this. (2005-07-04) (when (symbolp (get-name doc)) (labels ((clean (x &key optional key) - (typecase x - (atom x) - ((cons (member &optional)) - (cons (car x) (clean (cdr x) :optional t))) - ((cons (member &key)) - (cons (car x) (clean (cdr x) :key t))) - ((cons cons) - (cons - (cond (key (if (consp (caar x)) - (caaar x) - (caar x))) - (optional (caar x)) - (t (clean (car x)))) - (clean (cdr x) :key key :optional optional))) - (cons - (cons - (cond ((or key optional) (car x)) - (t (clean (car x)))) - (clean (cdr x) :key key :optional optional)))))) - (clean (sb-introspect:function-arglist (get-name doc)))))))) + (typecase x + (atom x) + ((cons (member &optional)) + (cons (car x) (clean (cdr x) :optional t))) + ((cons (member &key)) + (cons (car x) (clean (cdr x) :key t))) + ((cons cons) + (cons + (cond (key (if (consp (caar x)) + (caaar x) + (caar x))) + (optional (caar x)) + (t (clean (car x)))) + (clean (cdr x) :key key :optional optional))) + (cons + (cons + (cond ((or key optional) (car x)) + (t (clean (car x)))) + (clean (cdr x) :key key :optional optional)))))) + (clean (sb-introspect:function-arglist (get-name doc)))))))) (defun documentation< (x y) (let ((p1 (position (get-kind x) *ordered-documentation-kinds*)) - (p2 (position (get-kind y) *ordered-documentation-kinds*))) - (if (or (not (and p1 p2)) (= p1 p2)) - (string< (string (get-name x)) (string (get-name y))) - (< p1 p2)))) + (p2 (position (get-kind y) *ordered-documentation-kinds*))) + (if (or (not (and p1 p2)) (= p1 p2)) + (string< (string (get-name x)) (string (get-name y))) + (< p1 p2)))) ;;;; turning text into texinfo @@ -393,10 +393,10 @@ there is no corresponding docstring." "Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped with #\@. Optionally downcase the result." (let ((result (with-output-to-string (s) - (loop for char across string - when (find char *texinfo-escaped-chars*) - do (write-char #\@ s) - do (write-char char s))))) + (loop for char across string + when (find char *texinfo-escaped-chars*) + do (write-char #\@ s) + do (write-char char s))))) (if downcasep (nstring-downcase result) result))) (defun empty-p (line-number lines) @@ -449,7 +449,7 @@ variables if the symbol in question is contained in symbols (write-string (subseq line last (first symbol/index)) result) (let ((symbol-name (apply #'subseq line symbol/index))) (format result (if (member symbol-name *texinfo-variables* - :test #'string=) + :test #'string=) "@var{~A}" "@code{~A}") (string-downcase symbol-name))) @@ -464,15 +464,15 @@ ie. if it starts with whitespace followed by a paren or semicolon, and the previous line is empty" (let ((offset (indentation line))) (and offset - (plusp offset) - (find (find-if-not #'whitespacep line) "(;") - (empty-p (1- line-number) lines)))) + (plusp offset) + (find (find-if-not #'whitespacep line) "(;") + (empty-p (1- line-number) lines)))) (defun collect-lisp-section (lines line-number) (let ((lisp (loop for index = line-number then (1+ index) - for line = (and (< index (length lines)) (svref lines index)) - while (indentation line) - collect line))) + for line = (and (< index (length lines)) (svref lines index)) + while (indentation line) + collect line))) (values (length lisp) `("@lisp" ,@lisp "@end lisp")))) ;;; itemized sections @@ -481,12 +481,12 @@ semicolon, and the previous line is empty" "Return NIL or the indentation offset if LINE looks like it starts an item in an itemization." (let* ((offset (indentation line)) - (char (when offset (char line offset)))) + (char (when offset (char line offset)))) (and offset - (member char *itemize-start-characters* :test #'char=) - (char= #\Space (find-if-not (lambda (c) (char= c char)) - line :start offset)) - offset))) + (member char *itemize-start-characters* :test #'char=) + (char= #\Space (find-if-not (lambda (c) (char= c char)) + line :start offset)) + offset))) (defun collect-maybe-itemized-section (lines starting-line) ;; Return index of next line to be processed outside @@ -504,7 +504,7 @@ an item in an itemization." (incf lines-consumed)) ((and offset (> indentation this-offset)) ;; nested itemization -- handle recursively - ;; FIXME: tables in itemizations go wrong + ;; FIXME: tables in itemizations go wrong (multiple-value-bind (sub-lines-consumed sub-itemization) (collect-maybe-itemized-section lines line-number) (when sub-lines-consumed @@ -526,8 +526,8 @@ an item in an itemization." (loop-finish)))) ;; a single-line itemization isn't. (if (> (count-if (lambda (line) (> (length line) 0)) result) 1) - (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize")) - nil))) + (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize")) + nil))) ;;; table sections @@ -538,14 +538,14 @@ an item in an itemization." (defun tabulation-p (offset line-number lines direction) (let ((step (ecase direction - (:backwards (1- line-number)) - (:forwards (1+ line-number))))) + (:backwards (1- line-number)) + (:forwards (1+ line-number))))) (when (and (plusp line-number) (< line-number (length lines))) (and (eql offset (indentation (svref lines line-number))) - (or (when (eq direction :backwards) - (empty-p step lines)) - (tabulation-p offset step lines direction) - (tabulation-body-p offset step lines)))))) + (or (when (eq direction :backwards) + (empty-p step lines)) + (tabulation-p offset step lines direction) + (tabulation-body-p offset step lines)))))) (defun maybe-table-offset (line-number lines) "Return NIL or the indentation offset if LINE looks like it starts @@ -553,16 +553,16 @@ an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an empty line, another tabulation label, or a tabulation body, (3) and followed another tabulation label or a tabulation body." (let* ((line (svref lines line-number)) - (offset (indentation line)) - (prev (1- line-number)) - (next (1+ line-number))) + (offset (indentation line)) + (prev (1- line-number)) + (next (1+ line-number))) (when (and offset (plusp offset)) (and (or (empty-p prev lines) - (tabulation-body-p offset prev lines) - (tabulation-p offset prev lines :backwards)) - (or (tabulation-body-p offset next lines) - (tabulation-p offset next lines :forwards)) - offset)))) + (tabulation-body-p offset prev lines) + (tabulation-p offset prev lines :backwards)) + (or (tabulation-body-p offset next lines) + (tabulation-p offset next lines :forwards)) + offset)))) ;;; FIXME: This and itemization are very similar: could they share ;;; some code, mayhap? @@ -573,36 +573,36 @@ followed another tabulation label or a tabulation body." (result nil) (lines-consumed 0)) (loop for line-number from starting-line below (length lines) - for line = (svref lines line-number) - for indentation = (indentation line) - for offset = (maybe-table-offset line-number lines) - do (cond - ((not indentation) - ;; empty line -- inserts paragraph. - (push "" result) - (incf lines-consumed)) - ((and offset (= indentation this-offset)) - ;; start of new item, or continuation of previous item - (if (and result (search "@item" (car result) :test #'char=)) - (push (format nil "@itemx ~A" (texinfo-line line)) - result) - (progn - (push "" result) - (push (format nil "@item ~A" (texinfo-line line)) - result))) - (incf lines-consumed)) - ((> indentation this-offset) - ;; continued item from previous line - (push (texinfo-line line) result) - (incf lines-consumed)) - (t - ;; end of itemization - (loop-finish)))) + for line = (svref lines line-number) + for indentation = (indentation line) + for offset = (maybe-table-offset line-number lines) + do (cond + ((not indentation) + ;; empty line -- inserts paragraph. + (push "" result) + (incf lines-consumed)) + ((and offset (= indentation this-offset)) + ;; start of new item, or continuation of previous item + (if (and result (search "@item" (car result) :test #'char=)) + (push (format nil "@itemx ~A" (texinfo-line line)) + result) + (progn + (push "" result) + (push (format nil "@item ~A" (texinfo-line line)) + result))) + (incf lines-consumed)) + ((> indentation this-offset) + ;; continued item from previous line + (push (texinfo-line line) result) + (incf lines-consumed)) + (t + ;; end of itemization + (loop-finish)))) ;; a single-line table isn't. (if (> (count-if (lambda (line) (> (length line) 0)) result) 1) - (values lines-consumed - `("" "@table @emph" ,@(reverse result) "@end table" "")) - nil))) + (values lines-consumed + `("" "@table @emph" ,@(reverse result) "@end table" "")) + nil))) ;;; section markup @@ -610,27 +610,27 @@ followed another tabulation label or a tabulation body." `(multiple-value-bind (count collected) (progn ,@forms) (when count (dolist (line collected) - (write-line line *texinfo-output*)) + (write-line line *texinfo-output*)) (incf ,index (1- count))))) (defun write-texinfo-string (string &optional lambda-list) "Try to guess as much formatting for a raw docstring as possible." (let ((*texinfo-variables* (flatten lambda-list)) - (lines (string-lines (escape-for-texinfo string nil)))) + (lines (string-lines (escape-for-texinfo string nil)))) (loop for line-number from 0 below (length lines) - for line = (svref lines line-number) - do (cond - ((with-maybe-section line-number - (and (lisp-section-p line line-number lines) - (collect-lisp-section lines line-number)))) - ((with-maybe-section line-number - (and (maybe-itemize-offset line) - (collect-maybe-itemized-section lines line-number)))) - ((with-maybe-section line-number - (and (maybe-table-offset line-number lines) - (collect-maybe-table-section lines line-number)))) - (t - (write-line (texinfo-line line) *texinfo-output*)))))) + for line = (svref lines line-number) + do (cond + ((with-maybe-section line-number + (and (lisp-section-p line line-number lines) + (collect-lisp-section lines line-number)))) + ((with-maybe-section line-number + (and (maybe-itemize-offset line) + (collect-maybe-itemized-section lines line-number)))) + ((with-maybe-section line-number + (and (maybe-table-offset line-number lines) + (collect-maybe-table-section lines line-number)))) + (t + (write-line (texinfo-line line) *texinfo-output*)))))) ;;;; texinfo formatting tools @@ -641,24 +641,24 @@ followed another tabulation label or a tabulation body." ;; classes in CP-lists, unless the symbol we're documenting is ;; internal as well. (and (member super-package #.'(mapcar #'find-package *undocumented-packages*)) - (not (eq super-package (symbol-package class-name)))) + (not (eq super-package (symbol-package class-name)))) ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them ;; simply as a matter of convenience. The assumption here is that ;; the inheritance is incidental unless the name of the condition ;; begins with SIMPLE-. (and (member super-name '(simple-error simple-condition)) - (let ((prefix "SIMPLE-")) - (mismatch prefix (string class-name) :end2 (length prefix))) - t ; don't return number from MISMATCH - )))) + (let ((prefix "SIMPLE-")) + (mismatch prefix (string class-name) :end2 (length prefix))) + t ; don't return number from MISMATCH + )))) (defun hide-slot-p (symbol slot) ;; FIXME: There is no pricipal reason to avoid the slot docs fo ;; structures and conditions, but their DOCUMENTATION T doesn't ;; currently work with them the way we'd like. (not (and (typep (find-class symbol nil) 'standard-class) - (docstring slot t)))) + (docstring slot t)))) (defun texinfo-anchor (doc) (format *texinfo-output* "@anchor{~A}~%" (node-name doc))) @@ -667,16 +667,16 @@ followed another tabulation label or a tabulation body." (defun texinfo-begin (doc &aux *print-pretty*) (let ((kind (get-kind doc))) (format *texinfo-output* "@~A {~:(~A~)} ~(~A~@[ ~{~A~^ ~}~]~)~%" - (case kind - ((package constant variable) - "defvr") - ((structure class condition type) - "deftp") - (t - "deffn")) - (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind)) - (title-name doc) - (lambda-list doc)))) + (case kind + ((package constant variable) + "defvr") + ((structure class condition type) + "deftp") + (t + "deffn")) + (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind)) + (title-name doc) + (lambda-list doc)))) (defun texinfo-index (doc) (let ((title (title-name doc))) @@ -693,31 +693,31 @@ followed another tabulation label or a tabulation body." (let ((name (get-name doc))) ;; class precedence list (format *texinfo-output* "Class precedence list: @code{~(~{@w{~A}~^, ~}~)}~%~%" - (remove-if (lambda (class) (hide-superclass-p name class)) - (mapcar #'class-name (class-precedence-list (find-class name))))) + (remove-if (lambda (class) (hide-superclass-p name class)) + (mapcar #'class-name (class-precedence-list (find-class name))))) ;; slots (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot)) - (class-direct-slots (find-class name))))) - (when slots - (format *texinfo-output* "Slots:~%@itemize~%") - (dolist (slot slots) - (format *texinfo-output* "@item ~(@code{~A} ~ + (class-direct-slots (find-class name))))) + (when slots + (format *texinfo-output* "Slots:~%@itemize~%") + (dolist (slot slots) + (format *texinfo-output* "@item ~(@code{~A} ~ ~@[--- initargs: @code{~{@w{~S}~^, ~}}~]~)~%~%" - (slot-definition-name slot) - (slot-definition-initargs slot)) - ;; FIXME: Would be neater to handler as children - (write-texinfo-string (docstring slot t))) - (format *texinfo-output* "@end itemize~%~%")))))) + (slot-definition-name slot) + (slot-definition-initargs slot)) + ;; FIXME: Would be neater to handler as children + (write-texinfo-string (docstring slot t))) + (format *texinfo-output* "@end itemize~%~%")))))) (defun texinfo-body (doc) (write-texinfo-string (get-string doc))) (defun texinfo-end (doc) (write-line (case (get-kind doc) - ((package variable constant) "@end defvr") - ((structure type class condition) "@end deftp") - (t "@end deffn")) - *texinfo-output*)) + ((package variable constant) "@end defvr") + ((structure type class condition) "@end deftp") + (t "@end deffn")) + *texinfo-output*)) (defun write-texinfo (doc) "Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*." @@ -735,22 +735,22 @@ followed another tabulation label or a tabulation body." (defun collect-gf-documentation (gf) "Collects method documentation for the generic function GF" (loop for method in (generic-function-methods gf) - for doc = (maybe-documentation method t) - when doc - collect doc)) + for doc = (maybe-documentation method t) + when doc + collect doc)) (defun collect-name-documentation (name) (loop for type in *documentation-types* - for doc = (maybe-documentation name type) - when doc - collect doc)) + for doc = (maybe-documentation name type) + when doc + collect doc)) (defun collect-symbol-documentation (symbol) "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of the form DOC instances. See `*documentation-types*' for the possible values of doc-type." (nconc (collect-name-documentation symbol) - (collect-name-documentation (list 'setf symbol)))) + (collect-name-documentation (list 'setf symbol)))) (defun collect-documentation (package) "Collects all documentation for all external symbols of the given @@ -762,14 +762,14 @@ package, as well as for the package itself." (setf docs (nconc (collect-symbol-documentation symbol) docs))) (let ((doc (maybe-documentation *documentation-package* t))) (when doc - (push doc docs))) + (push doc docs))) docs)) (defmacro with-texinfo-file (pathname &body forms) `(with-open-file (*texinfo-output* ,pathname - :direction :output - :if-does-not-exist :create - :if-exists :supersede) + :direction :output + :if-does-not-exist :create + :if-exists :supersede) ,@forms)) (defun generate-includes (directory &rest packages) @@ -785,9 +785,9 @@ markup, you lose." (let ((directory (merge-pathnames (pathname directory)))) (ensure-directories-exist directory) (dolist (package packages) - (dolist (doc (collect-documentation (find-package package))) - (with-texinfo-file (merge-pathnames (include-pathname doc) directory) - (write-texinfo doc)))) + (dolist (doc (collect-documentation (find-package package))) + (with-texinfo-file (merge-pathnames (include-pathname doc) directory) + (write-texinfo doc)))) directory))) (defun document-package (package &optional filename) @@ -801,11 +801,11 @@ syntax-significant characters are escaped in symbol names, but if a docstring contains invalid Texinfo markup, you lose." (handler-bind ((warning #'muffle-warning)) (let* ((package (find-package package)) - (filename (or filename (make-pathname - :name (string-downcase (package-name package)) - :type "texinfo"))) - (docs (sort (collect-documentation package) #'documentation<))) + (filename (or filename (make-pathname + :name (string-downcase (package-name package)) + :type "texinfo"))) + (docs (sort (collect-documentation package) #'documentation<))) (with-texinfo-file filename - (dolist (doc docs) - (write-texinfo doc))) + (dolist (doc docs) + (write-texinfo doc))) filename))) diff --git a/src/assembly/alpha/arith.lisp b/src/assembly/alpha/arith.lisp index 80094f2..52f0265 100644 --- a/src/assembly/alpha/arith.lisp +++ b/src/assembly/alpha/arith.lisp @@ -12,36 +12,36 @@ (in-package "SB!VM") (define-assembly-routine (generic-+ - (:cost 10) - (:return-style :full-call) - (:translate +) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp temp2 non-descriptor-reg nl1-offset) - (:temp temp3 non-descriptor-reg nl2-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:translate +) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp temp3 non-descriptor-reg nl2-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst and x 3 temp) (inst bne temp DO-STATIC-FUN) (inst and y 3 temp) (inst bne temp DO-STATIC-FUN) (inst addq x y res) - + ; Check whether we need a bignum. (inst sra res 31 temp) (inst beq temp DONE) (inst not temp temp) (inst beq temp DONE) (inst sra res 2 temp3) - + ; from move-from-signed (inst li 2 temp2) (inst sra temp3 31 temp) @@ -50,7 +50,7 @@ (inst cmoveq temp 1 temp2) (inst sll temp2 n-widetag-bits temp2) (inst bis temp2 bignum-widetag temp2) - + (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3))) (inst bis alloc-tn other-pointer-lowtag res) (storew temp2 res 0 other-pointer-lowtag) @@ -69,36 +69,36 @@ (define-assembly-routine (generic-- - (:cost 10) - (:return-style :full-call) - (:translate -) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp temp2 non-descriptor-reg nl1-offset) - (:temp temp3 non-descriptor-reg nl2-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:translate -) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp temp3 non-descriptor-reg nl2-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst and x 3 temp) (inst bne temp DO-STATIC-FUN) (inst and y 3 temp) (inst bne temp DO-STATIC-FUN) (inst subq x y res) - + ; Check whether we need a bignum. (inst sra res 31 temp) (inst beq temp DONE) (inst not temp temp) (inst beq temp DONE) (inst sra res 2 temp3) - + ; from move-from-signed (inst li 2 temp2) (inst sra temp3 31 temp) @@ -107,7 +107,7 @@ (inst cmoveq temp 1 temp2) (inst sll temp2 n-widetag-bits temp2) (inst bis temp2 bignum-widetag temp2) - + (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3))) (inst bis alloc-tn other-pointer-lowtag res) (storew temp2 res 0 other-pointer-lowtag) @@ -126,24 +126,24 @@ (define-assembly-routine (generic-* - (:cost 25) - (:return-style :full-call) - (:translate *) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lo non-descriptor-reg nl1-offset) - (:temp hi non-descriptor-reg nl2-offset) - (:temp temp2 non-descriptor-reg nl3-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 25) + (:return-style :full-call) + (:translate *) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lo non-descriptor-reg nl1-offset) + (:temp hi non-descriptor-reg nl2-offset) + (:temp temp2 non-descriptor-reg nl3-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) ;; If either arg is not a fixnum, call the static function. (inst and x 3 temp) (inst bne temp DO-STATIC-FUN) @@ -208,25 +208,25 @@ ;;;; division (define-assembly-routine (signed-truncate - (:note "(signed-byte 64) truncate") - (:cost 60) - (:policy :fast-safe) - (:translate truncate) - (:arg-types signed-num signed-num) - (:result-types signed-num signed-num)) - - ((:arg dividend signed-reg nl0-offset) - (:arg divisor signed-reg nl1-offset) - - (:res quo signed-reg nl2-offset) - (:res rem signed-reg nl3-offset) - - (:temp quo-sign signed-reg nl5-offset) - (:temp rem-sign signed-reg nargs-offset) - (:temp temp1 non-descriptor-reg nl4-offset)) - + (:note "(signed-byte 64) truncate") + (:cost 60) + (:policy :fast-safe) + (:translate truncate) + (:arg-types signed-num signed-num) + (:result-types signed-num signed-num)) + + ((:arg dividend signed-reg nl0-offset) + (:arg divisor signed-reg nl1-offset) + + (:res quo signed-reg nl2-offset) + (:res rem signed-reg nl3-offset) + + (:temp quo-sign signed-reg nl5-offset) + (:temp rem-sign signed-reg nargs-offset) + (:temp temp1 non-descriptor-reg nl4-offset)) + (let ((error (generate-error-code nil division-by-zero-error - dividend divisor))) + dividend divisor))) (inst beq divisor error)) (inst xor dividend divisor quo-sign) @@ -271,59 +271,59 @@ (macrolet ((define-cond-assem-rtn (name translate static-fn cmp not-p) `(define-assembly-routine (,name - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate ,translate) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst and x 3 temp) - (inst bne temp DO-STATIC-FN) - (inst and y 3 temp) - (inst beq temp DO-COMPARE) - - DO-STATIC-FN - (inst ldl lip (static-fun-offset ',static-fn) null-tn) - (inst li (fixnumize 2) nargs) - (inst move cfp-tn ocfp) - (inst move csp-tn cfp-tn) - (inst jmp zero-tn lip) - - DO-COMPARE - ,cmp - (inst move null-tn res) - (inst ,(if not-p 'bne 'beq) temp done) - (load-symbol res t) - DONE))) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst and x 3 temp) + (inst bne temp DO-STATIC-FN) + (inst and y 3 temp) + (inst beq temp DO-COMPARE) + + DO-STATIC-FN + (inst ldl lip (static-fun-offset ',static-fn) null-tn) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst move csp-tn cfp-tn) + (inst jmp zero-tn lip) + + DO-COMPARE + ,cmp + (inst move null-tn res) + (inst ,(if not-p 'bne 'beq) temp done) + (load-symbol res t) + DONE))) (define-cond-assem-rtn generic-< < two-arg-< (inst cmplt x y temp) nil) (define-cond-assem-rtn generic-> > two-arg-> (inst cmplt y x temp) nil)) (define-assembly-routine (generic-eql - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate eql) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst cmpeq x y temp) (inst bne temp RETURN-T) (inst and x 3 temp) @@ -346,21 +346,21 @@ (load-symbol res t)) (define-assembly-routine (generic-= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate =) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst and x 3 temp) (inst bne temp DO-STATIC-FN) (inst and y 3 temp) @@ -382,21 +382,21 @@ (load-symbol res t)) (define-assembly-routine (generic-/= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate /=) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate /=) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst and x 3 temp) (inst bne temp DO-STATIC-FN) (inst and y 3 temp) diff --git a/src/assembly/alpha/array.lisp b/src/assembly/alpha/array.lisp index b67466a..f1aefb6 100644 --- a/src/assembly/alpha/array.lisp +++ b/src/assembly/alpha/array.lisp @@ -13,22 +13,22 @@ (define-assembly-routine (allocate-vector - (:policy :fast-safe) - (:translate allocate-vector) - (:arg-types positive-fixnum - positive-fixnum - positive-fixnum)) - ((:arg type any-reg a0-offset) - (:arg length any-reg a1-offset) - (:arg words any-reg a2-offset) - (:res result descriptor-reg a0-offset) - - (:temp ndescr non-descriptor-reg nl0-offset)) + (:policy :fast-safe) + (:translate allocate-vector) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum)) + ((:arg type any-reg a0-offset) + (:arg length any-reg a1-offset) + (:arg words any-reg a2-offset) + (:res result descriptor-reg a0-offset) + + (:temp ndescr non-descriptor-reg nl0-offset)) ;; This is kinda sleezy, changing words like this. But we can because ;; the vop thinks it is temporary. (inst addq words (+ (1- (ash 1 n-lowtag-bits)) - (* vector-data-offset n-word-bytes)) - words) + (* vector-data-offset n-word-bytes)) + words) (inst li (lognot lowtag-mask) ndescr) (inst and words ndescr words) (inst srl type word-shift ndescr) @@ -42,20 +42,20 @@ ;;;; hash primitives #| (define-assembly-routine (sxhash-simple-string - (:translate %sxhash-simple-string) - (:policy :fast-safe) - (:result-types positive-fixnum)) - ((:arg string descriptor-reg a0-offset) - (:res result any-reg a0-offset) + (:translate %sxhash-simple-string) + (:policy :fast-safe) + (:result-types positive-fixnum)) + ((:arg string descriptor-reg a0-offset) + (:res result any-reg a0-offset) - (:temp length any-reg a1-offset) + (:temp length any-reg a1-offset) - (:temp lip interior-reg lip-offset) - (:temp accum non-descriptor-reg nl0-offset) - (:temp data non-descriptor-reg nl1-offset) - (:temp byte non-descriptor-reg nl2-offset) - (:temp retaddr non-descriptor-reg nl3-offset) - (:temp temp1 non-descriptor-reg nl4-offset)) + (:temp lip interior-reg lip-offset) + (:temp accum non-descriptor-reg nl0-offset) + (:temp data non-descriptor-reg nl1-offset) + (:temp byte non-descriptor-reg nl2-offset) + (:temp retaddr non-descriptor-reg nl3-offset) + (:temp temp1 non-descriptor-reg nl4-offset)) ;; These are needed after we jump into sxhash-simple-substring. (progn result lip accum data byte retaddr) @@ -63,30 +63,30 @@ (inst li (make-fixup 'sxhash-simple-substring :assembly-routine) temp1) (loadw length string vector-length-slot other-pointer-lowtag) (inst jmp zero-tn temp1 - (make-fixup 'sxhash-simple-substring :assembly-routine))) + (make-fixup 'sxhash-simple-substring :assembly-routine))) (define-assembly-routine (sxhash-simple-substring - (:translate %sxhash-simple-substring) - (:policy :fast-safe) - (:arg-types * positive-fixnum) - (:result-types positive-fixnum)) - ((:arg string descriptor-reg a0-offset) - (:arg length any-reg a1-offset) - (:res result any-reg a0-offset) - - (:temp lip interior-reg lip-offset) - (:temp accum non-descriptor-reg nl0-offset) - (:temp data non-descriptor-reg nl1-offset) - (:temp byte non-descriptor-reg nl2-offset) - (:temp retaddr non-descriptor-reg nl3-offset)) + (:translate %sxhash-simple-substring) + (:policy :fast-safe) + (:arg-types * positive-fixnum) + (:result-types positive-fixnum)) + ((:arg string descriptor-reg a0-offset) + (:arg length any-reg a1-offset) + (:res result any-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp accum non-descriptor-reg nl0-offset) + (:temp data non-descriptor-reg nl1-offset) + (:temp byte non-descriptor-reg nl2-offset) + (:temp retaddr non-descriptor-reg nl3-offset)) ;; Save the return address (inst subq lip code-tn retaddr) ;; Get a pointer to the data. (inst addq string - (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - lip) + (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + lip) (move zero-tn accum) (inst br zero-tn test) diff --git a/src/assembly/alpha/assem-rtns.lisp b/src/assembly/alpha/assem-rtns.lisp index 615d480..7fedab4 100644 --- a/src/assembly/alpha/assem-rtns.lisp +++ b/src/assembly/alpha/assem-rtns.lisp @@ -67,7 +67,7 @@ (inst subq count (fixnumize 1) count) (inst addq dst n-word-bytes dst) (inst bne count loop) - + (inst br zero-tn done) DEFAULT-A0-AND-ON @@ -82,12 +82,12 @@ DEFAULT-A5-AND-ON (inst move null-tn a5) DONE - + ;; Clear the stack. (move cfp-tn ocfp-tn) (move ocfp cfp-tn) (inst addq ocfp-tn nvals csp-tn) - + ;; Return. (lisp-return lra lip)) @@ -125,7 +125,7 @@ ;; Calculate NARGS (as a fixnum) (inst subq csp-tn args nargs) - + ;; Load the argument regs (must do this now, 'cause the blt might ;; trash these locations) (inst ldl a0 (* 0 n-word-bytes) args) @@ -140,7 +140,7 @@ (inst addq args (* n-word-bytes register-arg-count) src) (inst ble count done) (inst addq cfp-tn (* n-word-bytes register-arg-count) dst) - + LOOP ;; Copy one arg. (inst ldl temp 0 src) @@ -149,7 +149,7 @@ (inst subq count (fixnumize 1) count) (inst addq dst n-word-bytes dst) (inst bgt count loop) - + DONE ;; We are done. Do the jump. (progn @@ -177,15 +177,15 @@ (load-symbol-value cur-uwp *current-unwind-protect-block*) (let ((error (generate-error-code nil invalid-unwind-error))) (inst beq block error)) - + (loadw target-uwp block unwind-block-current-uwp-slot) (inst cmpeq cur-uwp target-uwp temp1) (inst beq temp1 do-uwp) - + (move block cur-uwp) do-exit - + (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) (loadw code-tn cur-uwp unwind-block-current-code-slot) (progn @@ -206,24 +206,24 @@ (:temp catch any-reg a1-offset) (:temp tag descriptor-reg a2-offset) (:temp temp1 non-descriptor-reg nl0-offset)) - + (progn start count) ; We just need them in the registers. (load-symbol-value catch *current-catch-block*) - + loop - + (let ((error (generate-error-code nil unseen-throw-tag-error target))) (inst beq catch error)) - + (loadw tag catch catch-block-tag-slot) (inst cmpeq tag target temp1) (inst bne temp1 exit) (loadw catch catch catch-block-previous-catch-slot) (inst br zero-tn loop) - + exit - + (move catch target) (inst li (make-fixup 'unwind :assembly-routine) temp1) (inst jmp zero-tn temp1 (make-fixup 'unwind :assembly-routine))) diff --git a/src/assembly/alpha/support.lisp b/src/assembly/alpha/support.lisp index a2ef297..9e75098 100644 --- a/src/assembly/alpha/support.lisp +++ b/src/assembly/alpha/support.lisp @@ -16,41 +16,41 @@ ((:raw :none) (values `((inst li (make-fixup ',name :assembly-routine) temp) - (inst jsr lip-tn temp)) + (inst jsr lip-tn temp)) '((:temporary (:sc non-descriptor-reg) temp)) nil)) (:full-call (let ((temp (make-symbol "TEMP")) - (nfp-save (make-symbol "NFP-SAVE")) - (lra (make-symbol "LRA"))) + (nfp-save (make-symbol "NFP-SAVE")) + (lra (make-symbol "LRA"))) (values - `((let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn ,vop))) - (when cur-nfp - (store-stack-tn ,nfp-save cur-nfp)) - (inst compute-lra-from-code ,lra code-tn lra-label ,temp) - (note-next-instruction ,vop :call-site) - ; here - (inst li (make-fixup ',name :assembly-routine) temp1) - (inst jsr lip-tn temp1 (make-fixup ',name :assembly-routine)) - (emit-return-pc lra-label) - (note-this-location ,vop :single-value-return) - (without-scheduling () - (move ocfp-tn csp-tn) - (inst nop)) - (inst compute-code-from-lra code-tn code-tn - lra-label ,temp) - (when cur-nfp - (maybe-load-stack-nfp-tn cur-nfp ,nfp-save temp1)))) - `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) - ,temp) - (:temporary (:sc descriptor-reg :offset lra-offset - :from (:eval 0) :to (:eval 1)) - ,lra) - (:temporary (:scs (control-stack) :offset nfp-save-offset) - ,nfp-save) - (:temporary (:scs (non-descriptor-reg)) temp1) - (:save-p t))))))) + `((let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn ,vop))) + (when cur-nfp + (store-stack-tn ,nfp-save cur-nfp)) + (inst compute-lra-from-code ,lra code-tn lra-label ,temp) + (note-next-instruction ,vop :call-site) + ; here + (inst li (make-fixup ',name :assembly-routine) temp1) + (inst jsr lip-tn temp1 (make-fixup ',name :assembly-routine)) + (emit-return-pc lra-label) + (note-this-location ,vop :single-value-return) + (without-scheduling () + (move ocfp-tn csp-tn) + (inst nop)) + (inst compute-code-from-lra code-tn code-tn + lra-label ,temp) + (when cur-nfp + (maybe-load-stack-nfp-tn cur-nfp ,nfp-save temp1)))) + `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) + ,temp) + (:temporary (:sc descriptor-reg :offset lra-offset + :from (:eval 0) :to (:eval 1)) + ,lra) + (:temporary (:scs (control-stack) :offset nfp-save-offset) + ,nfp-save) + (:temporary (:scs (non-descriptor-reg)) temp1) + (:save-p t))))))) (!def-vm-support-routine generate-return-sequence (style) (ecase style @@ -58,10 +58,10 @@ `((inst ret zero-tn lip-tn))) (:full-call `((lisp-return (make-random-tn :kind :normal - :sc (sc-or-lose - 'descriptor-reg) - :offset lra-offset) - lip-tn :offset 2))) + :sc (sc-or-lose + 'descriptor-reg) + :offset lra-offset) + lip-tn :offset 2))) (:none))) (defun return-machine-address (scp) diff --git a/src/assembly/assemfile.lisp b/src/assembly/assemfile.lisp index ac8ab34..591acfb 100644 --- a/src/assembly/assemfile.lisp +++ b/src/assembly/assemfile.lisp @@ -27,36 +27,36 @@ ;;; to the return convention. It LOADs a file, then writes out any ;;; assembly code created by the process. (defun assemble-file (name - &key - (output-file (make-pathname :defaults name - :type "assem"))) + &key + (output-file (make-pathname :defaults name + :type "assem"))) ;; FIXME: Consider nuking the filename defaulting logic here. (let* ((*emit-assembly-code-not-vops-p* t) - (name (pathname name)) - ;; the fasl file currently being output to - (lap-fasl-output (open-fasl-output (pathname output-file) name)) - (*entry-points* nil) - (won nil) - (*code-segment* nil) - (*elsewhere* nil) - (*assembly-optimize* nil) - (*fixup-notes* nil)) + (name (pathname name)) + ;; the fasl file currently being output to + (lap-fasl-output (open-fasl-output (pathname output-file) name)) + (*entry-points* nil) + (won nil) + (*code-segment* nil) + (*elsewhere* nil) + (*assembly-optimize* nil) + (*fixup-notes* nil)) (unwind-protect - (let ((*features* (cons :sb-assembling *features*))) - (init-assembler) - (load (merge-pathnames name (make-pathname :type "lisp"))) - (fasl-dump-cold-load-form `(in-package ,(package-name - (sane-package))) - lap-fasl-output) - (sb!assem:append-segment *code-segment* *elsewhere*) - (setf *elsewhere* nil) - (let ((length (sb!assem:finalize-segment *code-segment*))) - (dump-assembler-routines *code-segment* - length - *fixup-notes* - *entry-points* - lap-fasl-output)) - (setq won t)) + (let ((*features* (cons :sb-assembling *features*))) + (init-assembler) + (load (merge-pathnames name (make-pathname :type "lisp"))) + (fasl-dump-cold-load-form `(in-package ,(package-name + (sane-package))) + lap-fasl-output) + (sb!assem:append-segment *code-segment* *elsewhere*) + (setf *elsewhere* nil) + (let ((length (sb!assem:finalize-segment *code-segment*))) + (dump-assembler-routines *code-segment* + length + *fixup-notes* + *entry-points* + lap-fasl-output)) + (setq won t)) (close-fasl-output lap-fasl-output (not won))) won)) @@ -69,11 +69,11 @@ (def!method print-object ((spec reg-spec) stream) (print-unreadable-object (spec stream :type t) (format stream - ":KIND ~S :NAME ~S :SCS ~S :OFFSET ~S" - (reg-spec-kind spec) - (reg-spec-name spec) - (reg-spec-scs spec) - (reg-spec-offset spec)))) + ":KIND ~S :NAME ~S :SCS ~S :OFFSET ~S" + (reg-spec-kind spec) + (reg-spec-name spec) + (reg-spec-scs spec) + (reg-spec-offset spec)))) (defun reg-spec-sc (spec) (if (atom (reg-spec-scs spec)) @@ -92,105 +92,105 @@ (collect ((decls)) (loop (if (and (consp code) (consp (car code)) (eq (caar code) 'declare)) - (decls (pop code)) - (return))) + (decls (pop code)) + (return))) `(let ,(mapcar (lambda (reg) - `(,(reg-spec-name reg) - (make-random-tn - :kind :normal - :sc (sc-or-lose ',(reg-spec-sc reg)) - :offset ,(reg-spec-offset reg)))) - regs) + `(,(reg-spec-name reg) + (make-random-tn + :kind :normal + :sc (sc-or-lose ',(reg-spec-sc reg)) + :offset ,(reg-spec-offset reg)))) + regs) ,@(decls) (sb!assem:assemble (*code-segment* ',name) - ,name - (push (cons ',name ,name) *entry-points*) - ,@code - ,@(generate-return-sequence - (or (cadr (assoc :return-style options)) :raw))) + ,name + (push (cons ',name ,name) *entry-points*) + ,@code + ,@(generate-return-sequence + (or (cadr (assoc :return-style options)) :raw))) (when sb!xc:*compile-print* - (format *error-output* "~S assembled~%" ',name))))) + (format *error-output* "~S assembled~%" ',name))))) (defun arg-or-res-spec (reg) `(,(reg-spec-name reg) :scs ,(if (atom (reg-spec-scs reg)) - (list (reg-spec-scs reg)) - (reg-spec-scs reg)) + (list (reg-spec-scs reg)) + (reg-spec-scs reg)) ,@(unless (eq (reg-spec-kind reg) :res) - `(:target ,(reg-spec-temp reg))))) + `(:target ,(reg-spec-temp reg))))) (defun emit-vop (name options vars) (let* ((args (remove :arg vars :key #'reg-spec-kind :test #'neq)) - (temps (remove :temp vars :key #'reg-spec-kind :test #'neq)) - (results (remove :res vars :key #'reg-spec-kind :test #'neq)) - (return-style (or (cadr (assoc :return-style options)) :raw)) - (cost (or (cadr (assoc :cost options)) 247)) - (vop (make-symbol "VOP"))) + (temps (remove :temp vars :key #'reg-spec-kind :test #'neq)) + (results (remove :res vars :key #'reg-spec-kind :test #'neq)) + (return-style (or (cadr (assoc :return-style options)) :raw)) + (cost (or (cadr (assoc :cost options)) 247)) + (vop (make-symbol "VOP"))) (unless (member return-style '(:raw :full-call :none)) (error "unknown return-style for ~S: ~S" name return-style)) (multiple-value-bind - (call-sequence call-temps) - (generate-call-sequence name return-style vop) + (call-sequence call-temps) + (generate-call-sequence name return-style vop) `(define-vop ,(if (atom name) (list name) name) - (:args ,@(mapcar #'arg-or-res-spec args)) - ,@(let ((index -1)) - (mapcar (lambda (arg) - `(:temporary (:sc ,(reg-spec-sc arg) - :offset ,(reg-spec-offset arg) - :from (:argument ,(incf index)) - :to (:eval 2)) - ,(reg-spec-temp arg))) - args)) - ,@(mapcar (lambda (temp) - `(:temporary (:sc ,(reg-spec-sc temp) - :offset ,(reg-spec-offset temp) - :from (:eval 1) - :to (:eval 3)) - ,(reg-spec-name temp))) - temps) - ,@call-temps - (:vop-var ,vop) - ,@(let ((index -1)) - (mapcar (lambda (res) - `(:temporary (:sc ,(reg-spec-sc res) - :offset ,(reg-spec-offset res) - :from (:eval 2) - :to (:result ,(incf index)) - :target ,(reg-spec-name res)) - ,(reg-spec-temp res))) - results)) - (:results ,@(mapcar #'arg-or-res-spec results)) - (:ignore ,@(mapcar #'reg-spec-name temps) - ,@(apply #'append - (mapcar #'cdr - (remove :ignore call-temps - :test #'neq :key #'car)))) - ,@(remove-if (lambda (x) - (member x '(:return-style :cost))) - options - :key #'car) - (:generator ,cost - ,@(mapcar (lambda (arg) - #!+(or hppa alpha) `(move ,(reg-spec-name arg) - ,(reg-spec-temp arg)) - #!-(or hppa alpha) `(move ,(reg-spec-temp arg) - ,(reg-spec-name arg))) - args) - ,@call-sequence - ,@(mapcar (lambda (res) - #!+(or hppa alpha) `(move ,(reg-spec-temp res) - ,(reg-spec-name res)) - #!-(or hppa alpha) `(move ,(reg-spec-name res) - ,(reg-spec-temp res))) - results)))))) + (:args ,@(mapcar #'arg-or-res-spec args)) + ,@(let ((index -1)) + (mapcar (lambda (arg) + `(:temporary (:sc ,(reg-spec-sc arg) + :offset ,(reg-spec-offset arg) + :from (:argument ,(incf index)) + :to (:eval 2)) + ,(reg-spec-temp arg))) + args)) + ,@(mapcar (lambda (temp) + `(:temporary (:sc ,(reg-spec-sc temp) + :offset ,(reg-spec-offset temp) + :from (:eval 1) + :to (:eval 3)) + ,(reg-spec-name temp))) + temps) + ,@call-temps + (:vop-var ,vop) + ,@(let ((index -1)) + (mapcar (lambda (res) + `(:temporary (:sc ,(reg-spec-sc res) + :offset ,(reg-spec-offset res) + :from (:eval 2) + :to (:result ,(incf index)) + :target ,(reg-spec-name res)) + ,(reg-spec-temp res))) + results)) + (:results ,@(mapcar #'arg-or-res-spec results)) + (:ignore ,@(mapcar #'reg-spec-name temps) + ,@(apply #'append + (mapcar #'cdr + (remove :ignore call-temps + :test #'neq :key #'car)))) + ,@(remove-if (lambda (x) + (member x '(:return-style :cost))) + options + :key #'car) + (:generator ,cost + ,@(mapcar (lambda (arg) + #!+(or hppa alpha) `(move ,(reg-spec-name arg) + ,(reg-spec-temp arg)) + #!-(or hppa alpha) `(move ,(reg-spec-temp arg) + ,(reg-spec-name arg))) + args) + ,@call-sequence + ,@(mapcar (lambda (res) + #!+(or hppa alpha) `(move ,(reg-spec-temp res) + ,(reg-spec-name res)) + #!-(or hppa alpha) `(move ,(reg-spec-name res) + ,(reg-spec-temp res))) + results)))))) (def!macro define-assembly-routine (name&options vars &body code) (multiple-value-bind (name options) (if (atom name&options) - (values name&options nil) - (values (car name&options) - (cdr name&options))) + (values name&options nil) + (values (car name&options) + (cdr name&options))) (let ((regs (mapcar (lambda (var) (apply #'parse-reg-spec var)) vars))) (if *emit-assembly-code-not-vops-p* - (emit-assemble name options regs code) - (emit-vop name options regs))))) + (emit-assemble name options regs code) + (emit-vop name options regs))))) diff --git a/src/assembly/hppa/arith.lisp b/src/assembly/hppa/arith.lisp index 4929582..d3a2ffa 100644 --- a/src/assembly/hppa/arith.lisp +++ b/src/assembly/hppa/arith.lisp @@ -58,7 +58,7 @@ (:res quo signed-reg nl2-offset) (:res rem signed-reg nl3-offset)) - + ;; Move abs(divident) into quo. (inst move dividend quo :>=) (inst sub zero-tn quo quo) @@ -92,20 +92,20 @@ ;;;; Generic arithmetic. (define-assembly-routine (generic-+ - (:cost 10) - (:return-style :full-call) - (:translate +) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:translate +) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst extru x 31 2 zero-tn :=) (inst b do-static-fun :nullify t) (inst extru y 31 2 zero-tn :=) @@ -121,20 +121,20 @@ (inst move csp-tn cfp-tn)) (define-assembly-routine (generic-- - (:cost 10) - (:return-style :full-call) - (:translate -) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:translate -) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst extru x 31 2 zero-tn :=) (inst b do-static-fun :nullify t) (inst extru y 31 2 zero-tn :=) @@ -156,36 +156,36 @@ (macrolet ((define-cond-assem-rtn (name translate static-fn cond) `(define-assembly-routine (,name - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate ,translate) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp lip interior-reg lip-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst extru x 31 2 zero-tn :=) - (inst b do-static-fn :nullify t) - (inst extru y 31 2 zero-tn :=) - (inst b do-static-fn :nullify t) - - (inst comclr x y zero-tn ,cond) - (inst move null-tn res :tr) - (load-symbol res t) - (lisp-return lra :offset 1) - - DO-STATIC-FN - (inst ldw (static-fun-offset ',static-fn) null-tn lip) - (inst li (fixnumize 2) nargs) - (inst move cfp-tn ocfp) - (inst bv lip) - (inst move csp-tn cfp-tn)))) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst extru x 31 2 zero-tn :=) + (inst b do-static-fn :nullify t) + (inst extru y 31 2 zero-tn :=) + (inst b do-static-fn :nullify t) + + (inst comclr x y zero-tn ,cond) + (inst move null-tn res :tr) + (load-symbol res t) + (lisp-return lra :offset 1) + + DO-STATIC-FN + (inst ldw (static-fun-offset ',static-fn) null-tn lip) + (inst li (fixnumize 2) nargs) + (inst move cfp-tn ocfp) + (inst bv lip) + (inst move csp-tn cfp-tn)))) (define-cond-assem-rtn generic-< < two-arg-< :<) (define-cond-assem-rtn generic-> > two-arg-> :>)) @@ -200,9 +200,9 @@ (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) - + (:res res descriptor-reg a0-offset) - + (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) @@ -237,9 +237,9 @@ (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) - + (:res res descriptor-reg a0-offset) - + (:temp lip interior-reg lip-offset) (:temp lra descriptor-reg lra-offset) (:temp nargs any-reg nargs-offset) diff --git a/src/assembly/hppa/array.lisp b/src/assembly/hppa/array.lisp index d4dc139..84638ab 100644 --- a/src/assembly/hppa/array.lisp +++ b/src/assembly/hppa/array.lisp @@ -5,13 +5,13 @@ (:policy :fast-safe) (:translate allocate-vector) (:arg-types positive-fixnum - positive-fixnum - positive-fixnum)) + positive-fixnum + positive-fixnum)) ((:arg type any-reg a0-offset) (:arg length any-reg a1-offset) (:arg words any-reg a2-offset) (:res result descriptor-reg a0-offset) - + (:temp ndescr non-descriptor-reg nl0-offset) (:temp vector descriptor-reg a3-offset)) (pseudo-atomic () @@ -58,7 +58,7 @@ (:policy :fast-safe) (:arg-types * positive-fixnum) (:result-types positive-fixnum)) - + ((:arg string descriptor-reg a0-offset) (:arg length any-reg a1-offset) (:res result any-reg a0-offset) diff --git a/src/assembly/hppa/assem-rtns.lisp b/src/assembly/hppa/assem-rtns.lisp index 85b60a3..4cae72b 100644 --- a/src/assembly/hppa/assem-rtns.lisp +++ b/src/assembly/hppa/assem-rtns.lisp @@ -40,7 +40,7 @@ (loadw a4 vals 4) (inst addib := (fixnumize -1) count default-a5-and-on :nullify t) (loadw a5 vals 5) - (inst addib := (fixnumize -1) count done :nullify t) + (inst addib := (fixnumize -1) count done :nullify t) ;; Copy the remaining args to the top of the stack. (inst addi (* 6 n-word-bytes) vals src) @@ -71,7 +71,7 @@ (move cfp-tn ocfp-tn) (move old-fp cfp-tn) (inst add ocfp-tn nvals csp-tn) - + ;; Return. (lisp-return lra)) @@ -108,7 +108,7 @@ ;; Calculate NARGS (as a fixnum) (inst sub csp-tn args nargs) - + ;; Load the argument regs (must do this now, 'cause the blt might ;; trash these locations) (loadw a0 args 0) @@ -123,13 +123,13 @@ (inst comb :<= count zero-tn done :nullify t) (inst addi (* n-word-bytes register-arg-count) args src) (inst addi (* n-word-bytes register-arg-count) cfp-tn dst) - + LOOP ;; Copy one arg. (inst ldwm 4 src temp) (inst addib :> (fixnumize -1) count loop) (inst stwm temp 4 dst) - + DONE ;; We are done. Do the jump. (loadw temp lexenv closure-fun-slot fun-pointer-lowtag) @@ -160,15 +160,15 @@ (let ((error (generate-error-code nil invalid-unwind-error))) (inst bc := nil block zero-tn error)) - + (load-symbol-value cur-uwp *current-unwind-protect-block*) (loadw target-uwp block unwind-block-current-uwp-slot) (inst bc :<> nil cur-uwp target-uwp do-uwp) - + (move block cur-uwp) DO-EXIT - + (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) (loadw code-tn cur-uwp unwind-block-current-code-slot) (loadw lra cur-uwp unwind-block-entry-pc-slot) @@ -191,13 +191,13 @@ (declare (ignore start count)) ; We just need them in the registers. (load-symbol-value catch *current-catch-block*) - + LOOP (let ((error (generate-error-code nil unseen-throw-tag-error target))) (inst bc := nil catch zero-tn error)) (loadw tag catch catch-block-tag-slot) (inst comb :<> tag target loop :nullify t) (loadw catch catch catch-block-previous-catch-slot) - + (inst b *unwind-entry-point*) (inst move catch target)) diff --git a/src/assembly/hppa/support.lisp b/src/assembly/hppa/support.lisp index 4d7d53f..76c39b5 100644 --- a/src/assembly/hppa/support.lisp +++ b/src/assembly/hppa/support.lisp @@ -16,48 +16,48 @@ (:raw (with-unique-names (fixup) (values - `((let ((fixup (make-fixup ',name :assembly-routine))) - (inst ldil fixup ,fixup) - (inst ble fixup lisp-heap-space ,fixup :nullify t)) - (inst nop)) - `((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1)) - ,fixup))))) + `((let ((fixup (make-fixup ',name :assembly-routine))) + (inst ldil fixup ,fixup) + (inst ble fixup lisp-heap-space ,fixup :nullify t)) + (inst nop)) + `((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1)) + ,fixup))))) (:full-call (let ((temp (make-symbol "TEMP")) - (nfp-save (make-symbol "NFP-SAVE")) - (lra (make-symbol "LRA"))) + (nfp-save (make-symbol "NFP-SAVE")) + (lra (make-symbol "LRA"))) (values - `((let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn ,vop))) - (when cur-nfp - (store-stack-tn ,nfp-save cur-nfp)) - (inst compute-lra-from-code code-tn lra-label ,temp ,lra) - (note-this-location ,vop :call-site) - (let ((fixup (make-fixup ',name :assembly-routine))) - (inst ldil fixup ,temp) - (inst be fixup lisp-heap-space ,temp :nullify t)) - (emit-return-pc lra-label) - (note-this-location ,vop :single-value-return) - (move ocfp-tn csp-tn) - (inst compute-code-from-lra code-tn lra-label ,temp code-tn) - (when cur-nfp - (load-stack-tn cur-nfp ,nfp-save)))) - `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) - ,temp) - (:temporary (:sc descriptor-reg :offset lra-offset - :from (:eval 0) :to (:eval 1)) - ,lra) - (:temporary (:scs (control-stack) :offset nfp-save-offset) - ,nfp-save) - (:save-p :compute-only))))) + `((let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn ,vop))) + (when cur-nfp + (store-stack-tn ,nfp-save cur-nfp)) + (inst compute-lra-from-code code-tn lra-label ,temp ,lra) + (note-this-location ,vop :call-site) + (let ((fixup (make-fixup ',name :assembly-routine))) + (inst ldil fixup ,temp) + (inst be fixup lisp-heap-space ,temp :nullify t)) + (emit-return-pc lra-label) + (note-this-location ,vop :single-value-return) + (move ocfp-tn csp-tn) + (inst compute-code-from-lra code-tn lra-label ,temp code-tn) + (when cur-nfp + (load-stack-tn cur-nfp ,nfp-save)))) + `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) + ,temp) + (:temporary (:sc descriptor-reg :offset lra-offset + :from (:eval 0) :to (:eval 1)) + ,lra) + (:temporary (:scs (control-stack) :offset nfp-save-offset) + ,nfp-save) + (:save-p :compute-only))))) (:none (with-unique-names (fixup) (values - `((let ((fixup (make-fixup ',name :assembly-routine))) - (inst ldil fixup ,fixup) - (inst be fixup lisp-heap-space ,fixup :nullify t))) - `((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1)) - ,fixup))))))) + `((let ((fixup (make-fixup ',name :assembly-routine))) + (inst ldil fixup ,fixup) + (inst be fixup lisp-heap-space ,fixup :nullify t))) + `((:temporary (:scs (any-reg) :from (:eval 0) :to (:eval 1)) + ,fixup))))))) (!def-vm-support-routine generate-return-sequence (style) (ecase style @@ -65,9 +65,9 @@ `((inst bv lip-tn :nullify t))) (:full-call `((lisp-return (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset lra-offset) - :offset 1))) + :sc (sc-or-lose 'descriptor-reg) + :offset lra-offset) + :offset 1))) (:none))) (defun return-machine-address (scp) diff --git a/src/assembly/mips/arith.lisp b/src/assembly/mips/arith.lisp index 8a54196..1cbbbbd 100644 --- a/src/assembly/mips/arith.lisp +++ b/src/assembly/mips/arith.lisp @@ -2,23 +2,23 @@ (define-assembly-routine (generic-+ - (:cost 10) - (:return-style :full-call) - (:translate +) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp temp1 non-descriptor-reg nl1-offset) - (:temp temp2 non-descriptor-reg nl2-offset) - (:temp pa-flag non-descriptor-reg nl4-offset) - (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:translate +) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp1 non-descriptor-reg nl1-offset) + (:temp temp2 non-descriptor-reg nl2-offset) + (:temp pa-flag non-descriptor-reg nl4-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst or temp x y) (inst and temp fixnum-tag-mask) (inst beq temp DO-ADD) @@ -52,23 +52,23 @@ (define-assembly-routine (generic-- - (:cost 10) - (:return-style :full-call) - (:translate -) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp temp1 non-descriptor-reg nl1-offset) - (:temp temp2 non-descriptor-reg nl2-offset) - (:temp pa-flag non-descriptor-reg nl4-offset) - (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:translate -) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp1 non-descriptor-reg nl1-offset) + (:temp temp2 non-descriptor-reg nl2-offset) + (:temp pa-flag non-descriptor-reg nl4-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst or temp x y) (inst and temp fixnum-tag-mask) (inst beq temp DO-SUB) @@ -102,23 +102,23 @@ (define-assembly-routine (generic-* - (:cost 25) - (:return-style :full-call) - (:translate *) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lo non-descriptor-reg nl1-offset) - (:temp hi non-descriptor-reg nl2-offset) - (:temp pa-flag non-descriptor-reg nl4-offset) - (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 25) + (:return-style :full-call) + (:translate *) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lo non-descriptor-reg nl1-offset) + (:temp hi non-descriptor-reg nl2-offset) + (:temp pa-flag non-descriptor-reg nl4-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) ;; If either arg is not a fixnum, call the static function. (inst or temp x y) (inst and temp fixnum-tag-mask) @@ -180,58 +180,58 @@ (macrolet ((define-cond-assem-rtn (name translate static-fn cmp) `(define-assembly-routine (,name - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate ,translate) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst or temp x y) - (inst and temp fixnum-tag-mask) - (inst beq temp DO-COMPARE) - ,cmp - - ;; DO-STATIC-FUN - (inst lw lip null-tn (static-fun-offset ',static-fn)) - (inst li nargs (fixnumize 2)) - (move ocfp cfp-tn) - (inst j lip) - (move cfp-tn csp-tn t) - - DO-COMPARE - (inst beq temp DONE) - (move res null-tn t) - (load-symbol res t) - - DONE))) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst or temp x y) + (inst and temp fixnum-tag-mask) + (inst beq temp DO-COMPARE) + ,cmp + + ;; DO-STATIC-FUN + (inst lw lip null-tn (static-fun-offset ',static-fn)) + (inst li nargs (fixnumize 2)) + (move ocfp cfp-tn) + (inst j lip) + (move cfp-tn csp-tn t) + + DO-COMPARE + (inst beq temp DONE) + (move res null-tn t) + (load-symbol res t) + + DONE))) (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y)) (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x))) (define-assembly-routine (generic-eql - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate eql) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst beq x y RETURN-T) (inst or temp x y) (inst and temp fixnum-tag-mask) @@ -256,20 +256,20 @@ (define-assembly-routine (generic-= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate =) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst or temp x y) (inst and temp fixnum-tag-mask) (inst beq temp RETURN) @@ -291,20 +291,20 @@ (define-assembly-routine (generic-/= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate /=) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate /=) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst or temp x y) (inst and temp fixnum-tag-mask) (inst beq temp RETURN) diff --git a/src/assembly/mips/array.lisp b/src/assembly/mips/array.lisp index aaaff08..8399f2f 100644 --- a/src/assembly/mips/array.lisp +++ b/src/assembly/mips/array.lisp @@ -13,22 +13,22 @@ (in-package "SB!VM") (define-assembly-routine (allocate-vector - (:policy :fast-safe) - (:translate allocate-vector) - (:arg-types positive-fixnum - positive-fixnum - positive-fixnum)) - ((:arg type any-reg a0-offset) - (:arg length any-reg a1-offset) - (:arg words any-reg a2-offset) - (:res result descriptor-reg a0-offset) + (:policy :fast-safe) + (:translate allocate-vector) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum)) + ((:arg type any-reg a0-offset) + (:arg length any-reg a1-offset) + (:arg words any-reg a2-offset) + (:res result descriptor-reg a0-offset) - (:temp ndescr non-descriptor-reg nl0-offset) - (:temp pa-flag non-descriptor-reg nl4-offset)) + (:temp ndescr non-descriptor-reg nl0-offset) + (:temp pa-flag non-descriptor-reg nl4-offset)) ;; This is kinda sleezy, changing words like this. But we can because ;; the vop thinks it is temporary. (inst addu words (+ (1- (ash 1 n-lowtag-bits)) - (* vector-data-offset n-word-bytes))) + (* vector-data-offset n-word-bytes))) (inst li ndescr (lognot lowtag-mask)) (inst and words ndescr) (inst srl ndescr type word-shift) diff --git a/src/assembly/mips/assem-rtns.lisp b/src/assembly/mips/assem-rtns.lisp index ccc92b0..f0f6397 100644 --- a/src/assembly/mips/assem-rtns.lisp +++ b/src/assembly/mips/assem-rtns.lisp @@ -59,7 +59,7 @@ (inst subu count (fixnumize 1)) (inst bne count zero-tn loop) (inst addu dst n-word-bytes) - + (inst b done) (inst nop) @@ -75,12 +75,12 @@ DEFAULT-A5-AND-ON (move a5 null-tn) DONE - + ;; Clear the stack. (move ocfp-tn cfp-tn) (move cfp-tn ocfp) (inst addu csp-tn ocfp-tn nvals) - + ;; Return. (lisp-return lra lip)) @@ -119,7 +119,7 @@ ;; Calculate NARGS (as a fixnum) (inst subu nargs csp-tn args) - + ;; Load the argument regs (must do this now, 'cause the blt might ;; trash these locations) (inst lw a0 args (* 0 n-word-bytes)) @@ -134,7 +134,7 @@ (inst blez count done) (inst addu src args (* n-word-bytes register-arg-count)) (inst addu dst cfp-tn (* n-word-bytes register-arg-count)) - + LOOP ;; Copy one arg. (inst lw temp src) @@ -143,7 +143,7 @@ (inst addu count (fixnumize -1)) (inst bgtz count loop) (inst addu dst dst n-word-bytes) - + DONE ;; We are done. Do the jump. (loadw temp lexenv closure-fun-slot fun-pointer-lowtag) @@ -175,11 +175,11 @@ (loadw target-uwp block unwind-block-current-uwp-slot) (inst bne cur-uwp target-uwp do-uwp) (inst nop) - + (move cur-uwp block) DO-EXIT - + (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) (loadw code-tn cur-uwp unwind-block-current-code-slot) (loadw lra cur-uwp unwind-block-entry-pc-slot) @@ -199,24 +199,24 @@ (:arg count any-reg nargs-offset) (:temp catch any-reg a1-offset) (:temp tag descriptor-reg a2-offset)) - + (declare (ignore start count)) ; We only need them in the registers. (load-symbol-value catch *current-catch-block*) LOOP - + (let ((error (generate-error-code nil unseen-throw-tag-error target))) (inst beq catch zero-tn error) (inst nop)) - + (loadw tag catch catch-block-tag-slot) (inst beq tag target exit) (inst nop) (inst b loop) (loadw catch catch catch-block-previous-catch-slot) - + EXIT - + (inst j (make-fixup 'unwind :assembly-routine)) (move target catch t)) diff --git a/src/assembly/mips/support.lisp b/src/assembly/mips/support.lisp index 8800efc..cb3a759 100644 --- a/src/assembly/mips/support.lisp +++ b/src/assembly/mips/support.lisp @@ -16,38 +16,38 @@ ((:raw :none) (values `((inst jal (make-fixup ',name :assembly-routine)) - (inst nop)) + (inst nop)) `())) (:full-call (let ((temp (make-symbol "TEMP")) - (nfp-save (make-symbol "NFP-SAVE")) - (lra (make-symbol "LRA"))) + (nfp-save (make-symbol "NFP-SAVE")) + (lra (make-symbol "LRA"))) (values - `((let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn ,vop))) - (when cur-nfp - (store-stack-tn ,nfp-save cur-nfp)) - (inst compute-lra-from-code ,lra code-tn lra-label ,temp) - (note-next-instruction ,vop :call-site) - (inst j (make-fixup ',name :assembly-routine)) - (inst nop) - (without-scheduling () - (emit-return-pc lra-label) - (note-this-location ,vop :single-value-return) - (inst move csp-tn ocfp-tn) - (inst nop)) - (inst compute-code-from-lra code-tn code-tn - lra-label ,temp) - (when cur-nfp - (load-stack-tn cur-nfp ,nfp-save)))) - `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) - ,temp) - (:temporary (:sc descriptor-reg :offset lra-offset - :from (:eval 0) :to (:eval 1)) - ,lra) - (:temporary (:scs (control-stack) :offset nfp-save-offset) - ,nfp-save) - (:save-p t))))))) + `((let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn ,vop))) + (when cur-nfp + (store-stack-tn ,nfp-save cur-nfp)) + (inst compute-lra-from-code ,lra code-tn lra-label ,temp) + (note-next-instruction ,vop :call-site) + (inst j (make-fixup ',name :assembly-routine)) + (inst nop) + (without-scheduling () + (emit-return-pc lra-label) + (note-this-location ,vop :single-value-return) + (inst move csp-tn ocfp-tn) + (inst nop)) + (inst compute-code-from-lra code-tn code-tn + lra-label ,temp) + (when cur-nfp + (load-stack-tn cur-nfp ,nfp-save)))) + `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) + ,temp) + (:temporary (:sc descriptor-reg :offset lra-offset + :from (:eval 0) :to (:eval 1)) + ,lra) + (:temporary (:scs (control-stack) :offset nfp-save-offset) + ,nfp-save) + (:save-p t))))))) (!def-vm-support-routine generate-return-sequence (style) (ecase style @@ -56,10 +56,10 @@ (inst nop))) (:full-call `((lisp-return (make-random-tn :kind :normal - :sc (sc-or-lose - 'descriptor-reg) - :offset lra-offset) - lip-tn :offset 2))) + :sc (sc-or-lose + 'descriptor-reg) + :offset lra-offset) + lip-tn :offset 2))) (:none))) (defun return-machine-address (scp) diff --git a/src/assembly/ppc/arith.lisp b/src/assembly/ppc/arith.lisp index 13e998a..0abf902 100644 --- a/src/assembly/ppc/arith.lisp +++ b/src/assembly/ppc/arith.lisp @@ -9,8 +9,8 @@ ;;; Note that there is only one use of static-fun-offset outside this ;;; file (in genesis.lisp) - -(define-assembly-routine + +(define-assembly-routine (generic-+ (:cost 10) (:return-style :full-call) @@ -19,9 +19,9 @@ (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) - + (:res res (descriptor-reg any-reg) a0-offset) - + (:temp temp non-descriptor-reg nl0-offset) (:temp temp2 non-descriptor-reg nl1-offset) (:temp flag non-descriptor-reg nl3-offset) @@ -29,7 +29,7 @@ (:temp nargs any-reg nargs-offset) (:temp lip interior-reg lip-offset) (:temp ocfp any-reg ocfp-offset)) - + ; Clear the damned "sticky overflow" bit in :cr0 and :xer (inst mtxer zero-tn) (inst or temp x y) @@ -37,26 +37,26 @@ (inst bne DO-STATIC-FUN) (inst addo. temp x y) (inst bns done) - + (inst srawi temp x 2) (inst srawi temp2 y 2) (inst add temp2 temp2 temp) (with-fixed-allocation (res flag temp bignum-widetag (1+ bignum-digits-offset)) (storew temp2 res bignum-digits-offset other-pointer-lowtag)) (lisp-return lra lip :offset 2) - + DO-STATIC-FUN (inst lwz lip null-tn (static-fun-offset 'two-arg-+) ) (inst li nargs (fixnumize 2)) (inst mr ocfp cfp-tn) (inst mr cfp-tn csp-tn) (inst j lip 0) - + DONE (move res temp)) -(define-assembly-routine +(define-assembly-routine (generic-- (:cost 10) (:return-style :full-call) @@ -65,9 +65,9 @@ (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) - + (:res res (descriptor-reg any-reg) a0-offset) - + (:temp temp non-descriptor-reg nl0-offset) (:temp temp2 non-descriptor-reg nl1-offset) (:temp flag non-descriptor-reg nl3-offset) @@ -108,7 +108,7 @@ ;;;; Multiplication -(define-assembly-routine +(define-assembly-routine (generic-* (:cost 50) (:return-style :full-call) @@ -117,9 +117,9 @@ (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) - + (:res res (descriptor-reg any-reg) a0-offset) - + (:temp temp non-descriptor-reg nl0-offset) (:temp lo non-descriptor-reg nl1-offset) (:temp hi non-descriptor-reg nl2-offset) @@ -145,7 +145,7 @@ (inst bns ONE-WORD-ANSWER) (inst mulhw hi nargs temp) (inst b CONS-BIGNUM) - + ONE-WORD-ANSWER ; We know that all of the overflow bits are clear. (inst addo temp lo lo) (inst addo. res temp temp) @@ -163,7 +163,7 @@ (inst beq one-word) ;; Nope, we need two, so allocate the additional space. (inst addi alloc-tn alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset)) - (pad-data-block (1+ bignum-digits-offset)))) + (pad-data-block (1+ bignum-digits-offset)))) (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag)) (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag) (emit-label one-word) @@ -186,17 +186,17 @@ (macrolet ((frob (name note cost type sc) `(define-assembly-routine (,name - (:note ,note) - (:cost ,cost) - (:translate *) - (:policy :fast-safe) - (:arg-types ,type ,type) - (:result-types ,type)) - ((:arg x ,sc nl0-offset) - (:arg y ,sc nl1-offset) - (:res res ,sc nl0-offset)) - ,@(when (eq type 'tagged-num) - `((inst srawi x x 2))) + (:note ,note) + (:cost ,cost) + (:translate *) + (:policy :fast-safe) + (:arg-types ,type ,type) + (:result-types ,type)) + ((:arg x ,sc nl0-offset) + (:arg y ,sc nl1-offset) + (:res res ,sc nl0-offset)) + ,@(when (eq type 'tagged-num) + `((inst srawi x x 2))) (inst mullw res x y)))) (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg) (frob signed-* "unsigned *" 41 signed-num signed-reg) @@ -208,20 +208,20 @@ (define-assembly-routine (positive-fixnum-truncate - (:note "unsigned fixnum truncate") - (:cost 45) - (:translate truncate) - (:policy :fast-safe) - (:arg-types positive-fixnum positive-fixnum) - (:result-types positive-fixnum positive-fixnum)) - ((:arg dividend any-reg nl0-offset) - (:arg divisor any-reg nl1-offset) - - (:res quo any-reg nl2-offset) - (:res rem any-reg nl0-offset)) + (:note "unsigned fixnum truncate") + (:cost 45) + (:translate truncate) + (:policy :fast-safe) + (:arg-types positive-fixnum positive-fixnum) + (:result-types positive-fixnum positive-fixnum)) + ((:arg dividend any-reg nl0-offset) + (:arg divisor any-reg nl1-offset) + + (:res quo any-reg nl2-offset) + (:res rem any-reg nl0-offset)) (aver (location= rem dividend)) (let ((error (generate-error-code nil division-by-zero-error - dividend divisor))) + dividend divisor))) (inst cmpwi divisor 0) (inst beq error)) (inst divwu quo dividend divisor) @@ -232,21 +232,21 @@ (define-assembly-routine (fixnum-truncate - (:note "fixnum truncate") - (:cost 50) - (:policy :fast-safe) - (:translate truncate) - (:arg-types tagged-num tagged-num) - (:result-types tagged-num tagged-num)) - ((:arg dividend any-reg nl0-offset) - (:arg divisor any-reg nl1-offset) - - (:res quo any-reg nl2-offset) - (:res rem any-reg nl0-offset)) - + (:note "fixnum truncate") + (:cost 50) + (:policy :fast-safe) + (:translate truncate) + (:arg-types tagged-num tagged-num) + (:result-types tagged-num tagged-num)) + ((:arg dividend any-reg nl0-offset) + (:arg divisor any-reg nl1-offset) + + (:res quo any-reg nl2-offset) + (:res rem any-reg nl0-offset)) + (aver (location= rem dividend)) (let ((error (generate-error-code nil division-by-zero-error - dividend divisor))) + dividend divisor))) (inst cmpwi divisor 0) (inst beq error)) @@ -257,21 +257,21 @@ (define-assembly-routine (signed-truncate - (:note "(signed-byte 32) truncate") - (:cost 60) - (:policy :fast-safe) - (:translate truncate) - (:arg-types signed-num signed-num) - (:result-types signed-num signed-num)) - - ((:arg dividend signed-reg nl0-offset) - (:arg divisor signed-reg nl1-offset) - - (:res quo signed-reg nl2-offset) - (:res rem signed-reg nl0-offset)) - + (:note "(signed-byte 32) truncate") + (:cost 60) + (:policy :fast-safe) + (:translate truncate) + (:arg-types signed-num signed-num) + (:result-types signed-num signed-num)) + + ((:arg dividend signed-reg nl0-offset) + (:arg divisor signed-reg nl1-offset) + + (:res quo signed-reg nl2-offset) + (:res rem signed-reg nl0-offset)) + (let ((error (generate-error-code nil division-by-zero-error - dividend divisor))) + dividend divisor))) (inst cmpwi divisor 0) (inst beq error)) @@ -284,7 +284,7 @@ (macrolet ((define-cond-assem-rtn (name translate static-fn cmp) - `(define-assembly-routine + `(define-assembly-routine (,name (:cost 10) (:return-style :full-call) @@ -293,30 +293,30 @@ (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) - + (:res res descriptor-reg a0-offset) - - (:temp lip interior-reg lip-offset) + + (:temp lip interior-reg lip-offset) (:temp nargs any-reg nargs-offset) (:temp ocfp any-reg ocfp-offset)) - + (inst or nargs x y) (inst andi. nargs nargs 3) (inst cmpw :cr1 x y) (inst beq DO-COMPARE) - - DO-STATIC-FN - (inst lwz lip null-tn (static-fun-offset ',static-fn)) - (inst li nargs (fixnumize 2)) - (inst mr ocfp cfp-tn) - (inst mr cfp-tn csp-tn) - (inst j lip 0) - - DO-COMPARE - (load-symbol res t) - (inst b? :cr1 ,cmp done) - (inst mr res null-tn) - DONE))) + + DO-STATIC-FN + (inst lwz lip null-tn (static-fun-offset ',static-fn)) + (inst li nargs (fixnumize 2)) + (inst mr ocfp cfp-tn) + (inst mr cfp-tn csp-tn) + (inst j lip 0) + + DO-COMPARE + (load-symbol res t) + (inst b? :cr1 ,cmp done) + (inst mr res null-tn) + DONE))) (define-cond-assem-rtn generic-< < two-arg-< :lt) (define-cond-assem-rtn generic-<= <= two-arg-<= :le) @@ -325,20 +325,20 @@ (define-assembly-routine (generic-eql - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate eql) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp lra descriptor-reg lra-offset) - (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lra descriptor-reg lra-offset) + (:temp lip interior-reg lip-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst cmpw :cr1 x y) (inst andi. nargs x 3) (inst beq :cr1 RETURN-T) @@ -360,7 +360,7 @@ RETURN-T (load-symbol res t)) -(define-assembly-routine +(define-assembly-routine (generic-= (:cost 10) (:return-style :full-call) @@ -369,7 +369,7 @@ (:save-p t)) ((:arg x (descriptor-reg any-reg) a0-offset) (:arg y (descriptor-reg any-reg) a1-offset) - + (:res res descriptor-reg a0-offset) (:temp lip interior-reg lip-offset) @@ -397,21 +397,21 @@ (load-symbol res t)) (define-assembly-routine (generic-/= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate /=) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate /=) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) - (:res res descriptor-reg a0-offset) + (:res res descriptor-reg a0-offset) - (:temp lra descriptor-reg lra-offset) - (:temp lip interior-reg lip-offset) + (:temp lra descriptor-reg lra-offset) + (:temp lip interior-reg lip-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst or nargs x y) (inst andi. nargs nargs 3) (inst cmpw :cr1 x y) diff --git a/src/assembly/ppc/array.lisp b/src/assembly/ppc/array.lisp index 4e0fb53..e94fa84 100644 --- a/src/assembly/ppc/array.lisp +++ b/src/assembly/ppc/array.lisp @@ -13,16 +13,16 @@ (in-package "SB!VM") (define-assembly-routine (allocate-vector - (:policy :fast-safe) - (:translate allocate-vector) - (:arg-types positive-fixnum - positive-fixnum - positive-fixnum)) + (:policy :fast-safe) + (:translate allocate-vector) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum)) ((:arg type any-reg a0-offset) (:arg length any-reg a1-offset) (:arg words any-reg a2-offset) (:res result descriptor-reg a0-offset) - + (:temp ndescr non-descriptor-reg nl0-offset) (:temp pa-flag non-descriptor-reg nl3-offset) (:temp vector descriptor-reg a3-offset)) diff --git a/src/assembly/ppc/assem-rtns.lisp b/src/assembly/ppc/assem-rtns.lisp index b84f882..d59e074 100644 --- a/src/assembly/ppc/assem-rtns.lisp +++ b/src/assembly/ppc/assem-rtns.lisp @@ -21,7 +21,7 @@ (:temp dst any-reg cfunc-offset) (:temp temp descriptor-reg l0-offset) - + ;; These are needed so we can get at the register args. (:temp a0 descriptor-reg a0-offset) (:temp a1 descriptor-reg a1-offset) @@ -55,7 +55,7 @@ (inst stw temp dst 0) (inst addi dst dst n-word-bytes) (inst bge loop) - + (inst b done) DEFAULT-A0-AND-ON @@ -66,12 +66,12 @@ DEFAULT-A3-AND-ON (inst mr a3 null-tn) DONE - + ;; Clear the stack. (move ocfp-tn cfp-tn) (move cfp-tn ocfp) (inst add csp-tn ocfp-tn nvals) - + ;; Return. (lisp-return lra lip)) @@ -107,7 +107,7 @@ ;; Calculate NARGS (as a fixnum) (inst sub nargs csp-tn args) - + ;; Load the argument regs (must do this now, 'cause the blt might ;; trash these locations) (inst lwz a0 args (* 0 n-word-bytes)) @@ -120,7 +120,7 @@ (inst addi src args (* n-word-bytes register-arg-count)) (inst ble done) (inst addi dst cfp-tn (* n-word-bytes register-arg-count)) - + LOOP ;; Copy one arg. (inst lwz temp src 0) @@ -129,7 +129,7 @@ (inst addic. count count (fixnumize -1)) (inst addi dst dst n-word-bytes) (inst bgt loop) - + DONE ;; We are done. Do the jump. (loadw temp lexenv closure-fun-slot fun-pointer-lowtag) @@ -140,32 +140,32 @@ ;;;; Non-local exit noise. (define-assembly-routine (unwind - (:return-style :none) - (:translate %continue-unwind) - (:policy :fast-safe)) - ((:arg block (any-reg descriptor-reg) a0-offset) - (:arg start (any-reg descriptor-reg) ocfp-offset) - (:arg count (any-reg descriptor-reg) nargs-offset) - (:temp lra descriptor-reg lra-offset) - (:temp lip interior-reg lip-offset) - (:temp cur-uwp any-reg nl0-offset) - (:temp next-uwp any-reg nl1-offset) - (:temp target-uwp any-reg nl2-offset)) + (:return-style :none) + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) a0-offset) + (:arg start (any-reg descriptor-reg) ocfp-offset) + (:arg count (any-reg descriptor-reg) nargs-offset) + (:temp lra descriptor-reg lra-offset) + (:temp lip interior-reg lip-offset) + (:temp cur-uwp any-reg nl0-offset) + (:temp next-uwp any-reg nl1-offset) + (:temp target-uwp any-reg nl2-offset)) (declare (ignore start count)) (let ((error (generate-error-code nil invalid-unwind-error))) (inst cmpwi block 0) (inst beq error)) - + (load-symbol-value cur-uwp *current-unwind-protect-block*) (loadw target-uwp block unwind-block-current-uwp-slot) (inst cmpw cur-uwp target-uwp) (inst bne do-uwp) - + (move cur-uwp block) DO-EXIT - + (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) (loadw code-tn cur-uwp unwind-block-current-code-slot) (loadw lra cur-uwp unwind-block-entry-pc-slot) @@ -178,31 +178,31 @@ (inst b do-exit)) (define-assembly-routine (throw - (:return-style :none)) - ((:arg target descriptor-reg a0-offset) - (:arg start any-reg ocfp-offset) - (:arg count any-reg nargs-offset) - (:temp catch any-reg a1-offset) - (:temp tag descriptor-reg a2-offset)) - + (:return-style :none)) + ((:arg target descriptor-reg a0-offset) + (:arg start any-reg ocfp-offset) + (:arg count any-reg nargs-offset) + (:temp catch any-reg a1-offset) + (:temp tag descriptor-reg a2-offset)) + (declare (ignore start count)) (load-symbol-value catch *current-catch-block*) - + loop - + (let ((error (generate-error-code nil unseen-throw-tag-error target))) (inst cmpwi catch 0) (inst beq error)) - + (loadw tag catch catch-block-tag-slot) (inst cmpw tag target) (inst beq exit) (loadw catch catch catch-block-previous-catch-slot) (inst b loop) - + exit - + (move target catch) (inst ba (make-fixup 'unwind :assembly-routine))) diff --git a/src/assembly/ppc/support.lisp b/src/assembly/ppc/support.lisp index 512e4c1..d15bc71 100644 --- a/src/assembly/ppc/support.lisp +++ b/src/assembly/ppc/support.lisp @@ -14,38 +14,38 @@ (!def-vm-support-routine generate-call-sequence (name style vop) (ecase style ((:raw :none) - (values + (values `((inst bla (make-fixup ',name :assembly-routine))) `())) (:full-call (let ((temp (make-symbol "TEMP")) - (nfp-save (make-symbol "NFP-SAVE")) - (lra (make-symbol "LRA"))) + (nfp-save (make-symbol "NFP-SAVE")) + (lra (make-symbol "LRA"))) (values - `((let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn ,vop))) - (when cur-nfp - (store-stack-tn ,nfp-save cur-nfp)) - (inst compute-lra-from-code ,lra code-tn lra-label ,temp) - (note-next-instruction ,vop :call-site) + `((let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn ,vop))) + (when cur-nfp + (store-stack-tn ,nfp-save cur-nfp)) + (inst compute-lra-from-code ,lra code-tn lra-label ,temp) + (note-next-instruction ,vop :call-site) (inst ba (make-fixup ',name :assembly-routine)) - (emit-return-pc lra-label) - (note-this-location ,vop :single-value-return) - (without-scheduling () - (move csp-tn ocfp-tn) - (inst nop)) - (inst compute-code-from-lra code-tn code-tn - lra-label ,temp) - (when cur-nfp - (load-stack-tn cur-nfp ,nfp-save)))) - `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) - ,temp) - (:temporary (:sc descriptor-reg :offset lra-offset - :from (:eval 0) :to (:eval 1)) - ,lra) - (:temporary (:scs (control-stack) :offset nfp-save-offset) - ,nfp-save) - (:save-p :compute-only))))))) + (emit-return-pc lra-label) + (note-this-location ,vop :single-value-return) + (without-scheduling () + (move csp-tn ocfp-tn) + (inst nop)) + (inst compute-code-from-lra code-tn code-tn + lra-label ,temp) + (when cur-nfp + (load-stack-tn cur-nfp ,nfp-save)))) + `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) + ,temp) + (:temporary (:sc descriptor-reg :offset lra-offset + :from (:eval 0) :to (:eval 1)) + ,lra) + (:temporary (:scs (control-stack) :offset nfp-save-offset) + ,nfp-save) + (:save-p :compute-only))))))) (!def-vm-support-routine generate-return-sequence (style) (ecase style @@ -53,12 +53,12 @@ `((inst blr))) (:full-call `((lisp-return (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg ) - :offset lra-offset) - (make-random-tn :kind :normal - :sc (sc-or-lose 'interior-reg ) - :offset lip-offset) - :offset 2))) + :sc (sc-or-lose 'descriptor-reg ) + :offset lra-offset) + (make-random-tn :kind :normal + :sc (sc-or-lose 'interior-reg ) + :offset lip-offset) + :offset 2))) (:none))) (defun return-machine-address (scp) diff --git a/src/assembly/sparc/arith.lisp b/src/assembly/sparc/arith.lisp index a299846..61278cc 100644 --- a/src/assembly/sparc/arith.lisp +++ b/src/assembly/sparc/arith.lisp @@ -14,21 +14,21 @@ ;;;; Addition and subtraction. (define-assembly-routine (generic-+ - (:cost 10) - (:return-style :full-call) - (:translate +) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp temp2 non-descriptor-reg nl1-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:translate +) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst andcc zero-tn x fixnum-tag-mask) (inst b :ne DO-STATIC-FUN) (inst andcc zero-tn y fixnum-tag-mask) @@ -50,7 +50,7 @@ (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j code-tn - (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) + (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) (inst move cfp-tn csp-tn) DONE @@ -58,21 +58,21 @@ (define-assembly-routine (generic-- - (:cost 10) - (:return-style :full-call) - (:translate -) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp temp2 non-descriptor-reg nl1-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:translate -) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp temp2 non-descriptor-reg nl1-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst andcc zero-tn x fixnum-tag-mask) (inst b :ne DO-STATIC-FUN) (inst andcc zero-tn y fixnum-tag-mask) @@ -94,7 +94,7 @@ (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j code-tn - (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) + (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) (inst move cfp-tn csp-tn) DONE @@ -106,22 +106,22 @@ (define-assembly-routine (generic-* - (:cost 50) - (:return-style :full-call) - (:translate *) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res (descriptor-reg any-reg) a0-offset) - - (:temp temp non-descriptor-reg nl0-offset) - (:temp lo non-descriptor-reg nl1-offset) - (:temp hi non-descriptor-reg nl2-offset) - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 50) + (:return-style :full-call) + (:translate *) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res (descriptor-reg any-reg) a0-offset) + + (:temp temp non-descriptor-reg nl0-offset) + (:temp lo non-descriptor-reg nl1-offset) + (:temp hi non-descriptor-reg nl2-offset) + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) ;; If either arg is not a fixnum, call the static function. (inst andcc zero-tn x fixnum-tag-mask) (inst b :ne DO-STATIC-FUN) @@ -143,7 +143,7 @@ (inst move lo hi) (inst srax hi 32)) ((or (member :sparc-v8 *backend-subfeatures*) - (member :sparc-v9 *backend-subfeatures*)) + (member :sparc-v9 *backend-subfeatures*)) (inst smul lo temp y) (inst rdy hi)) (t @@ -153,7 +153,7 @@ (inst nop) (inst nop) (dotimes (i 32) - (inst mulscc hi y)) + (inst mulscc hi y)) (inst mulscc hi zero-tn) (inst cmp x) (inst b :ge MULTIPLIER-POSITIVE) @@ -174,21 +174,21 @@ ;; Allocate a BIGNUM for the result. #+nil (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset))) - (let ((one-word (gen-label))) - (inst or res alloc-tn other-pointer-lowtag) - ;; We start out assuming that we need one word. Is that correct? - (inst sra temp lo 31) - (inst xorcc temp hi) - (inst b :eq one-word) - (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag)) - ;; Nope, we need two, so allocate the addition space. - (inst add alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset)) - (pad-data-block (1+ bignum-digits-offset)))) - (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag)) - (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag) - (emit-label one-word) - (storew temp res 0 other-pointer-lowtag) - (storew lo res bignum-digits-offset other-pointer-lowtag))) + (let ((one-word (gen-label))) + (inst or res alloc-tn other-pointer-lowtag) + ;; We start out assuming that we need one word. Is that correct? + (inst sra temp lo 31) + (inst xorcc temp hi) + (inst b :eq one-word) + (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag)) + ;; Nope, we need two, so allocate the addition space. + (inst add alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset)) + (pad-data-block (1+ bignum-digits-offset)))) + (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag)) + (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag) + (emit-label one-word) + (storew temp res 0 other-pointer-lowtag) + (storew lo res bignum-digits-offset other-pointer-lowtag))) ;; Always allocate 2 words for the bignum result, even if we only ;; need one. The copying GC will take care of the extra word if it ;; isn't needed. @@ -210,13 +210,13 @@ (storew lo res bignum-digits-offset other-pointer-lowtag))) ;; Out of here (lisp-return lra :offset 2) - + DO-STATIC-FUN (inst ld code-tn null-tn (static-fun-offset 'two-arg-*)) (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j code-tn - (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) + (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) (inst move cfp-tn csp-tn) LOW-FITS-IN-FIXNUM @@ -225,36 +225,36 @@ (macrolet ((frob (name note cost type sc) `(define-assembly-routine (,name - (:note ,note) - (:cost ,cost) - (:translate *) - (:policy :fast-safe) - (:arg-types ,type ,type) - (:result-types ,type)) - ((:arg x ,sc nl0-offset) - (:arg y ,sc nl1-offset) - (:res res ,sc nl0-offset) - (:temp temp ,sc nl2-offset)) - ,@(when (eq type 'tagged-num) - `((inst sra x 2))) - (cond - ((member :sparc-64 *backend-subfeatures*) - ;; Sign extend, then multiply - (inst sra x 0) - (inst sra y 0) - (inst mulx res x y)) - ((or (member :sparc-v8 *backend-subfeatures*) - (member :sparc-v9 *backend-subfeatures*)) - (inst smul res x y)) - (t - (inst wry x) - (inst andcc temp zero-tn) - (inst nop) - (inst nop) - (dotimes (i 32) - (inst mulscc temp y)) - (inst mulscc temp zero-tn) - (inst rdy res)))))) + (:note ,note) + (:cost ,cost) + (:translate *) + (:policy :fast-safe) + (:arg-types ,type ,type) + (:result-types ,type)) + ((:arg x ,sc nl0-offset) + (:arg y ,sc nl1-offset) + (:res res ,sc nl0-offset) + (:temp temp ,sc nl2-offset)) + ,@(when (eq type 'tagged-num) + `((inst sra x 2))) + (cond + ((member :sparc-64 *backend-subfeatures*) + ;; Sign extend, then multiply + (inst sra x 0) + (inst sra y 0) + (inst mulx res x y)) + ((or (member :sparc-v8 *backend-subfeatures*) + (member :sparc-v9 *backend-subfeatures*)) + (inst smul res x y)) + (t + (inst wry x) + (inst andcc temp zero-tn) + (inst nop) + (inst nop) + (dotimes (i 32) + (inst mulscc temp y)) + (inst mulscc temp zero-tn) + (inst rdy res)))))) (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg) (frob signed-* "unsigned *" 41 signed-num signed-reg) (frob fixnum-* "fixnum *" 30 tagged-num any-reg)) @@ -268,42 +268,42 @@ (inst li quo 0) (labels ((do-loop (depth) - (cond - ((zerop depth) - (inst unimp 0)) - (t - (let ((label-1 (gen-label)) - (label-2 (gen-label))) - (inst cmp divisor rem) - (inst b :geu label-1) - (inst nop) - (inst sll divisor 1) - (do-loop (1- depth)) - (inst srl divisor 1) - (inst cmp divisor rem) - (emit-label label-1) - (inst b :gtu label-2) - (inst sll quo 1) - (inst add quo (if tagged (fixnumize 1) 1)) - (inst sub rem divisor) - (emit-label label-2)))))) + (cond + ((zerop depth) + (inst unimp 0)) + (t + (let ((label-1 (gen-label)) + (label-2 (gen-label))) + (inst cmp divisor rem) + (inst b :geu label-1) + (inst nop) + (inst sll divisor 1) + (do-loop (1- depth)) + (inst srl divisor 1) + (inst cmp divisor rem) + (emit-label label-1) + (inst b :gtu label-2) + (inst sll quo 1) + (inst add quo (if tagged (fixnumize 1) 1)) + (inst sub rem divisor) + (emit-label label-2)))))) (do-loop (if tagged 30 32)))) (define-assembly-routine (positive-fixnum-truncate - (:note "unsigned fixnum truncate") - (:cost 45) - (:translate truncate) - (:policy :fast-safe) - (:arg-types positive-fixnum positive-fixnum) - (:result-types positive-fixnum positive-fixnum)) - ((:arg dividend any-reg nl0-offset) - (:arg divisor any-reg nl1-offset) - - (:res quo any-reg nl2-offset) - (:res rem any-reg nl0-offset)) + (:note "unsigned fixnum truncate") + (:cost 45) + (:translate truncate) + (:policy :fast-safe) + (:arg-types positive-fixnum positive-fixnum) + (:result-types positive-fixnum positive-fixnum)) + ((:arg dividend any-reg nl0-offset) + (:arg divisor any-reg nl1-offset) + + (:res quo any-reg nl2-offset) + (:res rem any-reg nl0-offset)) (let ((error (generate-error-code nil division-by-zero-error - dividend divisor))) + dividend divisor))) (inst cmp divisor) (inst b :eq error)) @@ -312,23 +312,23 @@ (define-assembly-routine (fixnum-truncate - (:note "fixnum truncate") - (:cost 50) - (:policy :fast-safe) - (:translate truncate) - (:arg-types tagged-num tagged-num) - (:result-types tagged-num tagged-num)) - ((:arg dividend any-reg nl0-offset) - (:arg divisor any-reg nl1-offset) - - (:res quo any-reg nl2-offset) - (:res rem any-reg nl0-offset) - - (:temp quo-sign any-reg nl5-offset) - (:temp rem-sign any-reg nargs-offset)) - + (:note "fixnum truncate") + (:cost 50) + (:policy :fast-safe) + (:translate truncate) + (:arg-types tagged-num tagged-num) + (:result-types tagged-num tagged-num)) + ((:arg dividend any-reg nl0-offset) + (:arg divisor any-reg nl1-offset) + + (:res quo any-reg nl2-offset) + (:res rem any-reg nl0-offset) + + (:temp quo-sign any-reg nl5-offset) + (:temp rem-sign any-reg nargs-offset)) + (let ((error (generate-error-code nil division-by-zero-error - dividend divisor))) + dividend divisor))) (inst cmp divisor) (inst b :eq error)) @@ -361,24 +361,24 @@ (define-assembly-routine (signed-truncate - (:note "(signed-byte 32) truncate") - (:cost 60) - (:policy :fast-safe) - (:translate truncate) - (:arg-types signed-num signed-num) - (:result-types signed-num signed-num)) - - ((:arg dividend signed-reg nl0-offset) - (:arg divisor signed-reg nl1-offset) - - (:res quo signed-reg nl2-offset) - (:res rem signed-reg nl0-offset) - - (:temp quo-sign signed-reg nl5-offset) - (:temp rem-sign signed-reg nargs-offset)) - + (:note "(signed-byte 32) truncate") + (:cost 60) + (:policy :fast-safe) + (:translate truncate) + (:arg-types signed-num signed-num) + (:result-types signed-num signed-num)) + + ((:arg dividend signed-reg nl0-offset) + (:arg divisor signed-reg nl1-offset) + + (:res quo signed-reg nl2-offset) + (:res rem signed-reg nl0-offset) + + (:temp quo-sign signed-reg nl5-offset) + (:temp rem-sign signed-reg nargs-offset)) + (let ((error (generate-error-code nil division-by-zero-error - dividend divisor))) + dividend divisor))) (inst cmp divisor) (inst b :eq error)) @@ -415,37 +415,37 @@ (macrolet ((define-cond-assem-rtn (name translate static-fn cmp) `(define-assembly-routine (,name - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate ,translate) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) - (inst andcc zero-tn x fixnum-tag-mask) - (inst b :ne DO-STATIC-FN) - (inst andcc zero-tn y fixnum-tag-mask) - (inst b :eq DO-COMPARE) - (inst cmp x y) - - DO-STATIC-FN - (inst ld code-tn null-tn (static-fun-offset ',static-fn)) - (inst li nargs (fixnumize 2)) - (inst move ocfp cfp-tn) - (inst j code-tn - (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) - (inst move cfp-tn csp-tn) - - DO-COMPARE - (inst b ,cmp done) - (load-symbol res t) - (inst move res null-tn) - DONE))) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) + (inst andcc zero-tn x fixnum-tag-mask) + (inst b :ne DO-STATIC-FN) + (inst andcc zero-tn y fixnum-tag-mask) + (inst b :eq DO-COMPARE) + (inst cmp x y) + + DO-STATIC-FN + (inst ld code-tn null-tn (static-fun-offset ',static-fn)) + (inst li nargs (fixnumize 2)) + (inst move ocfp cfp-tn) + (inst j code-tn + (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) + (inst move cfp-tn csp-tn) + + DO-COMPARE + (inst b ,cmp done) + (load-symbol res t) + (inst move res null-tn) + DONE))) (define-cond-assem-rtn generic-< < two-arg-< :lt) (define-cond-assem-rtn generic-<= <= two-arg-<= :le) @@ -454,19 +454,19 @@ (define-assembly-routine (generic-eql - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate eql) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst cmp x y) (inst b :eq RETURN-T) (inst andcc zero-tn x fixnum-tag-mask) @@ -484,26 +484,26 @@ (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j code-tn - (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) + (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) (inst move cfp-tn csp-tn) RETURN-T (load-symbol res t)) (define-assembly-routine (generic-= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate =) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst andcc zero-tn x fixnum-tag-mask) (inst b :ne DO-STATIC-FN) (inst andcc zero-tn y fixnum-tag-mask) @@ -520,26 +520,26 @@ (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j code-tn - (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) + (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) (inst move cfp-tn csp-tn) RETURN-T (load-symbol res t)) (define-assembly-routine (generic-/= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate /=) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) a0-offset) - (:arg y (descriptor-reg any-reg) a1-offset) - - (:res res descriptor-reg a0-offset) - - (:temp lra descriptor-reg lra-offset) - (:temp nargs any-reg nargs-offset) - (:temp ocfp any-reg ocfp-offset)) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate /=) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) a0-offset) + (:arg y (descriptor-reg any-reg) a1-offset) + + (:res res descriptor-reg a0-offset) + + (:temp lra descriptor-reg lra-offset) + (:temp nargs any-reg nargs-offset) + (:temp ocfp any-reg ocfp-offset)) (inst cmp x y) (inst b :eq RETURN-NIL) (inst andcc zero-tn x fixnum-tag-mask) @@ -556,7 +556,7 @@ (inst li nargs (fixnumize 2)) (inst move ocfp cfp-tn) (inst j code-tn - (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) + (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag)) (inst move cfp-tn csp-tn) RETURN-NIL diff --git a/src/assembly/sparc/array.lisp b/src/assembly/sparc/array.lisp index 717fa07..1bd9e20 100644 --- a/src/assembly/sparc/array.lisp +++ b/src/assembly/sparc/array.lisp @@ -12,18 +12,18 @@ (in-package "SB!VM") (define-assembly-routine (allocate-vector - (:policy :fast-safe) - (:translate allocate-vector) - (:arg-types positive-fixnum - positive-fixnum - positive-fixnum)) - ((:arg type any-reg a0-offset) - (:arg length any-reg a1-offset) - (:arg words any-reg a2-offset) - (:res result descriptor-reg a0-offset) + (:policy :fast-safe) + (:translate allocate-vector) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum)) + ((:arg type any-reg a0-offset) + (:arg length any-reg a1-offset) + (:arg words any-reg a2-offset) + (:res result descriptor-reg a0-offset) - (:temp ndescr non-descriptor-reg nl0-offset) - (:temp vector descriptor-reg a3-offset)) + (:temp ndescr non-descriptor-reg nl0-offset) + (:temp vector descriptor-reg a3-offset)) (pseudo-atomic () (inst or vector alloc-tn other-pointer-lowtag) ;; boxed words == unboxed bytes diff --git a/src/assembly/sparc/assem-rtns.lisp b/src/assembly/sparc/assem-rtns.lisp index c3fd3ef..1957b6c 100644 --- a/src/assembly/sparc/assem-rtns.lisp +++ b/src/assembly/sparc/assem-rtns.lisp @@ -69,7 +69,7 @@ (inst add dst n-word-bytes) (inst b :gt loop) (inst subcc count (fixnumize 1)) - + (inst b done) (inst nop) @@ -85,12 +85,12 @@ DEFAULT-A5-AND-ON (inst move a5 null-tn) DONE - + ;; Clear the stack. (move ocfp-tn cfp-tn) (move cfp-tn ocfp) (inst add csp-tn ocfp-tn nvals) - + ;; Return. (lisp-return lra)) @@ -127,7 +127,7 @@ ;; Calculate NARGS (as a fixnum) (inst sub nargs csp-tn args) - + ;; Load the argument regs (must do this now, 'cause the blt might ;; trash these locations) (inst ld a0 args (* 0 n-word-bytes)) @@ -142,7 +142,7 @@ (inst b :le done) (inst add src args (* n-word-bytes register-arg-count)) (inst add dst cfp-tn (* n-word-bytes register-arg-count)) - + LOOP ;; Copy one arg. (inst ld temp src) @@ -151,7 +151,7 @@ (inst addcc count (fixnumize -1)) (inst b :gt loop) (inst add dst dst n-word-bytes) - + DONE ;; We are done. Do the jump. (loadw temp lexenv closure-fun-slot fun-pointer-lowtag) @@ -162,32 +162,32 @@ ;;;; Non-local exit noise. (define-assembly-routine (unwind - (:return-style :none) - (:translate %continue-unwind) - (:policy :fast-safe)) - ((:arg block (any-reg descriptor-reg) a0-offset) - (:arg start (any-reg descriptor-reg) ocfp-offset) - (:arg count (any-reg descriptor-reg) nargs-offset) - (:temp lra descriptor-reg lra-offset) - (:temp cur-uwp any-reg nl0-offset) - (:temp next-uwp any-reg nl1-offset) - (:temp target-uwp any-reg nl2-offset)) + (:return-style :none) + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) a0-offset) + (:arg start (any-reg descriptor-reg) ocfp-offset) + (:arg count (any-reg descriptor-reg) nargs-offset) + (:temp lra descriptor-reg lra-offset) + (:temp cur-uwp any-reg nl0-offset) + (:temp next-uwp any-reg nl1-offset) + (:temp target-uwp any-reg nl2-offset)) (declare (ignore start count)) (let ((error (generate-error-code nil invalid-unwind-error))) (inst cmp block) (inst b :eq error)) - + (load-symbol-value cur-uwp *current-unwind-protect-block*) (loadw target-uwp block unwind-block-current-uwp-slot) (inst cmp cur-uwp target-uwp) (inst b :ne do-uwp) (inst nop) - + (move cur-uwp block) DO-EXIT - + (loadw cfp-tn cur-uwp unwind-block-current-cont-slot) (loadw code-tn cur-uwp unwind-block-current-code-slot) (loadw lra cur-uwp unwind-block-entry-pc-slot) @@ -201,25 +201,25 @@ (define-assembly-routine (throw - (:return-style :none)) - ((:arg target descriptor-reg a0-offset) - (:arg start any-reg ocfp-offset) - (:arg count any-reg nargs-offset) - (:temp catch any-reg a1-offset) - (:temp tag descriptor-reg a2-offset) - (:temp temp non-descriptor-reg nl0-offset)) - + (:return-style :none)) + ((:arg target descriptor-reg a0-offset) + (:arg start any-reg ocfp-offset) + (:arg count any-reg nargs-offset) + (:temp catch any-reg a1-offset) + (:temp tag descriptor-reg a2-offset) + (:temp temp non-descriptor-reg nl0-offset)) + (declare (ignore start count)) (load-symbol-value catch *current-catch-block*) - + loop - + (let ((error (generate-error-code nil unseen-throw-tag-error target))) (inst cmp catch) (inst b :eq error) (inst nop)) - + (loadw tag catch catch-block-tag-slot) (inst cmp tag target) (inst b :eq exit) @@ -227,9 +227,9 @@ (loadw catch catch catch-block-previous-catch-slot) (inst b loop) (inst nop) - + exit - + (move target catch) (inst li temp (make-fixup 'unwind :assembly-routine)) (inst j temp) diff --git a/src/assembly/sparc/support.lisp b/src/assembly/sparc/support.lisp index 42d4f0d..edb29f9 100644 --- a/src/assembly/sparc/support.lisp +++ b/src/assembly/sparc/support.lisp @@ -15,59 +15,59 @@ (ecase style ((:raw :none) (let ((temp (make-symbol "TEMP")) - (lip (make-symbol "LIP"))) - (values - `((inst jali ,lip ,temp (make-fixup ',name :assembly-routine)) - (inst nop)) - `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) - ,temp) - (:temporary (:scs (interior-reg) :from (:eval 0) :to (:eval 1)) - ,lip))))) + (lip (make-symbol "LIP"))) + (values + `((inst jali ,lip ,temp (make-fixup ',name :assembly-routine)) + (inst nop)) + `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) + ,temp) + (:temporary (:scs (interior-reg) :from (:eval 0) :to (:eval 1)) + ,lip))))) (:full-call (let ((temp (make-symbol "TEMP")) - (nfp-save (make-symbol "NFP-SAVE")) - (lra (make-symbol "LRA"))) + (nfp-save (make-symbol "NFP-SAVE")) + (lra (make-symbol "LRA"))) (values - `((let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn ,vop))) - (when cur-nfp - (store-stack-tn ,nfp-save cur-nfp)) - (inst compute-lra-from-code ,lra code-tn lra-label ,temp) - (note-next-instruction ,vop :call-site) - (inst ji ,temp (make-fixup ',name :assembly-routine)) - (inst nop) - (emit-return-pc lra-label) - (note-this-location ,vop :single-value-return) - (without-scheduling () - (move csp-tn ocfp-tn) - (inst nop)) - (inst compute-code-from-lra code-tn code-tn - lra-label ,temp) - (when cur-nfp - (load-stack-tn cur-nfp ,nfp-save)))) - `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) - ,temp) - (:temporary (:sc descriptor-reg :offset lra-offset - :from (:eval 0) :to (:eval 1)) - ,lra) - (:temporary (:scs (control-stack) :offset nfp-save-offset) - ,nfp-save) - (:save-p :compute-only))))))) + `((let ((lra-label (gen-label)) + (cur-nfp (current-nfp-tn ,vop))) + (when cur-nfp + (store-stack-tn ,nfp-save cur-nfp)) + (inst compute-lra-from-code ,lra code-tn lra-label ,temp) + (note-next-instruction ,vop :call-site) + (inst ji ,temp (make-fixup ',name :assembly-routine)) + (inst nop) + (emit-return-pc lra-label) + (note-this-location ,vop :single-value-return) + (without-scheduling () + (move csp-tn ocfp-tn) + (inst nop)) + (inst compute-code-from-lra code-tn code-tn + lra-label ,temp) + (when cur-nfp + (load-stack-tn cur-nfp ,nfp-save)))) + `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) + ,temp) + (:temporary (:sc descriptor-reg :offset lra-offset + :from (:eval 0) :to (:eval 1)) + ,lra) + (:temporary (:scs (control-stack) :offset nfp-save-offset) + ,nfp-save) + (:save-p :compute-only))))))) (!def-vm-support-routine generate-return-sequence (style) (ecase style (:raw `((inst j - (make-random-tn :kind :normal - :sc (sc-or-lose 'interior-reg) - :offset lip-offset) - 8) + (make-random-tn :kind :normal + :sc (sc-or-lose 'interior-reg) + :offset lip-offset) + 8) (inst nop))) (:full-call `((lisp-return (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset lra-offset) - :offset 2))) + :sc (sc-or-lose 'descriptor-reg) + :offset lra-offset) + :offset 2))) (:none))) (defun return-machine-address (scp) diff --git a/src/assembly/x86-64/arith.lisp b/src/assembly/x86-64/arith.lisp index a6f4d5e..ef19c4f 100644 --- a/src/assembly/x86-64/arith.lisp +++ b/src/assembly/x86-64/arith.lisp @@ -14,54 +14,54 @@ ;;;; addition, subtraction, and multiplication (macrolet ((define-generic-arith-routine ((fun cost) &body body) - `(define-assembly-routine (,(symbolicate "GENERIC-" fun) - (:cost ,cost) - (:return-style :full-call) - (:translate ,fun) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) rdx-offset) - (:arg y (descriptor-reg any-reg) - ;; this seems wrong esi-offset -- FIXME: What's it mean? - rdi-offset) - - (:res res (descriptor-reg any-reg) rdx-offset) - - (:temp rax unsigned-reg rax-offset) - (:temp rbx unsigned-reg rbx-offset) - (:temp rcx unsigned-reg rcx-offset)) - - (declare (ignorable rbx)) - - (inst test x 7) ; fixnum? - (inst jmp :nz DO-STATIC-FUN) ; no - do generic - (inst test y 7) ; fixnum? - (inst jmp :z DO-BODY) ; yes - doit here - - DO-STATIC-FUN - (inst pop rax) - (inst push rbp-tn) - (inst lea - rbp-tn - (make-ea :qword :base rsp-tn :disp n-word-bytes)) - (inst sub rsp-tn (fixnumize 2)) - (inst push rax) ; callers return addr - (inst mov rcx (fixnumize 2)) ; arg count - (inst jmp - (make-ea :qword - :disp (+ nil-value - (static-fun-offset - ',(symbolicate "TWO-ARG-" fun))))) - - DO-BODY - ,@body))) + `(define-assembly-routine (,(symbolicate "GENERIC-" fun) + (:cost ,cost) + (:return-style :full-call) + (:translate ,fun) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) rdx-offset) + (:arg y (descriptor-reg any-reg) + ;; this seems wrong esi-offset -- FIXME: What's it mean? + rdi-offset) + + (:res res (descriptor-reg any-reg) rdx-offset) + + (:temp rax unsigned-reg rax-offset) + (:temp rbx unsigned-reg rbx-offset) + (:temp rcx unsigned-reg rcx-offset)) + + (declare (ignorable rbx)) + + (inst test x 7) ; fixnum? + (inst jmp :nz DO-STATIC-FUN) ; no - do generic + (inst test y 7) ; fixnum? + (inst jmp :z DO-BODY) ; yes - doit here + + DO-STATIC-FUN + (inst pop rax) + (inst push rbp-tn) + (inst lea + rbp-tn + (make-ea :qword :base rsp-tn :disp n-word-bytes)) + (inst sub rsp-tn (fixnumize 2)) + (inst push rax) ; callers return addr + (inst mov rcx (fixnumize 2)) ; arg count + (inst jmp + (make-ea :qword + :disp (+ nil-value + (static-fun-offset + ',(symbolicate "TWO-ARG-" fun))))) + + DO-BODY + ,@body))) (define-generic-arith-routine (+ 10) (move res x) (inst add res y) (inst jmp :no OKAY) - (inst rcr res 1) ; carry has correct sign - (inst sar res 2) ; remove type bits + (inst rcr res 1) ; carry has correct sign + (inst sar res 2) ; remove type bits (move rcx res) @@ -76,7 +76,7 @@ (inst jmp :no OKAY) (inst cmc) ; carry has correct sign now (inst rcr res 1) - (inst sar res 2) ; remove type bits + (inst sar res 2) ; remove type bits (move rcx res) @@ -85,19 +85,19 @@ OKAY) (define-generic-arith-routine (* 30) - (move rax x) ; must use eax for 64-bit result - (inst sar rax 3) ; remove *4 fixnum bias - (inst imul y) ; result in edx:eax - (inst jmp :no OKAY) ; still fixnum + (move rax x) ; must use eax for 64-bit result + (inst sar rax 3) ; remove *4 fixnum bias + (inst imul y) ; result in edx:eax + (inst jmp :no OKAY) ; still fixnum ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above ;; pfw says that loses big -- edx is target for arg x and result res ;; note that 'edx' is not defined -- using x - (inst shrd rax x 3) ; high bits from edx - (inst sar x 3) ; now shift edx too + (inst shrd rax x 3) ; high bits from edx + (inst sar x 3) ; now shift edx too - (move rcx x) ; save high bits from cqo - (inst cqo) ; edx:eax <- sign-extend of eax + (move rcx x) ; save high bits from cqo + (inst cqo) ; edx:eax <- sign-extend of eax (inst cmp x rcx) (inst jmp :e SINGLE-WORD-BIGNUM) @@ -119,16 +119,16 @@ ;;;; negation (define-assembly-routine (generic-negate - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate %negate) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) rdx-offset) - (:res res (descriptor-reg any-reg) rdx-offset) - - (:temp rax unsigned-reg rax-offset) - (:temp rcx unsigned-reg rcx-offset)) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate %negate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) rdx-offset) + (:res res (descriptor-reg any-reg) rdx-offset) + + (:temp rax unsigned-reg rax-offset) + (:temp rcx unsigned-reg rcx-offset)) (inst test x 7) (inst jmp :z FIXNUM) @@ -137,15 +137,15 @@ (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes)) (inst sub rsp-tn (fixnumize 2)) (inst push rax) - (inst mov rcx (fixnumize 1)) ; arg count + (inst mov rcx (fixnumize 1)) ; arg count (inst jmp (make-ea :qword - :disp (+ nil-value (static-fun-offset '%negate)))) + :disp (+ nil-value (static-fun-offset '%negate)))) FIXNUM (move res x) - (inst neg res) ; (- most-negative-fixnum) is BIGNUM + (inst neg res) ; (- most-negative-fixnum) is BIGNUM (inst jmp :no OKAY) - (inst shr res 3) ; sign bit is data - remove type bits + (inst shr res 3) ; sign bit is data - remove type bits (move rcx res) (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) @@ -156,78 +156,78 @@ ;;;; comparison (macrolet ((define-cond-assem-rtn (name translate static-fn test) - `(define-assembly-routine (,name - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate ,translate) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) rdx-offset) - (:arg y (descriptor-reg any-reg) rdi-offset) - - (:res res descriptor-reg rdx-offset) - - (:temp eax unsigned-reg rax-offset) - (:temp ecx unsigned-reg rcx-offset)) - - ;; KLUDGE: The "3" here is a mask for the bits which will be - ;; zero in a fixnum. It should have a symbolic name. (Actually, - ;; it might already have a symbolic name which the coder - ;; couldn't be bothered to use..) -- WHN 19990917 - (inst test x 7) - (inst jmp :nz TAIL-CALL-TO-STATIC-FN) - (inst test y 7) - (inst jmp :z INLINE-FIXNUM-COMPARE) - - TAIL-CALL-TO-STATIC-FN - (inst pop eax) - (inst push rbp-tn) - (inst lea rbp-tn (make-ea :qword - :base rsp-tn - :disp n-word-bytes)) - (inst sub rsp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack, - ; weirdly? - (inst push eax) - (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and - ; SINGLE-FLOAT-BITS are parallel, - ; should be named parallelly. - (inst jmp (make-ea :qword - :disp (+ nil-value - (static-fun-offset ',static-fn)))) - - INLINE-FIXNUM-COMPARE - (inst cmp x y) - (inst jmp ,test RETURN-TRUE) - (inst mov res nil-value) - ;; FIXME: A note explaining this return convention, or a - ;; symbolic name for it, would be nice. (It looks as though we - ;; should be hand-crafting the same return sequence as would be - ;; produced by GENERATE-RETURN-SEQUENCE, but in that case it's - ;; not clear why we don't just jump to the end of this function - ;; to share the return sequence there. - (inst pop eax) - (inst add eax 3) - (inst jmp eax) - - RETURN-TRUE - (load-symbol res t)))) + `(define-assembly-routine (,name + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) rdx-offset) + (:arg y (descriptor-reg any-reg) rdi-offset) + + (:res res descriptor-reg rdx-offset) + + (:temp eax unsigned-reg rax-offset) + (:temp ecx unsigned-reg rcx-offset)) + + ;; KLUDGE: The "3" here is a mask for the bits which will be + ;; zero in a fixnum. It should have a symbolic name. (Actually, + ;; it might already have a symbolic name which the coder + ;; couldn't be bothered to use..) -- WHN 19990917 + (inst test x 7) + (inst jmp :nz TAIL-CALL-TO-STATIC-FN) + (inst test y 7) + (inst jmp :z INLINE-FIXNUM-COMPARE) + + TAIL-CALL-TO-STATIC-FN + (inst pop eax) + (inst push rbp-tn) + (inst lea rbp-tn (make-ea :qword + :base rsp-tn + :disp n-word-bytes)) + (inst sub rsp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack, + ; weirdly? + (inst push eax) + (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and + ; SINGLE-FLOAT-BITS are parallel, + ; should be named parallelly. + (inst jmp (make-ea :qword + :disp (+ nil-value + (static-fun-offset ',static-fn)))) + + INLINE-FIXNUM-COMPARE + (inst cmp x y) + (inst jmp ,test RETURN-TRUE) + (inst mov res nil-value) + ;; FIXME: A note explaining this return convention, or a + ;; symbolic name for it, would be nice. (It looks as though we + ;; should be hand-crafting the same return sequence as would be + ;; produced by GENERATE-RETURN-SEQUENCE, but in that case it's + ;; not clear why we don't just jump to the end of this function + ;; to share the return sequence there. + (inst pop eax) + (inst add eax 3) + (inst jmp eax) + + RETURN-TRUE + (load-symbol res t)))) (define-cond-assem-rtn generic-< < two-arg-< :l) (define-cond-assem-rtn generic-> > two-arg-> :g)) (define-assembly-routine (generic-eql - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate eql) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) rdx-offset) - (:arg y (descriptor-reg any-reg) rdi-offset) - - (:res res descriptor-reg rdx-offset) - - (:temp eax unsigned-reg rax-offset) - (:temp ecx unsigned-reg rcx-offset)) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) rdx-offset) + (:arg y (descriptor-reg any-reg) rdi-offset) + + (:res res descriptor-reg rdx-offset) + + (:temp eax unsigned-reg rax-offset) + (:temp ecx unsigned-reg rcx-offset)) (inst cmp x y) (inst jmp :e RETURN-T) (inst test x 7) @@ -249,7 +249,7 @@ (inst push eax) (inst mov ecx (fixnumize 2)) (inst jmp (make-ea :qword - :disp (+ nil-value (static-fun-offset 'eql)))) + :disp (+ nil-value (static-fun-offset 'eql)))) RETURN-T (load-symbol res t) @@ -257,25 +257,25 @@ ) (define-assembly-routine (generic-= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate =) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) rdx-offset) - (:arg y (descriptor-reg any-reg) rdi-offset) - - (:res res descriptor-reg rdx-offset) - - (:temp eax unsigned-reg rax-offset) - (:temp ecx unsigned-reg rcx-offset) - ) - (inst test x 7) ; descriptor? + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) rdx-offset) + (:arg y (descriptor-reg any-reg) rdi-offset) + + (:res res descriptor-reg rdx-offset) + + (:temp eax unsigned-reg rax-offset) + (:temp ecx unsigned-reg rcx-offset) + ) + (inst test x 7) ; descriptor? (inst jmp :nz DO-STATIC-FN) ; yes, do it here - (inst test y 7) ; descriptor? + (inst test y 7) ; descriptor? (inst jmp :nz DO-STATIC-FN) (inst cmp x y) - (inst jmp :e RETURN-T) ; ok + (inst jmp :e RETURN-T) ; ok (inst mov res nil-value) (inst pop eax) @@ -290,7 +290,7 @@ (inst push eax) (inst mov ecx (fixnumize 2)) (inst jmp (make-ea :qword - :disp (+ nil-value (static-fun-offset 'two-arg-=)))) + :disp (+ nil-value (static-fun-offset 'two-arg-=)))) RETURN-T (load-symbol res t)) diff --git a/src/assembly/x86-64/array.lisp b/src/assembly/x86-64/array.lisp index 7662427..226dbcb 100644 --- a/src/assembly/x86-64/array.lisp +++ b/src/assembly/x86-64/array.lisp @@ -15,17 +15,17 @@ ;;;; allocation (define-assembly-routine (allocate-vector - (:policy :fast-safe) - (:translate allocate-vector) - (:arg-types positive-fixnum - positive-fixnum - positive-fixnum)) - ((:arg type unsigned-reg eax-offset) - (:arg length any-reg ebx-offset) - (:arg words any-reg ecx-offset) - (:res result descriptor-reg edx-offset)) + (:policy :fast-safe) + (:translate allocate-vector) + (:arg-types positive-fixnum + positive-fixnum + positive-fixnum)) + ((:arg type unsigned-reg eax-offset) + (:arg length any-reg ebx-offset) + (:arg words any-reg ecx-offset) + (:res result descriptor-reg edx-offset)) (inst mov result (+ (1- (ash 1 n-lowtag-bits)) - (* vector-data-offset n-word-bytes))) + (* vector-data-offset n-word-bytes))) (inst add result words) (inst and result (lognot lowtag-mask)) (pseudo-atomic diff --git a/src/assembly/x86-64/assem-rtns.lisp b/src/assembly/x86-64/assem-rtns.lisp index 3687443..bd70889 100644 --- a/src/assembly/x86-64/assem-rtns.lisp +++ b/src/assembly/x86-64/assem-rtns.lisp @@ -48,9 +48,9 @@ ;; address. Therefore, we need to iterate from larger addresses to ;; smaller addresses. pfw-this says copy ecx words from esi to edi ;; counting down. - (inst shr ecx 3) ; fixnum to raw word count - (inst std) ; count down - (inst sub esi 8) ; ? + (inst shr ecx 3) ; fixnum to raw word count + (inst std) ; count down + (inst sub esi 8) ; ? (inst lea edi (make-ea :qword :base ebx :disp (- n-word-bytes))) (inst rep) (inst movs :qword) @@ -78,7 +78,7 @@ (inst jmp eax) ONE-VALUE ; Note: we can get this, because the return-multiple vop - ; doesn't check for this case when size > speed. + ; doesn't check for this case when size > speed. (loadw edx esi -1) (inst mov rsp-tn ebx) (inst add eax 3) @@ -140,8 +140,8 @@ ;; Do the blit. Because we are coping from smaller addresses to ;; larger addresses, we have to start at the largest pair and work ;; our way down. - (inst shr ecx 3) ; fixnum to raw words - (inst std) ; count down + (inst shr ecx 3) ; fixnum to raw words + (inst std) ; count down (inst lea edi (make-ea :qword :base rbp-tn :disp (- n-word-bytes))) (inst sub esi (fixnumize 1)) (inst rep) @@ -152,7 +152,7 @@ ;; Restore OLD-FP and ECX. (inst pop ecx) - (popw rbp-tn -1) ; overwrites a0 + (popw rbp-tn -1) ; overwrites a0 ;; Blow off the stack above the arguments. (inst lea rsp-tn (make-ea :qword :base edi :disp n-word-bytes)) @@ -166,9 +166,9 @@ ;; And jump into the function. (inst jmp - (make-ea :byte :base eax - :disp (- (* closure-fun-slot n-word-bytes) - fun-pointer-lowtag))) + (make-ea :byte :base eax + :disp (- (* closure-fun-slot n-word-bytes) + fun-pointer-lowtag))) ;; All the arguments fit in registers, so load them. REGISTER-ARGS @@ -178,22 +178,22 @@ ;; Clear most of the stack. (inst lea rsp-tn - (make-ea :qword :base rbp-tn :disp (* -3 n-word-bytes))) + (make-ea :qword :base rbp-tn :disp (* -3 n-word-bytes))) ;; Push the return-pc so it looks like we just called. - (pushw rbp-tn -2) ; XXX dan ? - + (pushw rbp-tn -2) ; XXX dan ? + ;; And away we go. (inst jmp (make-ea :byte :base eax - :disp (- (* closure-fun-slot n-word-bytes) - fun-pointer-lowtag)))) + :disp (- (* closure-fun-slot n-word-bytes) + fun-pointer-lowtag)))) (define-assembly-routine (throw - (:return-style :none)) - ((:arg target (descriptor-reg any-reg) rdx-offset) - (:arg start any-reg rbx-offset) - (:arg count any-reg rcx-offset) - (:temp catch any-reg rax-offset)) + (:return-style :none)) + ((:arg target (descriptor-reg any-reg) rdx-offset) + (:arg start any-reg rbx-offset) + (:arg count any-reg rcx-offset) + (:temp catch any-reg rax-offset)) (declare (ignore start count)) @@ -202,7 +202,7 @@ LOOP (let ((error (generate-error-code nil unseen-throw-tag-error target))) - (inst or catch catch) ; check for NULL pointer + (inst or catch catch) ; check for NULL pointer (inst jmp :z error)) (inst cmp target (make-ea-for-object-slot catch catch-block-tag-slot 0)) @@ -219,17 +219,17 @@ ;;;; non-local exit noise (define-assembly-routine (unwind - (:return-style :none) - (:translate %continue-unwind) - (:policy :fast-safe)) - ((:arg block (any-reg descriptor-reg) rax-offset) - (:arg start (any-reg descriptor-reg) rbx-offset) - (:arg count (any-reg descriptor-reg) rcx-offset) - (:temp uwp unsigned-reg rsi-offset)) + (:return-style :none) + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) rax-offset) + (:arg start (any-reg descriptor-reg) rbx-offset) + (:arg count (any-reg descriptor-reg) rcx-offset) + (:temp uwp unsigned-reg rsi-offset)) (declare (ignore start count)) (let ((error (generate-error-code nil invalid-unwind-error))) - (inst or block block) ; check for NULL pointer + (inst or block block) ; check for NULL pointer (inst jmp :z error)) (load-tl-symbol-value uwp *current-unwind-protect-block*) @@ -237,7 +237,7 @@ ;; Does *CURRENT-UNWIND-PROTECT-BLOCK* match the value stored in ;; argument's CURRENT-UWP-SLOT? (inst cmp uwp - (make-ea-for-object-slot block unwind-block-current-uwp-slot 0)) + (make-ea-for-object-slot block unwind-block-current-uwp-slot 0)) ;; If a match, return to context in arg block. (inst jmp :e DO-EXIT) @@ -260,4 +260,4 @@ ;; count in ecx-tn. (inst jmp (make-ea :byte :base block - :disp (* unwind-block-entry-pc-slot n-word-bytes)))) + :disp (* unwind-block-entry-pc-slot n-word-bytes)))) diff --git a/src/assembly/x86-64/support.lisp b/src/assembly/x86-64/support.lisp index e96ddbc..8f5e239 100644 --- a/src/assembly/x86-64/support.lisp +++ b/src/assembly/x86-64/support.lisp @@ -14,23 +14,23 @@ (:raw (values `((inst lea r13-tn - (make-ea :qword :disp (make-fixup ',name :assembly-routine))) - (inst call r13-tn)) + (make-ea :qword :disp (make-fixup ',name :assembly-routine))) + (inst call r13-tn)) nil)) (:full-call (values `((note-this-location ,vop :call-site) - (inst lea r13-tn - (make-ea :qword :disp (make-fixup ',name :assembly-routine))) - (inst call r13-tn) - (note-this-location ,vop :single-value-return) - (move rsp-tn rbx-tn)) + (inst lea r13-tn + (make-ea :qword :disp (make-fixup ',name :assembly-routine))) + (inst call r13-tn) + (note-this-location ,vop :single-value-return) + (move rsp-tn rbx-tn)) '((:save-p :compute-only)))) (:none (values `((inst lea r13-tn - (make-ea :qword :disp (make-fixup ',name :assembly-routine))) - (inst jmp r13-tn)) + (make-ea :qword :disp (make-fixup ',name :assembly-routine))) + (inst jmp r13-tn)) nil)))) (!def-vm-support-routine generate-return-sequence (style) diff --git a/src/assembly/x86/arith.lisp b/src/assembly/x86/arith.lisp index dbc752c..1365fba 100644 --- a/src/assembly/x86/arith.lisp +++ b/src/assembly/x86/arith.lisp @@ -14,54 +14,54 @@ ;;;; addition, subtraction, and multiplication (macrolet ((define-generic-arith-routine ((fun cost) &body body) - `(define-assembly-routine (,(symbolicate "GENERIC-" fun) - (:cost ,cost) - (:return-style :full-call) - (:translate ,fun) - (:policy :safe) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) edx-offset) - (:arg y (descriptor-reg any-reg) - ;; this seems wrong esi-offset -- FIXME: What's it mean? - edi-offset) - - (:res res (descriptor-reg any-reg) edx-offset) - - (:temp eax unsigned-reg eax-offset) - (:temp ebx unsigned-reg ebx-offset) - (:temp ecx unsigned-reg ecx-offset)) - - (declare (ignorable ebx)) - - (inst test x 3) ; fixnum? - (inst jmp :nz DO-STATIC-FUN) ; no - do generic - (inst test y 3) ; fixnum? - (inst jmp :z DO-BODY) ; yes - doit here - - DO-STATIC-FUN - (inst pop eax) - (inst push ebp-tn) - (inst lea - ebp-tn - (make-ea :dword :base esp-tn :disp n-word-bytes)) - (inst sub esp-tn (fixnumize 2)) - (inst push eax) ; callers return addr - (inst mov ecx (fixnumize 2)) ; arg count - (inst jmp - (make-ea :dword - :disp (+ nil-value - (static-fun-offset - ',(symbolicate "TWO-ARG-" fun))))) - - DO-BODY - ,@body))) + `(define-assembly-routine (,(symbolicate "GENERIC-" fun) + (:cost ,cost) + (:return-style :full-call) + (:translate ,fun) + (:policy :safe) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:arg y (descriptor-reg any-reg) + ;; this seems wrong esi-offset -- FIXME: What's it mean? + edi-offset) + + (:res res (descriptor-reg any-reg) edx-offset) + + (:temp eax unsigned-reg eax-offset) + (:temp ebx unsigned-reg ebx-offset) + (:temp ecx unsigned-reg ecx-offset)) + + (declare (ignorable ebx)) + + (inst test x 3) ; fixnum? + (inst jmp :nz DO-STATIC-FUN) ; no - do generic + (inst test y 3) ; fixnum? + (inst jmp :z DO-BODY) ; yes - doit here + + DO-STATIC-FUN + (inst pop eax) + (inst push ebp-tn) + (inst lea + ebp-tn + (make-ea :dword :base esp-tn :disp n-word-bytes)) + (inst sub esp-tn (fixnumize 2)) + (inst push eax) ; callers return addr + (inst mov ecx (fixnumize 2)) ; arg count + (inst jmp + (make-ea :dword + :disp (+ nil-value + (static-fun-offset + ',(symbolicate "TWO-ARG-" fun))))) + + DO-BODY + ,@body))) (define-generic-arith-routine (+ 10) (move res x) (inst add res y) (inst jmp :no OKAY) - (inst rcr res 1) ; carry has correct sign - (inst sar res 1) ; remove type bits + (inst rcr res 1) ; carry has correct sign + (inst sar res 1) ; remove type bits (move ecx res) @@ -76,7 +76,7 @@ (inst jmp :no OKAY) (inst cmc) ; carry has correct sign now (inst rcr res 1) - (inst sar res 1) ; remove type bits + (inst sar res 1) ; remove type bits (move ecx res) @@ -85,19 +85,19 @@ OKAY) (define-generic-arith-routine (* 30) - (move eax x) ; must use eax for 64-bit result - (inst sar eax 2) ; remove *4 fixnum bias - (inst imul y) ; result in edx:eax - (inst jmp :no okay) ; still fixnum + (move eax x) ; must use eax for 64-bit result + (inst sar eax 2) ; remove *4 fixnum bias + (inst imul y) ; result in edx:eax + (inst jmp :no okay) ; still fixnum ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above ;; pfw says that loses big -- edx is target for arg x and result res ;; note that 'edx' is not defined -- using x - (inst shrd eax x 2) ; high bits from edx - (inst sar x 2) ; now shift edx too + (inst shrd eax x 2) ; high bits from edx + (inst sar x 2) ; now shift edx too - (move ecx x) ; save high bits from cdq - (inst cdq) ; edx:eax <- sign-extend of eax + (move ecx x) ; save high bits from cdq + (inst cdq) ; edx:eax <- sign-extend of eax (inst cmp x ecx) (inst jmp :e SINGLE-WORD-BIGNUM) @@ -119,16 +119,16 @@ ;;;; negation (define-assembly-routine (generic-negate - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate %negate) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) edx-offset) - (:res res (descriptor-reg any-reg) edx-offset) - - (:temp eax unsigned-reg eax-offset) - (:temp ecx unsigned-reg ecx-offset)) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate %negate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:res res (descriptor-reg any-reg) edx-offset) + + (:temp eax unsigned-reg eax-offset) + (:temp ecx unsigned-reg ecx-offset)) (inst test x 3) (inst jmp :z FIXNUM) @@ -137,15 +137,15 @@ (inst lea ebp-tn (make-ea :dword :base esp-tn :disp n-word-bytes)) (inst sub esp-tn (fixnumize 2)) (inst push eax) - (inst mov ecx (fixnumize 1)) ; arg count + (inst mov ecx (fixnumize 1)) ; arg count (inst jmp (make-ea :dword - :disp (+ nil-value (static-fun-offset '%negate)))) + :disp (+ nil-value (static-fun-offset '%negate)))) FIXNUM (move res x) - (inst neg res) ; (- most-negative-fixnum) is BIGNUM + (inst neg res) ; (- most-negative-fixnum) is BIGNUM (inst jmp :no OKAY) - (inst shr res 2) ; sign bit is data - remove type bits + (inst shr res 2) ; sign bit is data - remove type bits (move ecx res) (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) @@ -156,78 +156,78 @@ ;;;; comparison (macrolet ((define-cond-assem-rtn (name translate static-fn test) - `(define-assembly-routine (,name - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate ,translate) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) edx-offset) - (:arg y (descriptor-reg any-reg) edi-offset) - - (:res res descriptor-reg edx-offset) - - (:temp eax unsigned-reg eax-offset) - (:temp ecx unsigned-reg ecx-offset)) - - ;; KLUDGE: The "3" here is a mask for the bits which will be - ;; zero in a fixnum. It should have a symbolic name. (Actually, - ;; it might already have a symbolic name which the coder - ;; couldn't be bothered to use..) -- WHN 19990917 - (inst test x 3) - (inst jmp :nz TAIL-CALL-TO-STATIC-FN) - (inst test y 3) - (inst jmp :z INLINE-FIXNUM-COMPARE) - - TAIL-CALL-TO-STATIC-FN - (inst pop eax) - (inst push ebp-tn) - (inst lea ebp-tn (make-ea :dword - :base esp-tn - :disp n-word-bytes)) - (inst sub esp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack, - ; weirdly? - (inst push eax) - (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and - ; SINGLE-FLOAT-BITS are parallel, - ; should be named parallelly. - (inst jmp (make-ea :dword - :disp (+ nil-value - (static-fun-offset ',static-fn)))) - - INLINE-FIXNUM-COMPARE - (inst cmp x y) - (inst jmp ,test RETURN-TRUE) - (inst mov res nil-value) - ;; FIXME: A note explaining this return convention, or a - ;; symbolic name for it, would be nice. (It looks as though we - ;; should be hand-crafting the same return sequence as would be - ;; produced by GENERATE-RETURN-SEQUENCE, but in that case it's - ;; not clear why we don't just jump to the end of this function - ;; to share the return sequence there. - (inst pop eax) - (inst add eax 2) - (inst jmp eax) - - RETURN-TRUE - (load-symbol res t)))) + `(define-assembly-routine (,name + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate ,translate) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:arg y (descriptor-reg any-reg) edi-offset) + + (:res res descriptor-reg edx-offset) + + (:temp eax unsigned-reg eax-offset) + (:temp ecx unsigned-reg ecx-offset)) + + ;; KLUDGE: The "3" here is a mask for the bits which will be + ;; zero in a fixnum. It should have a symbolic name. (Actually, + ;; it might already have a symbolic name which the coder + ;; couldn't be bothered to use..) -- WHN 19990917 + (inst test x 3) + (inst jmp :nz TAIL-CALL-TO-STATIC-FN) + (inst test y 3) + (inst jmp :z INLINE-FIXNUM-COMPARE) + + TAIL-CALL-TO-STATIC-FN + (inst pop eax) + (inst push ebp-tn) + (inst lea ebp-tn (make-ea :dword + :base esp-tn + :disp n-word-bytes)) + (inst sub esp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack, + ; weirdly? + (inst push eax) + (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and + ; SINGLE-FLOAT-BITS are parallel, + ; should be named parallelly. + (inst jmp (make-ea :dword + :disp (+ nil-value + (static-fun-offset ',static-fn)))) + + INLINE-FIXNUM-COMPARE + (inst cmp x y) + (inst jmp ,test RETURN-TRUE) + (inst mov res nil-value) + ;; FIXME: A note explaining this return convention, or a + ;; symbolic name for it, would be nice. (It looks as though we + ;; should be hand-crafting the same return sequence as would be + ;; produced by GENERATE-RETURN-SEQUENCE, but in that case it's + ;; not clear why we don't just jump to the end of this function + ;; to share the return sequence there. + (inst pop eax) + (inst add eax 2) + (inst jmp eax) + + RETURN-TRUE + (load-symbol res t)))) (define-cond-assem-rtn generic-< < two-arg-< :l) (define-cond-assem-rtn generic-> > two-arg-> :g)) (define-assembly-routine (generic-eql - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate eql) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) edx-offset) - (:arg y (descriptor-reg any-reg) edi-offset) - - (:res res descriptor-reg edx-offset) - - (:temp eax unsigned-reg eax-offset) - (:temp ecx unsigned-reg ecx-offset)) + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate eql) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:arg y (descriptor-reg any-reg) edi-offset) + + (:res res descriptor-reg edx-offset) + + (:temp eax unsigned-reg eax-offset) + (:temp ecx unsigned-reg ecx-offset)) (inst cmp x y) (inst jmp :e RETURN-T) (inst test x 3) @@ -249,7 +249,7 @@ (inst push eax) (inst mov ecx (fixnumize 2)) (inst jmp (make-ea :dword - :disp (+ nil-value (static-fun-offset 'eql)))) + :disp (+ nil-value (static-fun-offset 'eql)))) RETURN-T (load-symbol res t) @@ -257,25 +257,25 @@ ) (define-assembly-routine (generic-= - (:cost 10) - (:return-style :full-call) - (:policy :safe) - (:translate =) - (:save-p t)) - ((:arg x (descriptor-reg any-reg) edx-offset) - (:arg y (descriptor-reg any-reg) edi-offset) - - (:res res descriptor-reg edx-offset) - - (:temp eax unsigned-reg eax-offset) - (:temp ecx unsigned-reg ecx-offset) - ) - (inst test x 3) ; descriptor? + (:cost 10) + (:return-style :full-call) + (:policy :safe) + (:translate =) + (:save-p t)) + ((:arg x (descriptor-reg any-reg) edx-offset) + (:arg y (descriptor-reg any-reg) edi-offset) + + (:res res descriptor-reg edx-offset) + + (:temp eax unsigned-reg eax-offset) + (:temp ecx unsigned-reg ecx-offset) + ) + (inst test x 3) ; descriptor? (inst jmp :nz DO-STATIC-FN) ; yes, do it here - (inst test y 3) ; descriptor? + (inst test y 3) ; descriptor? (inst jmp :nz DO-STATIC-FN) (inst cmp x y) - (inst jmp :e RETURN-T) ; ok + (inst jmp :e RETURN-T) ; ok (inst mov res nil-value) (inst pop eax) @@ -290,7 +290,7 @@ (inst push eax) (inst mov ecx (fixnumize 2)) (inst jmp (make-ea :dword - :disp (+ nil-value (static-fun-offset 'two-arg-=)))) + :disp (+ nil-value (static-fun-offset 'two-arg-=)))) RETURN-T (load-symbol res t)) @@ -329,13 +329,13 @@ (inst xor k k) LOOP1 (inst mov y (make-ea :dword :base state :index k :scale 4 - :disp (- (* (+ 3 vector-data-offset) - n-word-bytes) - other-pointer-lowtag))) + :disp (- (* (+ 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) (inst mov tmp (make-ea :dword :base state :index k :scale 4 - :disp (- (* (+ 1 3 vector-data-offset) - n-word-bytes) - other-pointer-lowtag))) + :disp (- (* (+ 1 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) (inst and y #x80000000) (inst and tmp #x7fffffff) (inst or y tmp) @@ -344,26 +344,26 @@ (inst xor y #x9908b0df) SKIP1 (inst xor y (make-ea :dword :base state :index k :scale 4 - :disp (- (* (+ 397 3 vector-data-offset) - n-word-bytes) - other-pointer-lowtag))) + :disp (- (* (+ 397 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) (inst mov (make-ea :dword :base state :index k :scale 4 - :disp (- (* (+ 3 vector-data-offset) - n-word-bytes) - other-pointer-lowtag)) - y) + :disp (- (* (+ 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag)) + y) (inst inc k) (inst cmp k (- 624 397)) (inst jmp :b loop1) LOOP2 (inst mov y (make-ea :dword :base state :index k :scale 4 - :disp (- (* (+ 3 vector-data-offset) - n-word-bytes) - other-pointer-lowtag))) + :disp (- (* (+ 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) (inst mov tmp (make-ea :dword :base state :index k :scale 4 - :disp (- (* (+ 1 3 vector-data-offset) - n-word-bytes) - other-pointer-lowtag))) + :disp (- (* (+ 1 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) (inst and y #x80000000) (inst and tmp #x7fffffff) (inst or y tmp) @@ -372,26 +372,26 @@ (inst xor y #x9908b0df) SKIP2 (inst xor y (make-ea :dword :base state :index k :scale 4 - :disp (- (* (+ (- 397 624) 3 vector-data-offset) - n-word-bytes) - other-pointer-lowtag))) + :disp (- (* (+ (- 397 624) 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) (inst mov (make-ea :dword :base state :index k :scale 4 - :disp (- (* (+ 3 vector-data-offset) - n-word-bytes) - other-pointer-lowtag)) - y) + :disp (- (* (+ 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag)) + y) (inst inc k) (inst cmp k (- 624 1)) (inst jmp :b loop2) (inst mov y (make-ea :dword :base state - :disp (- (* (+ (- 624 1) 3 vector-data-offset) - n-word-bytes) - other-pointer-lowtag))) + :disp (- (* (+ (- 624 1) 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) (inst mov tmp (make-ea :dword :base state - :disp (- (* (+ 0 3 vector-data-offset) - n-word-bytes) - other-pointer-lowtag))) + :disp (- (* (+ 0 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) (inst and y #x80000000) (inst and tmp #x7fffffff) (inst or y tmp) @@ -400,14 +400,14 @@ (inst xor y #x9908b0df) SKIP3 (inst xor y (make-ea :dword :base state - :disp (- (* (+ (- 397 1) 3 vector-data-offset) - n-word-bytes) - other-pointer-lowtag))) + :disp (- (* (+ (- 397 1) 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag))) (inst mov (make-ea :dword :base state - :disp (- (* (+ (- 624 1) 3 vector-data-offset) - n-word-bytes) - other-pointer-lowtag)) - y) + :disp (- (* (+ (- 624 1) 3 vector-data-offset) + n-word-bytes) + other-pointer-lowtag)) + y) ;; Restore the temporary registers and return. (inst pop tmp) diff --git a/src/assembly/x86/assem-rtns.lisp b/src/assembly/x86/assem-rtns.lisp index 3596ae7..ef71ad2 100644 --- a/src/assembly/x86/assem-rtns.lisp +++ b/src/assembly/x86/assem-rtns.lisp @@ -48,9 +48,9 @@ ;; address. Therefore, we need to iterate from larger addresses to ;; smaller addresses. pfw-this says copy ecx words from esi to edi ;; counting down. - (inst shr ecx 2) ; fixnum to raw word count - (inst std) ; count down - (inst sub esi 4) ; ? + (inst shr ecx 2) ; fixnum to raw word count + (inst std) ; count down + (inst sub esi 4) ; ? (inst lea edi (make-ea :dword :base ebx :disp (- n-word-bytes))) (inst rep) (inst movs :dword) @@ -78,7 +78,7 @@ (inst jmp eax) ONE-VALUE ; Note: we can get this, because the return-multiple vop - ; doesn't check for this case when size > speed. + ; doesn't check for this case when size > speed. (loadw edx esi -1) (inst mov esp-tn ebx) (inst add eax 2) @@ -140,8 +140,8 @@ ;; Do the blit. Because we are coping from smaller addresses to ;; larger addresses, we have to start at the largest pair and work ;; our way down. - (inst shr ecx 2) ; fixnum to raw words - (inst std) ; count down + (inst shr ecx 2) ; fixnum to raw words + (inst std) ; count down (inst lea edi (make-ea :dword :base ebp-tn :disp (- n-word-bytes))) (inst sub esi (fixnumize 1)) (inst rep) @@ -152,7 +152,7 @@ ;; Restore OLD-FP and ECX. (inst pop ecx) - (popw ebp-tn -1) ; overwrites a0 + (popw ebp-tn -1) ; overwrites a0 ;; Blow off the stack above the arguments. (inst lea esp-tn (make-ea :dword :base edi :disp n-word-bytes)) @@ -166,9 +166,9 @@ ;; And jump into the function. (inst jmp - (make-ea :byte :base eax - :disp (- (* closure-fun-slot n-word-bytes) - fun-pointer-lowtag))) + (make-ea :byte :base eax + :disp (- (* closure-fun-slot n-word-bytes) + fun-pointer-lowtag))) ;; All the arguments fit in registers, so load them. REGISTER-ARGS @@ -178,22 +178,22 @@ ;; Clear most of the stack. (inst lea esp-tn - (make-ea :dword :base ebp-tn :disp (* -3 n-word-bytes))) + (make-ea :dword :base ebp-tn :disp (* -3 n-word-bytes))) ;; Push the return-pc so it looks like we just called. (pushw ebp-tn -2) ;; And away we go. (inst jmp (make-ea :byte :base eax - :disp (- (* closure-fun-slot n-word-bytes) - fun-pointer-lowtag)))) + :disp (- (* closure-fun-slot n-word-bytes) + fun-pointer-lowtag)))) (define-assembly-routine (throw - (:return-style :none)) - ((:arg target (descriptor-reg any-reg) edx-offset) - (:arg start any-reg ebx-offset) - (:arg count any-reg ecx-offset) - (:temp catch any-reg eax-offset)) + (:return-style :none)) + ((:arg target (descriptor-reg any-reg) edx-offset) + (:arg start any-reg ebx-offset) + (:arg count any-reg ecx-offset) + (:temp catch any-reg eax-offset)) (declare (ignore start count)) @@ -202,7 +202,7 @@ LOOP (let ((error (generate-error-code nil unseen-throw-tag-error target))) - (inst or catch catch) ; check for NULL pointer + (inst or catch catch) ; check for NULL pointer (inst jmp :z error)) (inst cmp target (make-ea-for-object-slot catch catch-block-tag-slot 0)) @@ -219,17 +219,17 @@ ;;;; non-local exit noise (define-assembly-routine (unwind - (:return-style :none) - (:translate %continue-unwind) - (:policy :fast-safe)) - ((:arg block (any-reg descriptor-reg) eax-offset) - (:arg start (any-reg descriptor-reg) ebx-offset) - (:arg count (any-reg descriptor-reg) ecx-offset) - (:temp uwp unsigned-reg esi-offset)) + (:return-style :none) + (:translate %continue-unwind) + (:policy :fast-safe)) + ((:arg block (any-reg descriptor-reg) eax-offset) + (:arg start (any-reg descriptor-reg) ebx-offset) + (:arg count (any-reg descriptor-reg) ecx-offset) + (:temp uwp unsigned-reg esi-offset)) (declare (ignore start count)) (let ((error (generate-error-code nil invalid-unwind-error))) - (inst or block block) ; check for NULL pointer + (inst or block block) ; check for NULL pointer (inst jmp :z error)) (load-tl-symbol-value uwp *current-unwind-protect-block*) @@ -237,7 +237,7 @@ ;; Does *CURRENT-UNWIND-PROTECT-BLOCK* match the value stored in ;; argument's CURRENT-UWP-SLOT? (inst cmp uwp - (make-ea-for-object-slot block unwind-block-current-uwp-slot 0)) + (make-ea-for-object-slot block unwind-block-current-uwp-slot 0)) ;; If a match, return to context in arg block. (inst jmp :e do-exit) @@ -260,4 +260,4 @@ ;; count in ecx-tn. (inst jmp (make-ea :byte :base block - :disp (* unwind-block-entry-pc-slot n-word-bytes)))) + :disp (* unwind-block-entry-pc-slot n-word-bytes)))) diff --git a/src/assembly/x86/support.lisp b/src/assembly/x86/support.lisp index 4bb9167..1e51079 100644 --- a/src/assembly/x86/support.lisp +++ b/src/assembly/x86/support.lisp @@ -18,9 +18,9 @@ (:full-call (values `((note-this-location ,vop :call-site) - (inst call (make-fixup ',name :assembly-routine)) - (note-this-location ,vop :single-value-return) - (move esp-tn ebx-tn)) + (inst call (make-fixup ',name :assembly-routine)) + (note-this-location ,vop :single-value-return) + (move esp-tn ebx-tn)) '((:save-p :compute-only)))))) (!def-vm-support-routine generate-return-sequence (style) diff --git a/src/code/alien-type.lisp b/src/code/alien-type.lisp index 5aed5cd..b0aeb65 100644 --- a/src/code/alien-type.lisp +++ b/src/code/alien-type.lisp @@ -18,10 +18,10 @@ (!begin-collecting-cold-init-forms) (defstruct (alien-type-type - (:include ctype - (class-info (type-class-or-lose 'alien))) - (:constructor %make-alien-type-type (alien-type)) - (:copier nil)) + (:include ctype + (class-info (type-class-or-lose 'alien))) + (:constructor %make-alien-type-type (alien-type)) + (:copier nil)) (alien-type nil :type alien-type)) (!define-type-class alien) @@ -34,8 +34,8 @@ (!define-type-method (alien :simple-subtypep) (type1 type2) (values (alien-subtype-p (alien-type-type-alien-type type1) - (alien-type-type-alien-type type2)) - t)) + (alien-type-type-alien-type type2)) + t)) ;;; KLUDGE: This !DEFINE-SUPERCLASSES gets executed much later than the ;;; others (toplevel form time instead of cold load init time) because @@ -45,10 +45,10 @@ (!define-type-method (alien :simple-=) (type1 type2) (let ((alien-type-1 (alien-type-type-alien-type type1)) - (alien-type-2 (alien-type-type-alien-type type2))) + (alien-type-2 (alien-type-type-alien-type type2))) (values (or (eq alien-type-1 alien-type-2) - (alien-type-= alien-type-1 alien-type-2)) - t))) + (alien-type-= alien-type-1 alien-type-2)) + t))) (!def-type-translator alien (&optional (alien-type nil)) (typecase alien-type @@ -62,9 +62,9 @@ (defun make-alien-type-type (&optional alien-type) (if alien-type (let ((lisp-rep-type (compute-lisp-rep-type alien-type))) - (if lisp-rep-type - (single-value-specifier-type lisp-rep-type) - (%make-alien-type-type alien-type))) + (if lisp-rep-type + (single-value-specifier-type lisp-rep-type) + (%make-alien-type-type alien-type))) *universal-type*)) (!defun-from-collected-cold-init-forms !alien-type-cold-init) diff --git a/src/code/alloc.lisp b/src/code/alloc.lisp index 866a9ee..e325f37 100644 --- a/src/code/alloc.lisp +++ b/src/code/alloc.lisp @@ -15,40 +15,39 @@ #!-sb-fluid (declaim (inline store-word)) (defun store-word (word base &optional (offset 0) (lowtag 0)) (declare (type (unsigned-byte #.sb!vm:n-word-bits) word base offset) - (type (unsigned-byte #.n-lowtag-bits) lowtag)) + (type (unsigned-byte #.n-lowtag-bits) lowtag)) (setf (sap-ref-word (int-sap base) (- (ash offset word-shift) lowtag)) word)) (defun allocate-static-vector (widetag length words) (declare (type (unsigned-byte #.n-widetag-bits) widetag) - (type (unsigned-byte #.n-word-bits) words) - (type index length)) + (type (unsigned-byte #.n-word-bits) words) + (type index length)) (handler-case ;; FIXME: Is WITHOUT-GCING enough to do lisp-side allocation ;; to static space, or should we have WITHOUT-INTERRUPTS here ;; as well? (without-gcing - (let* ((pointer *static-space-free-pointer*) ; in words - (free (* pointer n-word-bytes)) - (vector (logior free other-pointer-lowtag)) ; in bytes, yay - ;; rounded to dual word boundary - (nwords (logandc2 (+ lowtag-mask (+ words vector-data-offset 1)) - lowtag-mask)) - (new-pointer (+ *static-space-free-pointer* nwords)) - (new-free (* new-pointer n-word-bytes))) - (unless (> static-space-end new-free) - (error 'simple-storage-condition - :format-control "Not enough memory left in static space to ~ + (let* ((pointer *static-space-free-pointer*) ; in words + (free (* pointer n-word-bytes)) + (vector (logior free other-pointer-lowtag)) ; in bytes, yay + ;; rounded to dual word boundary + (nwords (logandc2 (+ lowtag-mask (+ words vector-data-offset 1)) + lowtag-mask)) + (new-pointer (+ *static-space-free-pointer* nwords)) + (new-free (* new-pointer n-word-bytes))) + (unless (> static-space-end new-free) + (error 'simple-storage-condition + :format-control "Not enough memory left in static space to ~ allocate vector.")) - (store-word widetag - vector 0 other-pointer-lowtag) - (store-word (ash length word-shift) - vector vector-length-slot other-pointer-lowtag) - (store-word 0 new-free) - (prog1 - (make-lisp-obj vector) - (setf *static-space-free-pointer* new-pointer)))) + (store-word widetag + vector 0 other-pointer-lowtag) + (store-word (ash length word-shift) + vector vector-length-slot other-pointer-lowtag) + (store-word 0 new-free) + (prog1 + (make-lisp-obj vector) + (setf *static-space-free-pointer* new-pointer)))) (serious-condition (c) ;; unwind from WITHOUT-GCING (error c)))) - \ No newline at end of file diff --git a/src/code/alpha-vm.lisp b/src/code/alpha-vm.lisp index b1f55cf..8373714 100644 --- a/src/code/alpha-vm.lisp +++ b/src/code/alpha-vm.lisp @@ -29,32 +29,32 @@ (error "Unaligned instruction? offset=#x~X." offset)) (sb!sys:without-gcing (let ((sap (truly-the system-area-pointer - (%primitive code-instructions code)))) + (%primitive code-instructions code)))) (ecase kind (:jmp-hint - (aver (zerop (ldb (byte 2 0) value))) - #+nil - (setf (sap-ref-16 sap offset) - (logior (sap-ref-16 sap offset) - (ldb (byte 14 0) (ash value -2))))) + (aver (zerop (ldb (byte 2 0) value))) + #+nil + (setf (sap-ref-16 sap offset) + (logior (sap-ref-16 sap offset) + (ldb (byte 14 0) (ash value -2))))) (:bits-63-48 - (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) - (value (if (logbitp 31 value) (+ value (ash 1 32)) value)) - (value (if (logbitp 47 value) (+ value (ash 1 48)) value))) - (setf (sap-ref-8 sap offset) (ldb (byte 8 48) value)) - (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 56) value)))) + (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) + (value (if (logbitp 31 value) (+ value (ash 1 32)) value)) + (value (if (logbitp 47 value) (+ value (ash 1 48)) value))) + (setf (sap-ref-8 sap offset) (ldb (byte 8 48) value)) + (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 56) value)))) (:bits-47-32 - (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) - (value (if (logbitp 31 value) (+ value (ash 1 32)) value))) - (setf (sap-ref-8 sap offset) (ldb (byte 8 32) value)) - (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 40) value)))) + (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) + (value (if (logbitp 31 value) (+ value (ash 1 32)) value))) + (setf (sap-ref-8 sap offset) (ldb (byte 8 32) value)) + (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 40) value)))) (:ldah - (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))) - (setf (sap-ref-8 sap offset) (ldb (byte 8 16) value)) - (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 24) value)))) + (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))) + (setf (sap-ref-8 sap offset) (ldb (byte 8 16) value)) + (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 24) value)))) (:lda - (setf (sap-ref-8 sap offset) (ldb (byte 8 0) value)) - (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value))))))) + (setf (sap-ref-8 sap offset) (ldb (byte 8 0) value)) + (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value))))))) ;;;; "sigcontext" access functions, cut & pasted from x86-vm.lisp then ;;;; hacked for types. @@ -87,13 +87,13 @@ (defun context-register (context index) (declare (type (alien (* os-context-t)) context)) (deref (the (alien (* unsigned-long)) - (context-register-addr context index)))) + (context-register-addr context index)))) (defun %set-context-register (context index new) (declare (type (alien (* os-context-t)) context)) (setf (deref (the (alien (* unsigned-long)) - (context-register-addr context index))) - new)) + (context-register-addr context index))) + new)) ;;; This is like CONTEXT-REGISTER, but returns the value of a float ;;; register. FORMAT is the type of float to return. @@ -101,7 +101,7 @@ ;;; FIXME: Whether COERCE actually knows how to make a float out of a ;;; long is another question. This stuff still needs testing. (define-alien-routine ("os_context_float_register_addr" - context-float-register-addr) + context-float-register-addr) (* long) (context (* os-context-t)) (index int)) @@ -141,7 +141,7 @@ ;;; Given a (POSIX) signal context, extract the internal error ;;; arguments from the instruction stream. This is e.g. -;;; 4 23 254 240 2 0 0 0 +;;; 4 23 254 240 2 0 0 0 ;;; | ~~~~~~~~~~~~~~~~~~~~~~~~~ ;;; length data (everything is an octet) ;;; (pc) diff --git a/src/code/ansi-stream.lisp b/src/code/ansi-stream.lisp index 663869f..7efbbd1 100644 --- a/src/code/ansi-stream.lisp +++ b/src/code/ansi-stream.lisp @@ -20,38 +20,38 @@ ;;; considered closed. The functions in the operation slots take ;;; arguments as follows: ;;; -;;; In: Stream, Eof-Errorp, Eof-Value -;;; Bin: Stream, Eof-Errorp, Eof-Value -;;; N-Bin: Stream, Buffer, Start, Numbytes, Eof-Errorp -;;; Out: Stream, Character -;;; Bout: Stream, Integer -;;; Sout: Stream, String, Start, End -;;; Misc: Stream, Operation, &Optional Arg1, Arg2 +;;; In: Stream, Eof-Errorp, Eof-Value +;;; Bin: Stream, Eof-Errorp, Eof-Value +;;; N-Bin: Stream, Buffer, Start, Numbytes, Eof-Errorp +;;; Out: Stream, Character +;;; Bout: Stream, Integer +;;; Sout: Stream, String, Start, End +;;; Misc: Stream, Operation, &Optional Arg1, Arg2 ;;; ;;; In order to save space, some of the less common stream operations ;;; are handled by just one function, the MISC method. This function ;;; is passed a keyword which indicates the operation to perform. ;;; The following keywords are used: -;;; :listen - Return the following values: -;;; t if any input waiting. -;;; :eof if at eof. -;;; nil if no input is available and not at eof. -;;; :unread - Unread the character Arg. -;;; :close - Do any stream specific stuff to close the stream. -;;; The methods are set to closed-flame by the close -;;; function, so that need not be done by this -;;; function. -;;; :clear-input - Clear any unread input +;;; :listen - Return the following values: +;;; t if any input waiting. +;;; :eof if at eof. +;;; nil if no input is available and not at eof. +;;; :unread - Unread the character Arg. +;;; :close - Do any stream specific stuff to close the stream. +;;; The methods are set to closed-flame by the close +;;; function, so that need not be done by this +;;; function. +;;; :clear-input - Clear any unread input ;;; :finish-output, -;;; :force-output - Cause output to happen -;;; :clear-output - Clear any undone output -;;; :element-type - Return the type of element the stream deals with. -;;; :line-length - Return the length of a line of output. -;;; :charpos - Return current output position on the line. -;;; :file-length - Return the file length of a file stream. -;;; :file-position - Return or change the current position of a +;;; :force-output - Cause output to happen +;;; :clear-output - Clear any undone output +;;; :element-type - Return the type of element the stream deals with. +;;; :line-length - Return the length of a line of output. +;;; :charpos - Return current output position on the line. +;;; :file-length - Return the file length of a file stream. +;;; :file-position - Return or change the current position of a ;;; file stream. -;;; :file-name - Return the name of an associated file. +;;; :file-name - Return the name of an associated file. ;;; :interactive-p - Is this an interactive device? ;;; ;;; In order to do almost anything useful, it is necessary to @@ -95,7 +95,7 @@ ;;; base class for ANSI standard streams (as opposed to the Gray ;;; streams extension) (defstruct (ansi-stream (:constructor nil) - (:copier nil)) + (:copier nil)) ;; input buffer ;; @@ -107,14 +107,14 @@ (in-index +ansi-stream-in-buffer-length+ :type index) ;; buffered input functions - (in #'ill-in :type function) ; READ-CHAR function - (bin #'ill-bin :type function) ; byte input function - (n-bin #'ill-bin :type function) ; n-byte input function + (in #'ill-in :type function) ; READ-CHAR function + (bin #'ill-bin :type function) ; byte input function + (n-bin #'ill-bin :type function) ; n-byte input function ;; output functions - (out #'ill-out :type function) ; WRITE-CHAR function - (bout #'ill-bout :type function) ; byte output function - (sout #'ill-out :type function) ; string output function + (out #'ill-out :type function) ; WRITE-CHAR function + (bout #'ill-bout :type function) ; byte output function + (sout #'ill-out :type function) ; string output function ;; other, less-used methods (misc #'no-op-placeholder :type function)) diff --git a/src/code/array.lisp b/src/code/array.lisp index 9f1eb0f..9b8088a 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -13,18 +13,18 @@ #!-sb-fluid (declaim (inline fill-pointer array-has-fill-pointer-p adjustable-array-p - array-displacement)) + array-displacement)) ;;;; miscellaneous accessor functions ;;; These functions are only needed by the interpreter, 'cause the ;;; compiler inlines them. (macrolet ((def (name) - `(progn - (defun ,name (array) - (,name array)) - (defun (setf ,name) (value array) - (setf (,name array) value))))) + `(progn + (defun ,name (array) + (,name array)) + (defun (setf ,name) (value array) + (setf (,name array) value))))) (def %array-fill-pointer) (def %array-fill-pointer-p) (def %array-available-elements) @@ -43,7 +43,7 @@ (defun %check-bound (array bound index) (declare (type index bound) - (fixnum index)) + (fixnum index)) (%check-bound array bound index)) (defun %with-array-data (array start end) @@ -68,11 +68,11 @@ (eval-when (:compile-toplevel :execute) (sb!xc:defmacro pick-vector-type (type &rest specs) `(cond ,@(mapcar (lambda (spec) - `(,(if (eq (car spec) t) - t - `(subtypep ,type ',(car spec))) - ,@(cdr spec))) - specs)))) + `(,(if (eq (car spec) t) + t + `(subtypep ,type ',(car spec))) + ,@(cdr spec))) + specs)))) ;;; These functions are used in the implementation of MAKE-ARRAY for ;;; complex arrays. There are lots of transforms to simplify @@ -101,12 +101,12 @@ ;; OK, we have to wade into SUBTYPEPing after all. (t #.`(pick-vector-type type - ,@(map 'list - (lambda (saetp) - `(,(sb!vm:saetp-specifier saetp) - (values ,(sb!vm:saetp-typecode saetp) - ,(sb!vm:saetp-n-bits saetp)))) - sb!vm:*specialized-array-element-type-properties*))))) + ,@(map 'list + (lambda (saetp) + `(,(sb!vm:saetp-specifier saetp) + (values ,(sb!vm:saetp-typecode saetp) + ,(sb!vm:saetp-n-bits saetp)))) + sb!vm:*specialized-array-element-type-properties*))))) (defun %complex-vector-widetag (type) (case type @@ -136,31 +136,31 @@ (t #.sb!vm:complex-vector-widetag))))) (defun make-array (dimensions &key - (element-type t) - (initial-element nil initial-element-p) - (initial-contents nil initial-contents-p) + (element-type t) + (initial-element nil initial-element-p) + (initial-contents nil initial-contents-p) adjustable fill-pointer - displaced-to displaced-index-offset) + displaced-to displaced-index-offset) (let* ((dimensions (if (listp dimensions) dimensions (list dimensions))) - (array-rank (length (the list dimensions))) - (simple (and (null fill-pointer) - (not adjustable) - (null displaced-to)))) + (array-rank (length (the list dimensions))) + (simple (and (null fill-pointer) + (not adjustable) + (null displaced-to)))) (declare (fixnum array-rank)) (when (and displaced-index-offset (null displaced-to)) (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO")) (if (and simple (= array-rank 1)) - ;; it's a (SIMPLE-ARRAY * (*)) - (multiple-value-bind (type n-bits) - (%vector-widetag-and-n-bits element-type) - (declare (type (unsigned-byte 8) type) - (type (integer 0 256) n-bits)) - (let* ((length (car dimensions)) - (array (allocate-vector - type - length - (ceiling - (* (if (or (= type sb!vm:simple-base-string-widetag) + ;; it's a (SIMPLE-ARRAY * (*)) + (multiple-value-bind (type n-bits) + (%vector-widetag-and-n-bits element-type) + (declare (type (unsigned-byte 8) type) + (type (integer 0 256) n-bits)) + (let* ((length (car dimensions)) + (array (allocate-vector + type + length + (ceiling + (* (if (or (= type sb!vm:simple-base-string-widetag) #!+sb-unicode (= type sb!vm:simple-character-string-widetag)) @@ -168,11 +168,11 @@ length) n-bits) sb!vm:n-word-bits)))) - (declare (type index length)) - (when initial-element-p - (fill array initial-element)) - (when initial-contents-p - (when initial-element-p + (declare (type index length)) + (when initial-element-p + (fill array initial-element)) + (when initial-contents-p + (when initial-element-p (error "can't specify both :INITIAL-ELEMENT and ~ :INITIAL-CONTENTS")) (unless (= length (length initial-contents)) @@ -180,153 +180,153 @@ the vector length is ~W." (length initial-contents) length)) - (replace array initial-contents)) - array)) - ;; it's either a complex array or a multidimensional array. - (let* ((total-size (reduce #'* dimensions)) - (data (or displaced-to - (data-vector-from-inits - dimensions total-size element-type - initial-contents initial-contents-p + (replace array initial-contents)) + array)) + ;; it's either a complex array or a multidimensional array. + (let* ((total-size (reduce #'* dimensions)) + (data (or displaced-to + (data-vector-from-inits + dimensions total-size element-type + initial-contents initial-contents-p initial-element initial-element-p))) - (array (make-array-header - (cond ((= array-rank 1) - (%complex-vector-widetag element-type)) - (simple sb!vm:simple-array-widetag) - (t sb!vm:complex-array-widetag)) - array-rank))) - (cond (fill-pointer - (unless (= array-rank 1) - (error "Only vectors can have fill pointers.")) - (let ((length (car dimensions))) - (declare (fixnum length)) - (setf (%array-fill-pointer array) - (cond ((eq fill-pointer t) - length) - (t - (unless (and (fixnump fill-pointer) - (>= fill-pointer 0) - (<= fill-pointer length)) - ;; FIXME: should be TYPE-ERROR? - (error "invalid fill-pointer ~W" - fill-pointer)) - fill-pointer)))) - (setf (%array-fill-pointer-p array) t)) - (t - (setf (%array-fill-pointer array) total-size) - (setf (%array-fill-pointer-p array) nil))) - (setf (%array-available-elements array) total-size) - (setf (%array-data-vector array) data) - (cond (displaced-to - (when (or initial-element-p initial-contents-p) - (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~ + (array (make-array-header + (cond ((= array-rank 1) + (%complex-vector-widetag element-type)) + (simple sb!vm:simple-array-widetag) + (t sb!vm:complex-array-widetag)) + array-rank))) + (cond (fill-pointer + (unless (= array-rank 1) + (error "Only vectors can have fill pointers.")) + (let ((length (car dimensions))) + (declare (fixnum length)) + (setf (%array-fill-pointer array) + (cond ((eq fill-pointer t) + length) + (t + (unless (and (fixnump fill-pointer) + (>= fill-pointer 0) + (<= fill-pointer length)) + ;; FIXME: should be TYPE-ERROR? + (error "invalid fill-pointer ~W" + fill-pointer)) + fill-pointer)))) + (setf (%array-fill-pointer-p array) t)) + (t + (setf (%array-fill-pointer array) total-size) + (setf (%array-fill-pointer-p array) nil))) + (setf (%array-available-elements array) total-size) + (setf (%array-data-vector array) data) + (cond (displaced-to + (when (or initial-element-p initial-contents-p) + (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~ can be specified along with :DISPLACED-TO")) - (let ((offset (or displaced-index-offset 0))) - (when (> (+ offset total-size) - (array-total-size displaced-to)) - (error "~S doesn't have enough elements." displaced-to)) - (setf (%array-displacement array) offset) - (setf (%array-displaced-p array) t))) - (t - (setf (%array-displaced-p array) nil))) - (let ((axis 0)) - (dolist (dim dimensions) - (setf (%array-dimension array axis) dim) - (incf axis))) - array)))) - -(defun make-static-vector (length &key - (element-type '(unsigned-byte 8)) - (initial-contents nil initial-contents-p) - (initial-element nil initial-element-p)) + (let ((offset (or displaced-index-offset 0))) + (when (> (+ offset total-size) + (array-total-size displaced-to)) + (error "~S doesn't have enough elements." displaced-to)) + (setf (%array-displacement array) offset) + (setf (%array-displaced-p array) t))) + (t + (setf (%array-displaced-p array) nil))) + (let ((axis 0)) + (dolist (dim dimensions) + (setf (%array-dimension array axis) dim) + (incf axis))) + array)))) + +(defun make-static-vector (length &key + (element-type '(unsigned-byte 8)) + (initial-contents nil initial-contents-p) + (initial-element nil initial-element-p)) "Allocate vector of LENGTH elements in static space. Only allocation of specialized arrays is supported." ;; STEP 1: check inputs fully ;; ;; This way of doing explicit checks before the vector is allocated ;; is expensive, but probably worth the trouble as once we've allocated - ;; the vector we have no way to get rid of it anymore... + ;; the vector we have no way to get rid of it anymore... (when (eq t (upgraded-array-element-type element-type)) - (error "Static arrays of type ~S not supported." - element-type)) + (error "Static arrays of type ~S not supported." + element-type)) (when initial-contents-p (when initial-element-p (error "can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS")) (unless (= length (length initial-contents)) (error "There are ~W elements in the :INITIAL-CONTENTS, but the ~ vector length is ~W." - (length initial-contents) - length)) + (length initial-contents) + length)) (unless (every (lambda (x) (typep x element-type)) initial-contents) (error ":INITIAL-CONTENTS contains elements not of type ~S." - element-type))) + element-type))) (when initial-element-p (unless (typep initial-element element-type) - (error ":INITIAL-ELEMENT ~S is not of type ~S." - initial-element element-type))) + (error ":INITIAL-ELEMENT ~S is not of type ~S." + initial-element element-type))) ;; STEP 2 ;; ;; Allocate and possibly initialize the vector. (multiple-value-bind (type n-bits) (sb!impl::%vector-widetag-and-n-bits element-type) - (let ((vector - (allocate-static-vector type length - (ceiling (* length n-bits) - sb!vm:n-word-bits)))) + (let ((vector + (allocate-static-vector type length + (ceiling (* length n-bits) + sb!vm:n-word-bits)))) (cond (initial-element-p - (fill vector initial-element)) - (initial-contents-p - (replace vector initial-contents)) - (t - vector))))) + (fill vector initial-element)) + (initial-contents-p + (replace vector initial-contents)) + (t + vector))))) ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the ;;; specified array characteristics. Dimensions is only used to pass ;;; to FILL-DATA-VECTOR for error checking on the structure of ;;; initial-contents. (defun data-vector-from-inits (dimensions total-size element-type - initial-contents initial-contents-p + initial-contents initial-contents-p initial-element initial-element-p) (when (and initial-contents-p initial-element-p) (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to either MAKE-ARRAY or ADJUST-ARRAY.")) (let ((data (if initial-element-p - (make-array total-size - :element-type element-type - :initial-element initial-element) - (make-array total-size - :element-type element-type)))) + (make-array total-size + :element-type element-type + :initial-element initial-element) + (make-array total-size + :element-type element-type)))) (cond (initial-element-p - (unless (simple-vector-p data) - (unless (typep initial-element element-type) - (error "~S cannot be used to initialize an array of type ~S." - initial-element element-type)) - (fill (the vector data) initial-element))) - (initial-contents-p - (fill-data-vector data dimensions initial-contents))) + (unless (simple-vector-p data) + (unless (typep initial-element element-type) + (error "~S cannot be used to initialize an array of type ~S." + initial-element element-type)) + (fill (the vector data) initial-element))) + (initial-contents-p + (fill-data-vector data dimensions initial-contents))) data)) (defun fill-data-vector (vector dimensions initial-contents) (let ((index 0)) (labels ((frob (axis dims contents) - (cond ((null dims) - (setf (aref vector index) contents) - (incf index)) - (t - (unless (typep contents 'sequence) + (cond ((null dims) + (setf (aref vector index) contents) + (incf index)) + (t + (unless (typep contents 'sequence) (error "malformed :INITIAL-CONTENTS: ~S is not a ~ sequence, but ~W more layer~:P needed." - contents - (- (length dimensions) axis))) - (unless (= (length contents) (car dims)) + contents + (- (length dimensions) axis))) + (unless (= (length contents) (car dims)) (error "malformed :INITIAL-CONTENTS: Dimension of ~ axis ~W is ~W, but ~S is ~W long." - axis (car dims) contents (length contents))) - (if (listp contents) - (dolist (content contents) - (frob (1+ axis) (cdr dims) content)) - (dotimes (i (length contents)) - (frob (1+ axis) (cdr dims) (aref contents i)))))))) + axis (car dims) contents (length contents))) + (if (listp contents) + (dolist (content contents) + (frob (1+ axis) (cdr dims) content)) + (dotimes (i (length contents)) + (frob (1+ axis) (cdr dims) (aref contents i)))))))) (frob 0 dimensions initial-contents)))) (defun vector (&rest objects) @@ -339,16 +339,16 @@ of specialized arrays is supported." (with-array-data ((vector array) (index index) (end)) (declare (ignore end)) (etypecase vector . - #.(map 'list - (lambda (saetp) - (let* ((type (sb!vm:saetp-specifier saetp)) - (atype `(simple-array ,type (*)))) - `(,atype - (data-vector-ref (the ,atype vector) index)))) - (sort - (copy-seq - sb!vm:*specialized-array-element-type-properties*) - #'> :key #'sb!vm:saetp-importance))))) + #.(map 'list + (lambda (saetp) + (let* ((type (sb!vm:saetp-specifier saetp)) + (atype `(simple-array ,type (*)))) + `(,atype + (data-vector-ref (the ,atype vector) index)))) + (sort + (copy-seq + sb!vm:*specialized-array-element-type-properties*) + #'> :key #'sb!vm:saetp-importance))))) ;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but ;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function @@ -360,67 +360,67 @@ of specialized arrays is supported." (with-array-data ((vector array) (index index) (end)) (declare (ignore end)) (etypecase vector . - #.(map 'list - (lambda (saetp) - (let* ((type (sb!vm:saetp-specifier saetp)) - (atype `(simple-array ,type (*)))) - `(,atype - (data-vector-set (the ,atype vector) index - (the ,type new-value)) - ;; For specialized arrays, the return from - ;; data-vector-set would have to be - ;; reboxed to be a (Lisp) return value; - ;; instead, we use the already-boxed value - ;; as the return. - new-value))) - (sort - (copy-seq - sb!vm:*specialized-array-element-type-properties*) - #'> :key #'sb!vm:saetp-importance))))) + #.(map 'list + (lambda (saetp) + (let* ((type (sb!vm:saetp-specifier saetp)) + (atype `(simple-array ,type (*)))) + `(,atype + (data-vector-set (the ,atype vector) index + (the ,type new-value)) + ;; For specialized arrays, the return from + ;; data-vector-set would have to be + ;; reboxed to be a (Lisp) return value; + ;; instead, we use the already-boxed value + ;; as the return. + new-value))) + (sort + (copy-seq + sb!vm:*specialized-array-element-type-properties*) + #'> :key #'sb!vm:saetp-importance))))) ;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed (defun %array-row-major-index (array subscripts - &optional (invalid-index-error-p t)) + &optional (invalid-index-error-p t)) (declare (array array) - (list subscripts)) + (list subscripts)) (let ((rank (array-rank array))) (unless (= rank (length subscripts)) (error "wrong number of subscripts, ~W, for array of rank ~W" - (length subscripts) rank)) + (length subscripts) rank)) (if (array-header-p array) - (do ((subs (nreverse subscripts) (cdr subs)) - (axis (1- (array-rank array)) (1- axis)) - (chunk-size 1) - (result 0)) - ((null subs) result) - (declare (list subs) (fixnum axis chunk-size result)) - (let ((index (car subs)) - (dim (%array-dimension array axis))) - (declare (fixnum dim)) - (unless (and (fixnump index) (< -1 index dim)) - (if invalid-index-error-p - (error 'simple-type-error - :format-control "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S" - :format-arguments (list index axis array) - :datum index - :expected-type `(integer 0 (,dim))) - (return-from %array-row-major-index nil))) - (incf result (* chunk-size (the fixnum index))) - (setf chunk-size (* chunk-size dim)))) - (let ((index (first subscripts)) - (length (length (the (simple-array * (*)) array)))) - (unless (and (fixnump index) (< -1 index length)) - (if invalid-index-error-p - ;; FIXME: perhaps this should share a format-string - ;; with INVALID-ARRAY-INDEX-ERROR or - ;; INDEX-TOO-LARGE-ERROR? - (error 'simple-type-error - :format-control "invalid index ~W in ~S" - :format-arguments (list index array) - :datum index - :expected-type `(integer 0 (,length))) - (return-from %array-row-major-index nil))) - index)))) + (do ((subs (nreverse subscripts) (cdr subs)) + (axis (1- (array-rank array)) (1- axis)) + (chunk-size 1) + (result 0)) + ((null subs) result) + (declare (list subs) (fixnum axis chunk-size result)) + (let ((index (car subs)) + (dim (%array-dimension array axis))) + (declare (fixnum dim)) + (unless (and (fixnump index) (< -1 index dim)) + (if invalid-index-error-p + (error 'simple-type-error + :format-control "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S" + :format-arguments (list index axis array) + :datum index + :expected-type `(integer 0 (,dim))) + (return-from %array-row-major-index nil))) + (incf result (* chunk-size (the fixnum index))) + (setf chunk-size (* chunk-size dim)))) + (let ((index (first subscripts)) + (length (length (the (simple-array * (*)) array)))) + (unless (and (fixnump index) (< -1 index length)) + (if invalid-index-error-p + ;; FIXME: perhaps this should share a format-string + ;; with INVALID-ARRAY-INDEX-ERROR or + ;; INDEX-TOO-LARGE-ERROR? + (error 'simple-type-error + :format-control "invalid index ~W in ~S" + :format-arguments (list index array) + :datum index + :expected-type `(integer 0 (,length))) + (return-from %array-row-major-index nil))) + index)))) (defun array-in-bounds-p (array &rest subscripts) #!+sb-doc @@ -441,9 +441,9 @@ of specialized arrays is supported." (defun %aset (array &rest stuff) (declare (dynamic-extent stuff)) (let ((subscripts (butlast stuff)) - (new-value (car (last stuff)))) + (new-value (car (last stuff)))) (setf (row-major-aref array (%array-row-major-index array subscripts)) - new-value))) + new-value))) ;;; FIXME: What's supposed to happen with functions ;;; like AREF when we (DEFUN (SETF FOO) ..) when @@ -475,7 +475,7 @@ of specialized arrays is supported." (declare (dynamic-extent subscripts)) (declare (type array array)) (setf (row-major-aref array (%array-row-major-index array subscripts)) - new-value)) + new-value)) (defun row-major-aref (array index) #!+sb-doc @@ -507,24 +507,24 @@ of specialized arrays is supported." (defun %bitset (bit-array &rest stuff) (declare (type (array bit) bit-array) (optimize (safety 1))) (let ((subscripts (butlast stuff)) - (new-value (car (last stuff)))) + (new-value (car (last stuff)))) (setf (row-major-aref bit-array - (%array-row-major-index bit-array subscripts)) - new-value))) + (%array-row-major-index bit-array subscripts)) + new-value))) #!-sb-fluid (declaim (inline (setf bit))) (defun (setf bit) (new-value bit-array &rest subscripts) (declare (type (array bit) bit-array) (optimize (safety 1))) (setf (row-major-aref bit-array - (%array-row-major-index bit-array subscripts)) - new-value)) + (%array-row-major-index bit-array subscripts)) + new-value)) (defun sbit (simple-bit-array &rest subscripts) #!+sb-doc "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS." (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1))) (row-major-aref simple-bit-array - (%array-row-major-index simple-bit-array subscripts))) + (%array-row-major-index simple-bit-array subscripts))) ;;; KLUDGE: Not all these things (%SET-ROW-MAJOR-AREF, %SET-FILL-POINTER, ;;; %SET-FDEFINITION, %SCHARSET, %SBITSET..) seem to deserve separate names. @@ -533,17 +533,17 @@ of specialized arrays is supported." (defun %sbitset (simple-bit-array &rest stuff) (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1))) (let ((subscripts (butlast stuff)) - (new-value (car (last stuff)))) + (new-value (car (last stuff)))) (setf (row-major-aref simple-bit-array - (%array-row-major-index simple-bit-array subscripts)) - new-value))) + (%array-row-major-index simple-bit-array subscripts)) + new-value))) #!-sb-fluid (declaim (inline (setf sbit))) (defun (setf sbit) (new-value bit-array &rest subscripts) (declare (type (simple-array bit) bit-array) (optimize (safety 1))) (setf (row-major-aref bit-array - (%array-row-major-index bit-array subscripts)) - new-value)) + (%array-row-major-index bit-array subscripts)) + new-value)) ;;;; miscellaneous array properties @@ -552,37 +552,37 @@ of specialized arrays is supported." "Return the type of the elements of the array" (let ((widetag (widetag-of array))) (macrolet ((pick-element-type (&rest stuff) - `(cond ,@(mapcar (lambda (stuff) - (cons - (let ((item (car stuff))) - (cond ((eq item t) - t) - ((listp item) - (cons 'or - (mapcar (lambda (x) - `(= widetag ,x)) - item))) - (t - `(= widetag ,item)))) - (cdr stuff))) - stuff)))) + `(cond ,@(mapcar (lambda (stuff) + (cons + (let ((item (car stuff))) + (cond ((eq item t) + t) + ((listp item) + (cons 'or + (mapcar (lambda (x) + `(= widetag ,x)) + item))) + (t + `(= widetag ,item)))) + (cdr stuff))) + stuff)))) #.`(pick-element-type - ,@(map 'list - (lambda (saetp) - `(,(if (sb!vm:saetp-complex-typecode saetp) - (list (sb!vm:saetp-typecode saetp) - (sb!vm:saetp-complex-typecode saetp)) - (sb!vm:saetp-typecode saetp)) - ',(sb!vm:saetp-specifier saetp))) - sb!vm:*specialized-array-element-type-properties*) - ((sb!vm:simple-array-widetag - sb!vm:complex-vector-widetag - sb!vm:complex-array-widetag) - (with-array-data ((array array) (start) (end)) - (declare (ignore start end)) - (array-element-type array))) - (t - (error 'type-error :datum array :expected-type 'array)))))) + ,@(map 'list + (lambda (saetp) + `(,(if (sb!vm:saetp-complex-typecode saetp) + (list (sb!vm:saetp-typecode saetp) + (sb!vm:saetp-complex-typecode saetp)) + (sb!vm:saetp-typecode saetp)) + ',(sb!vm:saetp-specifier saetp))) + sb!vm:*specialized-array-element-type-properties*) + ((sb!vm:simple-array-widetag + sb!vm:complex-vector-widetag + sb!vm:complex-array-widetag) + (with-array-data ((array array) (start) (end)) + (declare (ignore start end)) + (array-element-type array))) + (t + (error 'type-error :datum array :expected-type 'array)))))) (defun array-rank (array) #!+sb-doc @@ -596,32 +596,32 @@ of specialized arrays is supported." "Return the length of dimension AXIS-NUMBER of ARRAY." (declare (array array) (type index axis-number)) (cond ((not (array-header-p array)) - (unless (= axis-number 0) - (error "Vector axis is not zero: ~S" axis-number)) - (length (the (simple-array * (*)) array))) - ((>= axis-number (%array-rank array)) - (error "Axis number ~W is too big; ~S only has ~D dimension~:P." - axis-number array (%array-rank array))) - (t - ;; ANSI sayeth (ADJUST-ARRAY dictionary entry): - ;; - ;; "If A is displaced to B, the consequences are - ;; unspecified if B is adjusted in such a way that it no - ;; longer has enough elements to satisfy A. - ;; - ;; In situations where this matters we should be doing a - ;; bounds-check, which in turn uses ARRAY-DIMENSION -- so - ;; this seems like a good place to signal an error. - (multiple-value-bind (target offset) (array-displacement array) - (when (and target - (> (array-total-size array) - (- (array-total-size target) offset))) - (error 'displaced-to-array-too-small-error - :format-control "~@= axis-number (%array-rank array)) + (error "Axis number ~W is too big; ~S only has ~D dimension~:P." + axis-number array (%array-rank array))) + (t + ;; ANSI sayeth (ADJUST-ARRAY dictionary entry): + ;; + ;; "If A is displaced to B, the consequences are + ;; unspecified if B is adjusted in such a way that it no + ;; longer has enough elements to satisfy A. + ;; + ;; In situations where this matters we should be doing a + ;; bounds-check, which in turn uses ARRAY-DIMENSION -- so + ;; this seems like a good place to signal an error. + (multiple-value-bind (target offset) (array-displacement array) + (when (and target + (> (array-total-size array) + (- (array-total-size target) offset))) + (error 'displaced-to-array-too-small-error + :format-control "~@" - :format-arguments (list (array-total-size array) - (- (array-total-size target) offset)))) - (%array-dimension array axis-number))))) + :format-arguments (list (array-total-size array) + (- (array-total-size target) offset)))) + (%array-dimension array axis-number))))) (defun array-dimensions (array) #!+sb-doc @@ -629,8 +629,8 @@ of specialized arrays is supported." (declare (array array)) (if (array-header-p array) (do ((results nil (cons (array-dimension array index) results)) - (index (1- (array-rank array)) (1- index))) - ((minusp index) results)) + (index (1- (array-rank array)) (1- index))) + ((minusp index) results)) (list (array-dimension array 0)))) (defun array-total-size (array) @@ -647,7 +647,7 @@ of specialized arrays is supported." options to MAKE-ARRAY, or NIL and 0 if not a displaced array." (declare (type array array)) (if (and (array-header-p array) ; if unsimple and - (%array-displaced-p array)) ; displaced + (%array-displaced-p array)) ; displaced (values (%array-data-vector array) (%array-displacement array)) (values nil 0))) @@ -677,24 +677,24 @@ of specialized arrays is supported." (if (and (array-header-p vector) (%array-fill-pointer-p vector)) (%array-fill-pointer vector) (error 'simple-type-error - :datum vector - :expected-type '(and vector (satisfies array-has-fill-pointer-p)) - :format-control "~S is not an array with a fill pointer." - :format-arguments (list vector)))) + :datum vector + :expected-type '(and vector (satisfies array-has-fill-pointer-p)) + :format-control "~S is not an array with a fill pointer." + :format-arguments (list vector)))) (defun %set-fill-pointer (vector new) (declare (vector vector) (fixnum new)) (if (and (array-header-p vector) (%array-fill-pointer-p vector)) (if (> new (%array-available-elements vector)) - (error - "The new fill pointer, ~S, is larger than the length of the vector." - new) - (setf (%array-fill-pointer vector) new)) + (error + "The new fill pointer, ~S, is larger than the length of the vector." + new) + (setf (%array-fill-pointer vector) new)) (error 'simple-type-error - :datum vector - :expected-type '(and vector (satisfies array-has-fill-pointer-p)) - :format-control "~S is not an array with a fill pointer." - :format-arguments (list vector)))) + :datum vector + :expected-type '(and vector (satisfies array-has-fill-pointer-p)) + :format-control "~S is not an array with a fill pointer." + :format-arguments (list vector)))) ;;; FIXME: It'd probably make sense to use a MACROLET to share the ;;; guts of VECTOR-PUSH between VECTOR-PUSH-EXTEND. Such a macro @@ -711,16 +711,16 @@ of specialized arrays is supported." (let ((fill-pointer (fill-pointer array))) (declare (fixnum fill-pointer)) (cond ((= fill-pointer (%array-available-elements array)) - nil) - (t - (setf (aref array fill-pointer) new-el) - (setf (%array-fill-pointer array) (1+ fill-pointer)) - fill-pointer)))) + nil) + (t + (setf (aref array fill-pointer) new-el) + (setf (%array-fill-pointer array) (1+ fill-pointer)) + fill-pointer)))) (defun vector-push-extend (new-element - vector - &optional - (extension (1+ (length vector)))) + vector + &optional + (extension (1+ (length vector)))) (declare (vector vector) (fixnum extension)) (let ((fill-pointer (fill-pointer vector))) (declare (fixnum fill-pointer)) @@ -740,164 +740,164 @@ of specialized arrays is supported." (let ((fill-pointer (fill-pointer array))) (declare (fixnum fill-pointer)) (if (zerop fill-pointer) - (error "There is nothing left to pop.") - ;; disable bounds checking (and any fixnum test) - (locally (declare (optimize (safety 0))) - (aref array - (setf (%array-fill-pointer array) - (1- fill-pointer))))))) + (error "There is nothing left to pop.") + ;; disable bounds checking (and any fixnum test) + (locally (declare (optimize (safety 0))) + (aref array + (setf (%array-fill-pointer array) + (1- fill-pointer))))))) ;;;; ADJUST-ARRAY (defun adjust-array (array dimensions &key - (element-type (array-element-type array)) - (initial-element nil initial-element-p) - (initial-contents nil initial-contents-p) + (element-type (array-element-type array)) + (initial-element nil initial-element-p) + (initial-contents nil initial-contents-p) fill-pointer - displaced-to displaced-index-offset) + displaced-to displaced-index-offset) #!+sb-doc "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff." (let ((dimensions (if (listp dimensions) dimensions (list dimensions)))) (cond ((/= (the fixnum (length (the list dimensions))) - (the fixnum (array-rank array))) - (error "The number of dimensions not equal to rank of array.")) - ((not (subtypep element-type (array-element-type array))) - (error "The new element type, ~S, is incompatible with old type." - element-type))) + (the fixnum (array-rank array))) + (error "The number of dimensions not equal to rank of array.")) + ((not (subtypep element-type (array-element-type array))) + (error "The new element type, ~S, is incompatible with old type." + element-type))) (let ((array-rank (length (the list dimensions)))) (declare (fixnum array-rank)) (unless (= array-rank 1) - (when fill-pointer - (error "Only vectors can have fill pointers."))) + (when fill-pointer + (error "Only vectors can have fill pointers."))) (cond (initial-contents-p - ;; array former contents replaced by INITIAL-CONTENTS - (if (or initial-element-p displaced-to) + ;; array former contents replaced by INITIAL-CONTENTS + (if (or initial-element-p displaced-to) (error "INITIAL-CONTENTS may not be specified with ~ the :INITIAL-ELEMENT or :DISPLACED-TO option.")) - (let* ((array-size (apply #'* dimensions)) - (array-data (data-vector-from-inits - dimensions array-size element-type - initial-contents initial-contents-p + (let* ((array-size (apply #'* dimensions)) + (array-data (data-vector-from-inits + dimensions array-size element-type + initial-contents initial-contents-p initial-element initial-element-p))) - (if (adjustable-array-p array) - (set-array-header array array-data array-size - (get-new-fill-pointer array array-size - fill-pointer) - 0 dimensions nil) - (if (array-header-p array) - ;; simple multidimensional or single dimensional array - (make-array dimensions - :element-type element-type - :initial-contents initial-contents) - array-data)))) - (displaced-to - ;; We already established that no INITIAL-CONTENTS was supplied. - (when initial-element + (if (adjustable-array-p array) + (set-array-header array array-data array-size + (get-new-fill-pointer array array-size + fill-pointer) + 0 dimensions nil) + (if (array-header-p array) + ;; simple multidimensional or single dimensional array + (make-array dimensions + :element-type element-type + :initial-contents initial-contents) + array-data)))) + (displaced-to + ;; We already established that no INITIAL-CONTENTS was supplied. + (when initial-element (error "The :INITIAL-ELEMENT option may not be specified ~ with :DISPLACED-TO.")) (unless (subtypep element-type (array-element-type displaced-to)) (error "can't displace an array of type ~S into another of ~ type ~S" - element-type (array-element-type displaced-to))) - (let ((displacement (or displaced-index-offset 0)) - (array-size (apply #'* dimensions))) - (declare (fixnum displacement array-size)) - (if (< (the fixnum (array-total-size displaced-to)) - (the fixnum (+ displacement array-size))) - (error "The :DISPLACED-TO array is too small.")) - (if (adjustable-array-p array) - ;; None of the original contents appear in adjusted array. - (set-array-header array displaced-to array-size - (get-new-fill-pointer array array-size - fill-pointer) - displacement dimensions t) - ;; simple multidimensional or single dimensional array - (make-array dimensions - :element-type element-type - :displaced-to displaced-to - :displaced-index-offset - displaced-index-offset)))) - ((= array-rank 1) - (let ((old-length (array-total-size array)) - (new-length (car dimensions)) - new-data) - (declare (fixnum old-length new-length)) - (with-array-data ((old-data array) (old-start) - (old-end old-length)) - (cond ((or (%array-displaced-p array) - (< old-length new-length)) - (setf new-data - (data-vector-from-inits - dimensions new-length element-type - initial-contents initial-contents-p + element-type (array-element-type displaced-to))) + (let ((displacement (or displaced-index-offset 0)) + (array-size (apply #'* dimensions))) + (declare (fixnum displacement array-size)) + (if (< (the fixnum (array-total-size displaced-to)) + (the fixnum (+ displacement array-size))) + (error "The :DISPLACED-TO array is too small.")) + (if (adjustable-array-p array) + ;; None of the original contents appear in adjusted array. + (set-array-header array displaced-to array-size + (get-new-fill-pointer array array-size + fill-pointer) + displacement dimensions t) + ;; simple multidimensional or single dimensional array + (make-array dimensions + :element-type element-type + :displaced-to displaced-to + :displaced-index-offset + displaced-index-offset)))) + ((= array-rank 1) + (let ((old-length (array-total-size array)) + (new-length (car dimensions)) + new-data) + (declare (fixnum old-length new-length)) + (with-array-data ((old-data array) (old-start) + (old-end old-length)) + (cond ((or (%array-displaced-p array) + (< old-length new-length)) + (setf new-data + (data-vector-from-inits + dimensions new-length element-type + initial-contents initial-contents-p initial-element initial-element-p)) - (replace new-data old-data - :start2 old-start :end2 old-end)) - (t (setf new-data - (shrink-vector old-data new-length)))) - (if (adjustable-array-p array) - (set-array-header array new-data new-length - (get-new-fill-pointer array new-length - fill-pointer) - 0 dimensions nil) - new-data)))) - (t - (let ((old-length (%array-available-elements array)) - (new-length (apply #'* dimensions))) - (declare (fixnum old-length new-length)) - (with-array-data ((old-data array) (old-start) - (old-end old-length)) - (declare (ignore old-end)) - (let ((new-data (if (or (%array-displaced-p array) - (> new-length old-length)) - (data-vector-from-inits - dimensions new-length - element-type () nil + (replace new-data old-data + :start2 old-start :end2 old-end)) + (t (setf new-data + (shrink-vector old-data new-length)))) + (if (adjustable-array-p array) + (set-array-header array new-data new-length + (get-new-fill-pointer array new-length + fill-pointer) + 0 dimensions nil) + new-data)))) + (t + (let ((old-length (%array-available-elements array)) + (new-length (apply #'* dimensions))) + (declare (fixnum old-length new-length)) + (with-array-data ((old-data array) (old-start) + (old-end old-length)) + (declare (ignore old-end)) + (let ((new-data (if (or (%array-displaced-p array) + (> new-length old-length)) + (data-vector-from-inits + dimensions new-length + element-type () nil initial-element initial-element-p) - old-data))) - (if (or (zerop old-length) (zerop new-length)) - (when initial-element-p (fill new-data initial-element)) - (zap-array-data old-data (array-dimensions array) - old-start - new-data dimensions new-length - element-type initial-element - initial-element-p)) - (if (adjustable-array-p array) - (set-array-header array new-data new-length - new-length 0 dimensions nil) - (let ((new-array - (make-array-header - sb!vm:simple-array-widetag array-rank))) - (set-array-header new-array new-data new-length - new-length 0 dimensions nil))))))))))) - + old-data))) + (if (or (zerop old-length) (zerop new-length)) + (when initial-element-p (fill new-data initial-element)) + (zap-array-data old-data (array-dimensions array) + old-start + new-data dimensions new-length + element-type initial-element + initial-element-p)) + (if (adjustable-array-p array) + (set-array-header array new-data new-length + new-length 0 dimensions nil) + (let ((new-array + (make-array-header + sb!vm:simple-array-widetag array-rank))) + (set-array-header new-array new-data new-length + new-length 0 dimensions nil))))))))))) + (defun get-new-fill-pointer (old-array new-array-size fill-pointer) (cond ((not fill-pointer) - (when (array-has-fill-pointer-p old-array) - (when (> (%array-fill-pointer old-array) new-array-size) - (error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~ + (when (array-has-fill-pointer-p old-array) + (when (> (%array-fill-pointer old-array) new-array-size) + (error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~ smaller than its fill pointer (~S)" - old-array new-array-size (fill-pointer old-array))) - (%array-fill-pointer old-array))) - ((not (array-has-fill-pointer-p old-array)) - (error "cannot supply a non-NIL value (~S) for :FILL-POINTER ~ + old-array new-array-size (fill-pointer old-array))) + (%array-fill-pointer old-array))) + ((not (array-has-fill-pointer-p old-array)) + (error "cannot supply a non-NIL value (~S) for :FILL-POINTER ~ in ADJUST-ARRAY unless the array (~S) was originally ~ created with a fill pointer" - fill-pointer - old-array)) - ((numberp fill-pointer) - (when (> fill-pointer new-array-size) - (error "can't supply a value for :FILL-POINTER (~S) that is larger ~ + fill-pointer + old-array)) + ((numberp fill-pointer) + (when (> fill-pointer new-array-size) + (error "can't supply a value for :FILL-POINTER (~S) that is larger ~ than the new length of the vector (~S)" - fill-pointer new-array-size)) - fill-pointer) - ((eq fill-pointer t) - new-array-size) - (t - (error "bogus value for :FILL-POINTER in ADJUST-ARRAY: ~S" - fill-pointer)))) + fill-pointer new-array-size)) + fill-pointer) + ((eq fill-pointer t) + new-array-size) + (t + (error "bogus value for :FILL-POINTER in ADJUST-ARRAY: ~S" + fill-pointer)))) ;;; Destructively alter VECTOR, changing its length to NEW-LENGTH, ;;; which must be less than or equal to its current length. @@ -905,28 +905,28 @@ of specialized arrays is supported." (declare (vector vector)) (unless (array-header-p vector) (macrolet ((frob (name &rest things) - `(etypecase ,name - ((simple-array nil (*)) (error 'nil-array-accessed-error)) - ,@(mapcar (lambda (thing) - (destructuring-bind (type-spec fill-value) - thing - `(,type-spec - (fill (truly-the ,type-spec ,name) - ,fill-value - :start new-length)))) - things)))) + `(etypecase ,name + ((simple-array nil (*)) (error 'nil-array-accessed-error)) + ,@(mapcar (lambda (thing) + (destructuring-bind (type-spec fill-value) + thing + `(,type-spec + (fill (truly-the ,type-spec ,name) + ,fill-value + :start new-length)))) + things)))) #.`(frob vector - ,@(map 'list - (lambda (saetp) - `((simple-array ,(sb!vm:saetp-specifier saetp) (*)) - ,(if (or (eq (sb!vm:saetp-specifier saetp) 'character) + ,@(map 'list + (lambda (saetp) + `((simple-array ,(sb!vm:saetp-specifier saetp) (*)) + ,(if (or (eq (sb!vm:saetp-specifier saetp) 'character) #!+sb-unicode - (eq (sb!vm:saetp-specifier saetp) 'base-char)) - *default-init-char-form* - (sb!vm:saetp-initial-element-default saetp)))) - (remove-if-not - #'sb!vm:saetp-specifier - sb!vm:*specialized-array-element-type-properties*))))) + (eq (sb!vm:saetp-specifier saetp) 'base-char)) + *default-init-char-form* + (sb!vm:saetp-initial-element-default saetp)))) + (remove-if-not + #'sb!vm:saetp-specifier + sb!vm:*specialized-array-element-type-properties*))))) ;; Only arrays have fill-pointers, but vectors have their length ;; parameter in the same place. (setf (%array-fill-pointer vector) new-length) @@ -934,20 +934,20 @@ of specialized arrays is supported." ;;; Fill in array header with the provided information, and return the array. (defun set-array-header (array data length fill-pointer displacement dimensions - &optional displacedp) + &optional displacedp) (setf (%array-data-vector array) data) (setf (%array-available-elements array) length) (cond (fill-pointer - (setf (%array-fill-pointer array) fill-pointer) - (setf (%array-fill-pointer-p array) t)) - (t - (setf (%array-fill-pointer array) length) - (setf (%array-fill-pointer-p array) nil))) + (setf (%array-fill-pointer array) fill-pointer) + (setf (%array-fill-pointer-p array) t)) + (t + (setf (%array-fill-pointer array) length) + (setf (%array-fill-pointer-p array) nil))) (setf (%array-displacement array) displacement) (if (listp dimensions) (dotimes (axis (array-rank array)) - (declare (type index axis)) - (setf (%array-dimension array axis) (pop dimensions))) + (declare (type index axis)) + (setf (%array-dimension array axis) (pop dimensions))) (setf (%array-dimension array 0) dimensions)) (setf (%array-displaced-p array) displacedp) array) @@ -959,17 +959,17 @@ of specialized arrays is supported." (defvar *zap-array-data-temp* (make-array 1000 :initial-element t)) (defun zap-array-data-temp (length element-type initial-element - initial-element-p) + initial-element-p) (declare (fixnum length)) (when (> length (the fixnum (length *zap-array-data-temp*))) (setf *zap-array-data-temp* - (make-array length :initial-element t))) + (make-array length :initial-element t))) (when initial-element-p (unless (typep initial-element element-type) (error "~S can't be used to initialize an array of type ~S." - initial-element element-type)) + initial-element element-type)) (fill (the simple-vector *zap-array-data-temp*) initial-element - :end length)) + :end length)) *zap-array-data-temp*) ;;; This does the grinding work for ADJUST-ARRAY. It zaps the data @@ -982,40 +982,40 @@ of specialized arrays is supported." ;;; NEW-DATA are not EQ, NEW-DATA has already been filled with any ;;; specified initial-element. (defun zap-array-data (old-data old-dims offset new-data new-dims new-length - element-type initial-element initial-element-p) + element-type initial-element initial-element-p) (declare (list old-dims new-dims)) (setq old-dims (nreverse old-dims)) (setq new-dims (reverse new-dims)) (if (eq old-data new-data) (let ((temp (zap-array-data-temp new-length element-type - initial-element initial-element-p))) - (zap-array-data-aux old-data old-dims offset temp new-dims) - (dotimes (i new-length) (setf (aref new-data i) (aref temp i)))) + initial-element initial-element-p))) + (zap-array-data-aux old-data old-dims offset temp new-dims) + (dotimes (i new-length) (setf (aref new-data i) (aref temp i)))) (zap-array-data-aux old-data old-dims offset new-data new-dims))) (defun zap-array-data-aux (old-data old-dims offset new-data new-dims) (declare (fixnum offset)) (let ((limits (mapcar (lambda (x y) - (declare (fixnum x y)) - (1- (the fixnum (min x y)))) - old-dims new-dims))) + (declare (fixnum x y)) + (1- (the fixnum (min x y)))) + old-dims new-dims))) (macrolet ((bump-index-list (index limits) - `(do ((subscripts ,index (cdr subscripts)) - (limits ,limits (cdr limits))) - ((null subscripts) :eof) - (cond ((< (the fixnum (car subscripts)) - (the fixnum (car limits))) - (rplaca subscripts - (1+ (the fixnum (car subscripts)))) - (return ,index)) - (t (rplaca subscripts 0)))))) + `(do ((subscripts ,index (cdr subscripts)) + (limits ,limits (cdr limits))) + ((null subscripts) :eof) + (cond ((< (the fixnum (car subscripts)) + (the fixnum (car limits))) + (rplaca subscripts + (1+ (the fixnum (car subscripts)))) + (return ,index)) + (t (rplaca subscripts 0)))))) (do ((index (make-list (length old-dims) :initial-element 0) - (bump-index-list index limits))) - ((eq index :eof)) - (setf (aref new-data (row-major-index-from-dims index new-dims)) - (aref old-data - (+ (the fixnum (row-major-index-from-dims index old-dims)) - offset))))))) + (bump-index-list index limits))) + ((eq index :eof)) + (setf (aref new-data (row-major-index-from-dims index new-dims)) + (aref old-data + (+ (the fixnum (row-major-index-from-dims index old-dims)) + offset))))))) ;;; Figure out the row-major-order index of an array reference from a ;;; list of subscripts and a list of dimensions. This is for internal @@ -1029,8 +1029,8 @@ of specialized arrays is supported." ((null rev-dim-list) result) (declare (fixnum chunk-size result)) (setq result (+ result - (the fixnum (* (the fixnum (car rev-subscripts)) - chunk-size)))) + (the fixnum (* (the fixnum (car rev-subscripts)) + chunk-size)))) (setq chunk-size (* chunk-size (the fixnum (car rev-dim-list)))))) ;;;; some bit stuff @@ -1038,60 +1038,60 @@ of specialized arrays is supported." (defun bit-array-same-dimensions-p (array1 array2) (declare (type (array bit) array1 array2)) (and (= (array-rank array1) - (array-rank array2)) + (array-rank array2)) (dotimes (index (array-rank array1) t) - (when (/= (array-dimension array1 index) - (array-dimension array2 index)) - (return nil))))) + (when (/= (array-dimension array1 index) + (array-dimension array2 index)) + (return nil))))) (defun pick-result-array (result-bit-array bit-array-1) (case result-bit-array ((t) bit-array-1) ((nil) (make-array (array-dimensions bit-array-1) - :element-type 'bit - :initial-element 0)) + :element-type 'bit + :initial-element 0)) (t (unless (bit-array-same-dimensions-p bit-array-1 - result-bit-array) + result-bit-array) (error "~S and ~S don't have the same dimensions." - bit-array-1 result-bit-array)) + bit-array-1 result-bit-array)) result-bit-array))) (defmacro def-bit-array-op (name function) `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array) #!+sb-doc ,(format nil - "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~ + "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~ BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~ If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~ RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~ All the arrays must have the same rank and dimensions." - (symbol-name function)) + (symbol-name function)) (declare (type (array bit) bit-array-1 bit-array-2) - (type (or (array bit) (member t nil)) result-bit-array)) + (type (or (array bit) (member t nil)) result-bit-array)) (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2) (error "~S and ~S don't have the same dimensions." - bit-array-1 bit-array-2)) + bit-array-1 bit-array-2)) (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) (if (and (simple-bit-vector-p bit-array-1) - (simple-bit-vector-p bit-array-2) - (simple-bit-vector-p result-bit-array)) - (locally (declare (optimize (speed 3) (safety 0))) - (,name bit-array-1 bit-array-2 result-bit-array)) - (with-array-data ((data1 bit-array-1) (start1) (end1)) - (declare (ignore end1)) - (with-array-data ((data2 bit-array-2) (start2) (end2)) - (declare (ignore end2)) - (with-array-data ((data3 result-bit-array) (start3) (end3)) - (do ((index-1 start1 (1+ index-1)) - (index-2 start2 (1+ index-2)) - (index-3 start3 (1+ index-3))) - ((>= index-3 end3) result-bit-array) - (declare (type index index-1 index-2 index-3)) - (setf (sbit data3 index-3) - (logand (,function (sbit data1 index-1) - (sbit data2 index-2)) - 1)))))))))) + (simple-bit-vector-p bit-array-2) + (simple-bit-vector-p result-bit-array)) + (locally (declare (optimize (speed 3) (safety 0))) + (,name bit-array-1 bit-array-2 result-bit-array)) + (with-array-data ((data1 bit-array-1) (start1) (end1)) + (declare (ignore end1)) + (with-array-data ((data2 bit-array-2) (start2) (end2)) + (declare (ignore end2)) + (with-array-data ((data3 result-bit-array) (start3) (end3)) + (do ((index-1 start1 (1+ index-1)) + (index-2 start2 (1+ index-2)) + (index-3 start3 (1+ index-3))) + ((>= index-3 end3) result-bit-array) + (declare (type index index-1 index-2 index-3)) + (setf (sbit data3 index-3) + (logand (,function (sbit data1 index-1) + (sbit data2 index-2)) + 1)))))))))) (def-bit-array-op bit-and logand) (def-bit-array-op bit-ior logior) @@ -1111,18 +1111,18 @@ of specialized arrays is supported." BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is created. Both arrays must have the same rank and dimensions." (declare (type (array bit) bit-array) - (type (or (array bit) (member t nil)) result-bit-array)) + (type (or (array bit) (member t nil)) result-bit-array)) (let ((result-bit-array (pick-result-array result-bit-array bit-array))) (if (and (simple-bit-vector-p bit-array) - (simple-bit-vector-p result-bit-array)) - (locally (declare (optimize (speed 3) (safety 0))) - (bit-not bit-array result-bit-array)) - (with-array-data ((src bit-array) (src-start) (src-end)) - (declare (ignore src-end)) - (with-array-data ((dst result-bit-array) (dst-start) (dst-end)) - (do ((src-index src-start (1+ src-index)) - (dst-index dst-start (1+ dst-index))) - ((>= dst-index dst-end) result-bit-array) - (declare (type index src-index dst-index)) - (setf (sbit dst dst-index) - (logxor (sbit src src-index) 1)))))))) + (simple-bit-vector-p result-bit-array)) + (locally (declare (optimize (speed 3) (safety 0))) + (bit-not bit-array result-bit-array)) + (with-array-data ((src bit-array) (src-start) (src-end)) + (declare (ignore src-end)) + (with-array-data ((dst result-bit-array) (dst-start) (dst-end)) + (do ((src-index src-start (1+ src-index)) + (dst-index dst-start (1+ dst-index))) + ((>= dst-index dst-end) result-bit-array) + (declare (type index src-index dst-index)) + (setf (sbit dst dst-index) + (logxor (sbit src src-index) 1)))))))) diff --git a/src/code/backq.lisp b/src/code/backq.lisp index 0e7896d..cd418aa 100644 --- a/src/code/backq.lisp +++ b/src/code/backq.lisp @@ -16,8 +16,8 @@ ;;; The flags passed back by BACKQUOTIFY can be interpreted as follows: ;;; ;;; |`,|: [a] => a -;;; NIL: [a] => a ;the NIL flag is used only when a is NIL -;;; T: [a] => a ;the T flag is used when a is self-evaluating +;;; NIL: [a] => a ;the NIL flag is used only when a is NIL +;;; T: [a] => a ;the T flag is used when a is self-evaluating ;;; QUOTE: [a] => (QUOTE a) ;;; APPEND: [a] => (APPEND . a) ;;; NCONC: [a] => (NCONC . a) @@ -54,11 +54,11 @@ (declare (ignore ignore)) (let ((*backquote-count* (1+ *backquote-count*))) (multiple-value-bind (flag thing) - (backquotify stream (read stream t nil t)) + (backquotify stream (read stream t nil t)) (when (eq flag *bq-at-flag*) - (%reader-error stream ",@ after backquote in ~S" thing)) + (%reader-error stream ",@ after backquote in ~S" thing)) (when (eq flag *bq-dot-flag*) - (%reader-error stream ",. after backquote in ~S" thing)) + (%reader-error stream ",. after backquote in ~S" thing)) (backquotify-1 flag thing)))) (/show0 "backq.lisp 64") @@ -70,13 +70,13 @@ (return-from comma-macro nil)) (%reader-error stream "comma not inside a backquote")) (let ((c (read-char stream)) - (*backquote-count* (1- *backquote-count*))) + (*backquote-count* (1- *backquote-count*))) (cond ((char= c #\@) - (cons *bq-at-flag* (read stream t nil t))) - ((char= c #\.) - (cons *bq-dot-flag* (read stream t nil t))) - (t (unread-char c stream) - (cons *bq-comma-flag* (read stream t nil t)))))) + (cons *bq-at-flag* (read stream t nil t))) + ((char= c #\.) + (cons *bq-dot-flag* (read stream t nil t))) + (t (unread-char c stream) + (cons *bq-comma-flag* (read stream t nil t)))))) (/show0 "backq.lisp 83") @@ -90,107 +90,107 @@ ;;; This does the expansion from table 2. (defun backquotify (stream code) (cond ((atom code) - (cond ((null code) (values nil nil)) - ((or (consp code) + (cond ((null code) (values nil nil)) + ((or (consp code) (symbolp code)) - ;; Keywords are self-evaluating. Install after packages. + ;; Keywords are self-evaluating. Install after packages. (values 'quote code)) - (t (values t code)))) - ((or (eq (car code) *bq-at-flag*) - (eq (car code) *bq-dot-flag*)) - (values (car code) (cdr code))) - ((eq (car code) *bq-comma-flag*) - (comma (cdr code))) - ((eq (car code) *bq-vector-flag*) - (multiple-value-bind (dflag d) (backquotify stream (cdr code)) - (values 'vector (backquotify-1 dflag d)))) - (t (multiple-value-bind (aflag a) (backquotify stream (car code)) - (multiple-value-bind (dflag d) (backquotify stream (cdr code)) - (when (eq dflag *bq-at-flag*) - ;; Get the errors later. - (%reader-error stream ",@ after dot in ~S" code)) - (when (eq dflag *bq-dot-flag*) - (%reader-error stream ",. after dot in ~S" code)) - (cond - ((eq aflag *bq-at-flag*) - (if (null dflag) - (if (expandable-backq-expression-p a) + (t (values t code)))) + ((or (eq (car code) *bq-at-flag*) + (eq (car code) *bq-dot-flag*)) + (values (car code) (cdr code))) + ((eq (car code) *bq-comma-flag*) + (comma (cdr code))) + ((eq (car code) *bq-vector-flag*) + (multiple-value-bind (dflag d) (backquotify stream (cdr code)) + (values 'vector (backquotify-1 dflag d)))) + (t (multiple-value-bind (aflag a) (backquotify stream (car code)) + (multiple-value-bind (dflag d) (backquotify stream (cdr code)) + (when (eq dflag *bq-at-flag*) + ;; Get the errors later. + (%reader-error stream ",@ after dot in ~S" code)) + (when (eq dflag *bq-dot-flag*) + (%reader-error stream ",. after dot in ~S" code)) + (cond + ((eq aflag *bq-at-flag*) + (if (null dflag) + (if (expandable-backq-expression-p a) (values 'append (list a)) (comma a)) - (values 'append - (cond ((eq dflag 'append) - (cons a d )) - (t (list a (backquotify-1 dflag d))))))) - ((eq aflag *bq-dot-flag*) - (if (null dflag) - (if (expandable-backq-expression-p a) + (values 'append + (cond ((eq dflag 'append) + (cons a d )) + (t (list a (backquotify-1 dflag d))))))) + ((eq aflag *bq-dot-flag*) + (if (null dflag) + (if (expandable-backq-expression-p a) (values 'nconc (list a)) (comma a)) - (values 'nconc - (cond ((eq dflag 'nconc) - (cons a d)) - (t (list a (backquotify-1 dflag d))))))) - ((null dflag) - (if (member aflag '(quote t nil)) - (values 'quote (list a)) - (values 'list (list (backquotify-1 aflag a))))) - ((member dflag '(quote t)) - (if (member aflag '(quote t nil)) - (values 'quote (cons a d )) - (values 'list* (list (backquotify-1 aflag a) - (backquotify-1 dflag d))))) - (t (setq a (backquotify-1 aflag a)) - (if (member dflag '(list list*)) - (values dflag (cons a d)) - (values 'list* - (list a (backquotify-1 dflag d))))))))))) + (values 'nconc + (cond ((eq dflag 'nconc) + (cons a d)) + (t (list a (backquotify-1 dflag d))))))) + ((null dflag) + (if (member aflag '(quote t nil)) + (values 'quote (list a)) + (values 'list (list (backquotify-1 aflag a))))) + ((member dflag '(quote t)) + (if (member aflag '(quote t nil)) + (values 'quote (cons a d )) + (values 'list* (list (backquotify-1 aflag a) + (backquotify-1 dflag d))))) + (t (setq a (backquotify-1 aflag a)) + (if (member dflag '(list list*)) + (values dflag (cons a d)) + (values 'list* + (list a (backquotify-1 dflag d))))))))))) (/show0 "backq.lisp 139") ;;; This handles the cases. (defun comma (code) (cond ((atom code) - (cond ((null code) - (values nil nil)) - ((or (numberp code) (eq code t)) - (values t code)) - (t (values *bq-comma-flag* code)))) - ((and (eq (car code) 'quote) + (cond ((null code) + (values nil nil)) + ((or (numberp code) (eq code t)) + (values t code)) + (t (values *bq-comma-flag* code)))) + ((and (eq (car code) 'quote) (not (expandable-backq-expression-p (cadr code)))) (values (car code) (cadr code))) - ((member (car code) '(append list list* nconc)) - (values (car code) (cdr code))) - ((eq (car code) 'cons) - (values 'list* (cdr code))) - (t (values *bq-comma-flag* code)))) + ((member (car code) '(append list list* nconc)) + (values (car code) (cdr code))) + ((eq (car code) 'cons) + (values 'list* (cdr code))) + (t (values *bq-comma-flag* code)))) (/show0 "backq.lisp 157") ;;; This handles table 1. (defun backquotify-1 (flag thing) (cond ((or (eq flag *bq-comma-flag*) - (member flag '(t nil))) - thing) - ((eq flag 'quote) - (list 'quote thing)) - ((eq flag 'list*) + (member flag '(t nil))) + thing) + ((eq flag 'quote) + (list 'quote thing)) + ((eq flag 'list*) (cond ((and (null (cddr thing)) (not (expandable-backq-expression-p (cadr thing)))) - (cons 'backq-cons thing)) - ((expandable-backq-expression-p (car (last thing))) + (cons 'backq-cons thing)) + ((expandable-backq-expression-p (car (last thing))) (list 'backq-append (cons 'backq-list (butlast thing)) ;; Can it be optimized further? -- APD, 2001-12-21 (car (last thing)))) (t - (cons 'backq-list* thing)))) - ((eq flag 'vector) - (list 'backq-vector thing)) - (t (cons (ecase flag - ((list) 'backq-list) - ((append) 'backq-append) - ((nconc) 'backq-nconc)) - thing)))) + (cons 'backq-list* thing)))) + ((eq flag 'vector) + (list 'backq-vector thing)) + (t (cons (ecase flag + ((list) 'backq-list) + ((append) 'backq-append) + ((nconc) 'backq-nconc)) + thing)))) ;;;; magic BACKQ- versions of builtin functions @@ -200,15 +200,15 @@ ;;; them, the backquoted material will be recognizable to the ;;; pretty-printer. (macrolet ((def (b-name name) - (let ((args (gensym "ARGS"))) - ;; FIXME: This function should be INLINE so that the lists - ;; aren't consed twice, but I ran into an optimizer bug the - ;; first time I tried to make this work for BACKQ-LIST. See - ;; whether there's still an optimizer bug, and fix it if so, and - ;; then make these INLINE. - `(defun ,b-name (&rest ,args) + (let ((args (gensym "ARGS"))) + ;; FIXME: This function should be INLINE so that the lists + ;; aren't consed twice, but I ran into an optimizer bug the + ;; first time I tried to make this work for BACKQ-LIST. See + ;; whether there's still an optimizer bug, and fix it if so, and + ;; then make these INLINE. + `(defun ,b-name (&rest ,args) (declare (dynamic-extent ,args)) - (apply #',name ,args))))) + (apply #',name ,args))))) (def backq-list list) (def backq-list* list*) (def backq-append append) diff --git a/src/code/bignum.lisp b/src/code/bignum.lisp index fc6c45e..2e76411 100644 --- a/src/code/bignum.lisp +++ b/src/code/bignum.lisp @@ -41,7 +41,7 @@ ;;; %BIGNUM-SET-LENGTH ;;; %FIXNUM-DIGIT-WITH-CORRECT-SIGN ;;; %SIGN-DIGIT -;;; %ASHR +;;; %ASHR ;;; %ASHL ;;; %BIGNUM-0-OR-PLUSP ;;; %DIGIT-LOGICAL-SHIFT-RIGHT @@ -87,12 +87,12 @@ ;;; fixnums ;;; logior, logxor, logand ;;; depending on relationals, < (twice) and <= (twice) -;;; or write compare thing (twice). +;;; or write compare thing (twice). ;;; LDB on fixnum with bignum result. ;;; DPB on fixnum with bignum result. ;;; TRUNCATE returns zero or one as one value and fixnum or minus fixnum -;;; for the other value when given (truncate fixnum bignum). -;;; Returns (truncate bignum fixnum) otherwise. +;;; for the other value when given (truncate fixnum bignum). +;;; Returns (truncate bignum fixnum) otherwise. ;;; addition ;;; subtraction (twice) ;;; multiply @@ -100,11 +100,11 @@ ;;; Write MASK-FIELD and DEPOSIT-FIELD in terms of logical operations. ;;; DIVIDE ;;; IF (/ x y) with bignums: -;;; do the truncate, and if rem is 0, return quotient. -;;; if rem is non-0 -;;; gcd of x and y. -;;; "truncate" each by gcd, ignoring remainder 0. -;;; form ratio of each result, bottom is positive. +;;; do the truncate, and if rem is 0, return quotient. +;;; if rem is non-0 +;;; gcd of x and y. +;;; "truncate" each by gcd, ignoring remainder 0. +;;; form ratio of each result, bottom is positive. ;;;; What's a bignum? @@ -131,12 +131,12 @@ ;;; to be able to return the digit somewhere no one looks for real objects. (defun %bignum-ref (bignum i) (declare (type bignum-type bignum) - (type bignum-index i)) + (type bignum-index i)) (%bignum-ref bignum i)) (defun %bignum-set (bignum i value) (declare (type bignum-type bignum) - (type bignum-index i) - (type bignum-element-type value)) + (type bignum-index i) + (type bignum-element-type value)) (%bignum-set bignum i value)) ;;; Return T if digit is positive, or NIL if negative. @@ -147,7 +147,7 @@ #!-sb-fluid (declaim (inline %bignum-0-or-plusp)) (defun %bignum-0-or-plusp (bignum len) (declare (type bignum-type bignum) - (type bignum-index len)) + (type bignum-index len)) (%digit-0-or-plusp (%bignum-ref bignum (1- len)))) ;;; This should be in assembler, and should not cons intermediate @@ -155,7 +155,7 @@ ;;; together a, b, and an incoming carry. (defun %add-with-carry (a b carry) (declare (type bignum-element-type a b) - (type (mod 2) carry)) + (type (mod 2) carry)) (%add-with-carry a b carry)) ;;; This should be in assembler, and should not cons intermediate @@ -165,7 +165,7 @@ ;;; We really do: a - b - 1 + borrow, where borrow is either 0 or 1. (defun %subtract-with-borrow (a b borrow) (declare (type bignum-element-type a b) - (type (mod 2) borrow)) + (type (mod 2) borrow)) (%subtract-with-borrow a b borrow)) ;;; Multiply two digit-size numbers, returning a 2*digit-size result @@ -185,7 +185,7 @@ ;;; accumulating partial results which is where the res-digit comes ;;; from. (defun %multiply-and-add (x-digit y-digit carry-in-digit - &optional (res-digit 0)) + &optional (res-digit 0)) (declare (type bignum-element-type x-digit y-digit res-digit carry-in-digit)) (%multiply-and-add x-digit y-digit carry-in-digit res-digit)) @@ -235,27 +235,27 @@ ;;; unsigned. (defun %ashr (data count) (declare (type bignum-element-type data) - (type (mod #.sb!vm:n-word-bits) count)) + (type (mod #.sb!vm:n-word-bits) count)) (%ashr data count)) ;;; This takes a digit-size quantity and shifts it to the left, ;;; returning a digit-size quantity. (defun %ashl (data count) (declare (type bignum-element-type data) - (type (mod #.sb!vm:n-word-bits) count)) + (type (mod #.sb!vm:n-word-bits) count)) (%ashl data count)) ;;; Do an unsigned (logical) right shift of a digit by Count. (defun %digit-logical-shift-right (data count) (declare (type bignum-element-type data) - (type (mod #.sb!vm:n-word-bits) count)) + (type (mod #.sb!vm:n-word-bits) count)) (%digit-logical-shift-right data count)) ;;; Change the length of bignum to be newlen. Newlen must be the same or ;;; smaller than the old length, and any elements beyond newlen must be zeroed. (defun %bignum-set-length (bignum newlen) (declare (type bignum-type bignum) - (type bignum-index newlen)) + (type bignum-index newlen)) (%bignum-set-length bignum newlen)) ;;; This returns 0 or "-1" depending on whether the bignum is positive. This @@ -265,7 +265,7 @@ #!-sb-fluid (declaim (inline %sign-digit)) (defun %sign-digit (bignum len) (declare (type bignum-type bignum) - (type bignum-index len)) + (type bignum-index len)) (%ashr (%bignum-ref bignum (1- len)) (1- digit-size))) ;;; These take two digit-size quantities and compare or contrast them @@ -283,50 +283,50 @@ (defun add-bignums (a b) (declare (type bignum-type a b)) (let ((len-a (%bignum-length a)) - (len-b (%bignum-length b))) + (len-b (%bignum-length b))) (declare (type bignum-index len-a len-b)) (multiple-value-bind (a len-a b len-b) - (if (> len-a len-b) - (values a len-a b len-b) - (values b len-b a len-a)) + (if (> len-a len-b) + (values a len-a b len-b) + (values b len-b a len-a)) (declare (type bignum-type a b) - (type bignum-index len-a len-b)) + (type bignum-index len-a len-b)) (let* ((len-res (1+ len-a)) - (res (%allocate-bignum len-res)) - (carry 0)) - (declare (type bignum-index len-res) - (type bignum-type res) - (type (mod 2) carry)) - (dotimes (i len-b) - (declare (type bignum-index i)) - (multiple-value-bind (v k) - (%add-with-carry (%bignum-ref a i) (%bignum-ref b i) carry) - (declare (type bignum-element-type v) - (type (mod 2) k)) - (setf (%bignum-ref res i) v) - (setf carry k))) - (if (/= len-a len-b) - (finish-add a res carry (%sign-digit b len-b) len-b len-a) - (setf (%bignum-ref res len-a) - (%add-with-carry (%sign-digit a len-a) - (%sign-digit b len-b) - carry))) - (%normalize-bignum res len-res))))) + (res (%allocate-bignum len-res)) + (carry 0)) + (declare (type bignum-index len-res) + (type bignum-type res) + (type (mod 2) carry)) + (dotimes (i len-b) + (declare (type bignum-index i)) + (multiple-value-bind (v k) + (%add-with-carry (%bignum-ref a i) (%bignum-ref b i) carry) + (declare (type bignum-element-type v) + (type (mod 2) k)) + (setf (%bignum-ref res i) v) + (setf carry k))) + (if (/= len-a len-b) + (finish-add a res carry (%sign-digit b len-b) len-b len-a) + (setf (%bignum-ref res len-a) + (%add-with-carry (%sign-digit a len-a) + (%sign-digit b len-b) + carry))) + (%normalize-bignum res len-res))))) ;;; This takes the longer of two bignums and propagates the carry through its ;;; remaining high order digits. (defun finish-add (a res carry sign-digit-b start end) (declare (type bignum-type a res) - (type (mod 2) carry) - (type bignum-element-type sign-digit-b) - (type bignum-index start end)) + (type (mod 2) carry) + (type bignum-element-type sign-digit-b) + (type bignum-index start end)) (do ((i start (1+ i))) ((= i end) (setf (%bignum-ref res end) - (%add-with-carry (%sign-digit a end) sign-digit-b carry))) + (%add-with-carry (%sign-digit a end) sign-digit-b carry))) (declare (type bignum-index i)) (multiple-value-bind (v k) - (%add-with-carry (%bignum-ref a i) sign-digit-b carry) + (%add-with-carry (%bignum-ref a i) sign-digit-b carry) (setf (%bignum-ref res i) v) (setf carry k))) (values)) @@ -340,26 +340,26 @@ ;;; as the result. This macro may evaluate its arguments more than once. (sb!xc:defmacro subtract-bignum-loop (a len-a b len-b res len-res return-fun) (let ((borrow (gensym)) - (a-digit (gensym)) - (a-sign (gensym)) - (b-digit (gensym)) - (b-sign (gensym)) - (i (gensym)) - (v (gensym)) - (k (gensym))) + (a-digit (gensym)) + (a-sign (gensym)) + (b-digit (gensym)) + (b-sign (gensym)) + (i (gensym)) + (v (gensym)) + (k (gensym))) `(let* ((,borrow 1) - (,a-sign (%sign-digit ,a ,len-a)) - (,b-sign (%sign-digit ,b ,len-b))) + (,a-sign (%sign-digit ,a ,len-a)) + (,b-sign (%sign-digit ,b ,len-b))) (declare (type bignum-element-type ,a-sign ,b-sign)) (dotimes (,i ,len-res) - (declare (type bignum-index ,i)) - (let ((,a-digit (if (< ,i ,len-a) (%bignum-ref ,a ,i) ,a-sign)) - (,b-digit (if (< ,i ,len-b) (%bignum-ref ,b ,i) ,b-sign))) - (declare (type bignum-element-type ,a-digit ,b-digit)) - (multiple-value-bind (,v ,k) - (%subtract-with-borrow ,a-digit ,b-digit ,borrow) - (setf (%bignum-ref ,res ,i) ,v) - (setf ,borrow ,k)))) + (declare (type bignum-index ,i)) + (let ((,a-digit (if (< ,i ,len-a) (%bignum-ref ,a ,i) ,a-sign)) + (,b-digit (if (< ,i ,len-b) (%bignum-ref ,b ,i) ,b-sign))) + (declare (type bignum-element-type ,a-digit ,b-digit)) + (multiple-value-bind (,v ,k) + (%subtract-with-borrow ,a-digit ,b-digit ,borrow) + (setf (%bignum-ref ,res ,i) ,v) + (setf ,borrow ,k)))) (,return-fun ,res ,len-res)))) ) ;EVAL-WHEN @@ -367,9 +367,9 @@ (defun subtract-bignum (a b) (declare (type bignum-type a b)) (let* ((len-a (%bignum-length a)) - (len-b (%bignum-length b)) - (len-res (1+ (max len-a len-b))) - (res (%allocate-bignum len-res))) + (len-b (%bignum-length b)) + (len-res (1+ (max len-a len-b))) + (res (%allocate-bignum len-res))) (declare (type bignum-index len-a len-b len-res)) ;Test len-res for bounds? (subtract-bignum-loop a len-a b len-b res len-res %normalize-bignum))) @@ -378,70 +378,70 @@ ;;; result. (defun subtract-bignum-buffers-with-len (a len-a b len-b result len-res) (declare (type bignum-type a b) - (type bignum-index len-a len-b)) + (type bignum-index len-a len-b)) (subtract-bignum-loop a len-a b len-b result len-res - %normalize-bignum-buffer)) + %normalize-bignum-buffer)) (defun subtract-bignum-buffers (a len-a b len-b result) (declare (type bignum-type a b) - (type bignum-index len-a len-b)) + (type bignum-index len-a len-b)) (subtract-bignum-loop a len-a b len-b result (max len-a len-b) - %normalize-bignum-buffer)) + %normalize-bignum-buffer)) ;;;; multiplication (defun multiply-bignums (a b) (declare (type bignum-type a b)) (let* ((a-plusp (%bignum-0-or-plusp a (%bignum-length a))) - (b-plusp (%bignum-0-or-plusp b (%bignum-length b))) - (a (if a-plusp a (negate-bignum a))) - (b (if b-plusp b (negate-bignum b))) - (len-a (%bignum-length a)) - (len-b (%bignum-length b)) - (len-res (+ len-a len-b)) - (res (%allocate-bignum len-res)) - (negate-res (not (eq a-plusp b-plusp)))) + (b-plusp (%bignum-0-or-plusp b (%bignum-length b))) + (a (if a-plusp a (negate-bignum a))) + (b (if b-plusp b (negate-bignum b))) + (len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (len-res (+ len-a len-b)) + (res (%allocate-bignum len-res)) + (negate-res (not (eq a-plusp b-plusp)))) (declare (type bignum-index len-a len-b len-res)) (dotimes (i len-a) (declare (type bignum-index i)) (let ((carry-digit 0) - (x (%bignum-ref a i)) - (k i)) - (declare (type bignum-index k) - (type bignum-element-type carry-digit x)) - (dotimes (j len-b) - (multiple-value-bind (big-carry res-digit) - (%multiply-and-add x - (%bignum-ref b j) - (%bignum-ref res k) - carry-digit) - (declare (type bignum-element-type big-carry res-digit)) - (setf (%bignum-ref res k) res-digit) - (setf carry-digit big-carry) - (incf k))) - (setf (%bignum-ref res k) carry-digit))) + (x (%bignum-ref a i)) + (k i)) + (declare (type bignum-index k) + (type bignum-element-type carry-digit x)) + (dotimes (j len-b) + (multiple-value-bind (big-carry res-digit) + (%multiply-and-add x + (%bignum-ref b j) + (%bignum-ref res k) + carry-digit) + (declare (type bignum-element-type big-carry res-digit)) + (setf (%bignum-ref res k) res-digit) + (setf carry-digit big-carry) + (incf k))) + (setf (%bignum-ref res k) carry-digit))) (when negate-res (negate-bignum-in-place res)) (%normalize-bignum res len-res))) (defun multiply-bignum-and-fixnum (bignum fixnum) (declare (type bignum-type bignum) (type fixnum fixnum)) (let* ((bignum-plus-p (%bignum-0-or-plusp bignum (%bignum-length bignum))) - (fixnum-plus-p (not (minusp fixnum))) - (bignum (if bignum-plus-p bignum (negate-bignum bignum))) - (bignum-len (%bignum-length bignum)) - (fixnum (if fixnum-plus-p fixnum (- fixnum))) - (result (%allocate-bignum (1+ bignum-len))) - (carry-digit 0)) + (fixnum-plus-p (not (minusp fixnum))) + (bignum (if bignum-plus-p bignum (negate-bignum bignum))) + (bignum-len (%bignum-length bignum)) + (fixnum (if fixnum-plus-p fixnum (- fixnum))) + (result (%allocate-bignum (1+ bignum-len))) + (carry-digit 0)) (declare (type bignum-type bignum result) - (type bignum-index bignum-len) - (type bignum-element-type fixnum carry-digit)) + (type bignum-index bignum-len) + (type bignum-element-type fixnum carry-digit)) (dotimes (index bignum-len) (declare (type bignum-index index)) (multiple-value-bind (next-digit low) - (%multiply-and-add (%bignum-ref bignum index) fixnum carry-digit) - (declare (type bignum-element-type next-digit low)) - (setf carry-digit next-digit) - (setf (%bignum-ref result index) low))) + (%multiply-and-add (%bignum-ref bignum index) fixnum carry-digit) + (declare (type bignum-element-type next-digit low)) + (setf carry-digit next-digit) + (setf (%bignum-ref result index) low))) (setf (%bignum-ref result bignum-len) carry-digit) (unless (eq bignum-plus-p fixnum-plus-p) (negate-bignum-in-place result)) @@ -450,76 +450,76 @@ (defun multiply-fixnums (a b) (declare (fixnum a b)) (let* ((a-minusp (minusp a)) - (b-minusp (minusp b))) + (b-minusp (minusp b))) (multiple-value-bind (high low) - (%multiply (if a-minusp (- a) a) - (if b-minusp (- b) b)) + (%multiply (if a-minusp (- a) a) + (if b-minusp (- b) b)) (declare (type bignum-element-type high low)) (if (and (zerop high) - (%digit-0-or-plusp low)) - (let ((low (sb!ext:truly-the (unsigned-byte #.(1- sb!vm:n-word-bits)) - (%fixnum-digit-with-correct-sign low)))) - (if (eq a-minusp b-minusp) - low - (- low))) - (let ((res (%allocate-bignum 2))) - (%bignum-set res 0 low) - (%bignum-set res 1 high) - (unless (eq a-minusp b-minusp) (negate-bignum-in-place res)) - (%normalize-bignum res 2)))))) + (%digit-0-or-plusp low)) + (let ((low (sb!ext:truly-the (unsigned-byte #.(1- sb!vm:n-word-bits)) + (%fixnum-digit-with-correct-sign low)))) + (if (eq a-minusp b-minusp) + low + (- low))) + (let ((res (%allocate-bignum 2))) + (%bignum-set res 0 low) + (%bignum-set res 1 high) + (unless (eq a-minusp b-minusp) (negate-bignum-in-place res)) + (%normalize-bignum res 2)))))) ;;;; BIGNUM-REPLACE and WITH-BIGNUM-BUFFERS (eval-when (:compile-toplevel :execute) (sb!xc:defmacro bignum-replace (dest - src - &key - (start1 '0) - end1 - (start2 '0) - end2 - from-end) + src + &key + (start1 '0) + end1 + (start2 '0) + end2 + from-end) (sb!int:once-only ((n-dest dest) - (n-src src)) + (n-src src)) (let ((n-start1 (gensym)) - (n-end1 (gensym)) - (n-start2 (gensym)) - (n-end2 (gensym)) - (i1 (gensym)) - (i2 (gensym)) - (end1 (or end1 `(%bignum-length ,n-dest))) - (end2 (or end2 `(%bignum-length ,n-src)))) + (n-end1 (gensym)) + (n-start2 (gensym)) + (n-end2 (gensym)) + (i1 (gensym)) + (i2 (gensym)) + (end1 (or end1 `(%bignum-length ,n-dest))) + (end2 (or end2 `(%bignum-length ,n-src)))) (if from-end - `(let ((,n-start1 ,start1) - (,n-start2 ,start2)) - (do ((,i1 (1- ,end1) (1- ,i1)) - (,i2 (1- ,end2) (1- ,i2))) - ((or (< ,i1 ,n-start1) (< ,i2 ,n-start2))) - (declare (fixnum ,i1 ,i2)) - (%bignum-set ,n-dest ,i1 - (%bignum-ref ,n-src ,i2)))) - `(let ((,n-end1 ,end1) - (,n-end2 ,end2)) - (do ((,i1 ,start1 (1+ ,i1)) - (,i2 ,start2 (1+ ,i2))) - ((or (>= ,i1 ,n-end1) (>= ,i2 ,n-end2))) - (declare (type bignum-index ,i1 ,i2)) - (%bignum-set ,n-dest ,i1 - (%bignum-ref ,n-src ,i2)))))))) + `(let ((,n-start1 ,start1) + (,n-start2 ,start2)) + (do ((,i1 (1- ,end1) (1- ,i1)) + (,i2 (1- ,end2) (1- ,i2))) + ((or (< ,i1 ,n-start1) (< ,i2 ,n-start2))) + (declare (fixnum ,i1 ,i2)) + (%bignum-set ,n-dest ,i1 + (%bignum-ref ,n-src ,i2)))) + `(let ((,n-end1 ,end1) + (,n-end2 ,end2)) + (do ((,i1 ,start1 (1+ ,i1)) + (,i2 ,start2 (1+ ,i2))) + ((or (>= ,i1 ,n-end1) (>= ,i2 ,n-end2))) + (declare (type bignum-index ,i1 ,i2)) + (%bignum-set ,n-dest ,i1 + (%bignum-ref ,n-src ,i2)))))))) (sb!xc:defmacro with-bignum-buffers (specs &body body) #!+sb-doc "WITH-BIGNUM-BUFFERS ({(var size [init])}*) Form*" (sb!int:collect ((binds) - (inits)) + (inits)) (dolist (spec specs) (let ((name (first spec)) - (size (second spec))) - (binds `(,name (%allocate-bignum ,size))) - (let ((init (third spec))) - (when init - (inits `(bignum-replace ,name ,init)))))) + (size (second spec))) + (binds `(,name (%allocate-bignum ,size))) + (let ((init (third spec))) + (when init + (inits `(bignum-replace ,name ,init)))))) `(let* ,(binds) ,@(inits) ,@body))) @@ -533,7 +533,7 @@ ;; check in normal use, and are disabled here. (sb!xc:defmacro gcd-assert (&rest args) (if nil - `(assert ,@args))) + `(assert ,@args))) ;; We'll be doing a lot of modular arithmetic. (sb!xc:defmacro modularly (form) `(logand all-ones-digit ,form))) @@ -543,8 +543,8 @@ ;;; it, we pay a heavy price in BIGNUM-GCD when compiled by the ;;; cross-compiler. -- CSR, 2004-07-19 (declaim (ftype (sfunction (bignum-type bignum-index bignum-type bignum-index) - sb!vm::positive-fixnum) - bignum-factors-of-two)) + sb!vm::positive-fixnum) + bignum-factors-of-two)) (defun bignum-factors-of-two (a len-a b len-b) (declare (type bignum-index len-a len-b) (type bignum-type a b)) (do ((i 0 (1+ i)) @@ -553,10 +553,10 @@ (declare (type bignum-index i end)) (let ((or-digits (%logior (%bignum-ref a i) (%bignum-ref b i)))) (unless (zerop or-digits) - (return (do ((j 0 (1+ j)) - (or-digits or-digits (%ashr or-digits 1))) - ((oddp or-digits) (+ (* i digit-size) j)) - (declare (type (mod #.sb!vm:n-word-bits) j)))))))) + (return (do ((j 0 (1+ j)) + (or-digits or-digits (%ashr or-digits 1))) + ((oddp or-digits) (+ (* i digit-size) j)) + (declare (type (mod #.sb!vm:n-word-bits) j)))))))) ;;; Multiply a bignum buffer with a fixnum or a digit, storing the ;;; result in another bignum buffer, and without using any @@ -565,32 +565,32 @@ ;;; MULTIPLY-BIGNUM-AND-FIXNUM. (declaim (inline multiply-bignum-buffer-and-smallnum-to-buffer)) (defun multiply-bignum-buffer-and-smallnum-to-buffer (bignum bignum-len - smallnum res) + smallnum res) (declare (type bignum-type bignum)) (let* ((bignum-plus-p (%bignum-0-or-plusp bignum bignum-len)) - (smallnum-plus-p (not (minusp smallnum))) - (smallnum (if smallnum-plus-p smallnum (- smallnum))) - (carry-digit 0)) + (smallnum-plus-p (not (minusp smallnum))) + (smallnum (if smallnum-plus-p smallnum (- smallnum))) + (carry-digit 0)) (declare (type bignum-type bignum res) - (type bignum-index bignum-len) - (type bignum-element-type smallnum carry-digit)) + (type bignum-index bignum-len) + (type bignum-element-type smallnum carry-digit)) (unless bignum-plus-p (negate-bignum-buffer-in-place bignum bignum-len)) (dotimes (index bignum-len) (declare (type bignum-index index)) (multiple-value-bind (next-digit low) - (%multiply-and-add (%bignum-ref bignum index) - smallnum - carry-digit) - (declare (type bignum-element-type next-digit low)) - (setf carry-digit next-digit) - (setf (%bignum-ref res index) low))) + (%multiply-and-add (%bignum-ref bignum index) + smallnum + carry-digit) + (declare (type bignum-element-type next-digit low)) + (setf carry-digit next-digit) + (setf (%bignum-ref res index) low))) (setf (%bignum-ref res bignum-len) carry-digit) (unless bignum-plus-p (negate-bignum-buffer-in-place bignum bignum-len)) (let ((res-len (%normalize-bignum-buffer res (1+ bignum-len)))) (unless (eq bignum-plus-p smallnum-plus-p) - (negate-bignum-buffer-in-place res res-len)) + (negate-bignum-buffer-in-place res res-len)) res-len))) ;;; Given U and V, return U / V mod 2^32. Implements the algorithm in the @@ -598,79 +598,79 @@ (declaim (inline bmod)) (defun bmod (u v) (let ((ud (%bignum-ref u 0)) - (vd (%bignum-ref v 0)) - (umask 0) - (imask 1) - (m 0)) + (vd (%bignum-ref v 0)) + (umask 0) + (imask 1) + (m 0)) (declare (type (unsigned-byte #.sb!vm:n-word-bits) ud vd umask imask m)) (dotimes (i digit-size) (setf umask (logior umask imask)) (unless (zerop (logand ud umask)) - (setf ud (modularly (- ud vd))) - (setf m (modularly (logior m imask)))) + (setf ud (modularly (- ud vd))) + (setf m (modularly (logior m imask)))) (setf imask (modularly (ash imask 1))) (setf vd (modularly (ash vd 1)))) m)) (defun dmod (u u-len v v-len tmp1) (loop while (> (bignum-buffer-integer-length u u-len) - (+ (bignum-buffer-integer-length v v-len) - digit-size)) + (+ (bignum-buffer-integer-length v v-len) + digit-size)) do (unless (zerop (%bignum-ref u 0)) (let* ((bmod (bmod u v)) - (tmp1-len (multiply-bignum-buffer-and-smallnum-to-buffer v v-len - bmod - tmp1))) - (setf u-len (subtract-bignum-buffers u u-len - tmp1 tmp1-len - u)) - (bignum-abs-buffer u u-len))) + (tmp1-len (multiply-bignum-buffer-and-smallnum-to-buffer v v-len + bmod + tmp1))) + (setf u-len (subtract-bignum-buffers u u-len + tmp1 tmp1-len + u)) + (bignum-abs-buffer u u-len))) (gcd-assert (zerop (%bignum-ref u 0))) (setf u-len (bignum-buffer-ashift-right u u-len digit-size))) (let* ((d (+ 1 (- (bignum-buffer-integer-length u u-len) - (bignum-buffer-integer-length v v-len)))) - (n (1- (ash 1 d)))) + (bignum-buffer-integer-length v v-len)))) + (n (1- (ash 1 d)))) (declare (type (unsigned-byte #.(integer-length #.sb!vm:n-word-bits)) d) - (type (unsigned-byte #.sb!vm:n-word-bits) n)) + (type (unsigned-byte #.sb!vm:n-word-bits) n)) (gcd-assert (>= d 0)) (unless (zerop (logand (%bignum-ref u 0) n)) (let ((tmp1-len - (multiply-bignum-buffer-and-smallnum-to-buffer v v-len - (logand n (bmod u - v)) - tmp1))) - (setf u-len (subtract-bignum-buffers u u-len - tmp1 tmp1-len - u)) - (bignum-abs-buffer u u-len))) + (multiply-bignum-buffer-and-smallnum-to-buffer v v-len + (logand n (bmod u + v)) + tmp1))) + (setf u-len (subtract-bignum-buffers u u-len + tmp1 tmp1-len + u)) + (bignum-abs-buffer u u-len))) u-len)) (defconstant lower-ones-digit (1- (ash 1 (truncate sb!vm:n-word-bits 2)))) - + ;;; Find D and N such that (LOGAND ALL-ONES-DIGIT (- (* D X) (* N Y))) is 0, ;;; (< 0 N LOWER-ONES-DIGIT) and (< 0 (ABS D) LOWER-ONES-DIGIT). (defun reduced-ratio-mod (x y) (let* ((c (bmod x y)) - (n1 c) - (d1 1) - (n2 (modularly (1+ (modularly (lognot n1))))) - (d2 (modularly -1))) + (n1 c) + (d1 1) + (n2 (modularly (1+ (modularly (lognot n1))))) + (d2 (modularly -1))) (declare (type (unsigned-byte #.sb!vm:n-word-bits) n1 d1 n2 d2)) (loop while (> n2 (expt 2 (truncate digit-size 2))) do - (loop for i of-type (mod #.sb!vm:n-word-bits) - downfrom (- (integer-length n1) (integer-length n2)) - while (>= n1 n2) do - (when (>= n1 (modularly (ash n2 i))) - (psetf n1 (modularly (- n1 (modularly (ash n2 i)))) - d1 (modularly (- d1 (modularly (ash d2 i))))))) - (psetf n1 n2 - d1 d2 - n2 n1 - d2 d1)) + (loop for i of-type (mod #.sb!vm:n-word-bits) + downfrom (- (integer-length n1) (integer-length n2)) + while (>= n1 n2) do + (when (>= n1 (modularly (ash n2 i))) + (psetf n1 (modularly (- n1 (modularly (ash n2 i)))) + d1 (modularly (- d1 (modularly (ash d2 i))))))) + (psetf n1 n2 + d1 d2 + n2 n1 + d2 d1)) (values n2 (if (>= d2 (expt 2 (1- digit-size))) - (lognot (logand most-positive-fixnum (lognot d2))) - (logand lower-ones-digit d2))))) + (lognot (logand most-positive-fixnum (lognot d2))) + (logand lower-ones-digit d2))))) (defun copy-bignum (a &optional (len (%bignum-length a))) @@ -678,7 +678,7 @@ (bignum-replace b a) (%bignum-set-length b len) b)) - + ;;; Allocate a single word bignum that holds fixnum. This is useful when ;;; we are trying to mix fixnum and bignum operands. #!-sb-fluid (declaim (inline make-small-bignum)) @@ -688,7 +688,7 @@ res)) ;; When the larger number is less than this many bignum digits long, revert -;; to old algorithm. +;; to old algorithm. (defparameter *accelerated-gcd-cutoff* 3) ;;; Alternate between k-ary reduction with the help of @@ -701,96 +701,96 @@ (defun bignum-gcd (u0 v0) (declare (type bignum-type u0 v0)) (let* ((u1 (if (%bignum-0-or-plusp u0 (%bignum-length u0)) - u0 - (negate-bignum u0 nil))) - (v1 (if (%bignum-0-or-plusp v0 (%bignum-length v0)) - v0 - (negate-bignum v0 nil)))) + u0 + (negate-bignum u0 nil))) + (v1 (if (%bignum-0-or-plusp v0 (%bignum-length v0)) + v0 + (negate-bignum v0 nil)))) (if (zerop v1) - (return-from bignum-gcd u1)) + (return-from bignum-gcd u1)) (when (> u1 v1) (rotatef u1 v1)) (let ((n (mod v1 u1))) (setf v1 (if (fixnump n) - (make-small-bignum n) - n))) + (make-small-bignum n) + n))) (if (and (= 1 (%bignum-length v1)) - (zerop (%bignum-ref v1 0))) - (return-from bignum-gcd (%normalize-bignum u1 - (%bignum-length u1)))) + (zerop (%bignum-ref v1 0))) + (return-from bignum-gcd (%normalize-bignum u1 + (%bignum-length u1)))) (let* ((buffer-len (+ 2 (%bignum-length u1))) - (u (%allocate-bignum buffer-len)) - (u-len (%bignum-length u1)) - (v (%allocate-bignum buffer-len)) - (v-len (%bignum-length v1)) - (tmp1 (%allocate-bignum buffer-len)) - (tmp1-len 0) - (tmp2 (%allocate-bignum buffer-len)) - (tmp2-len 0) - (factors-of-two - (bignum-factors-of-two u1 (%bignum-length u1) - v1 (%bignum-length v1)))) + (u (%allocate-bignum buffer-len)) + (u-len (%bignum-length u1)) + (v (%allocate-bignum buffer-len)) + (v-len (%bignum-length v1)) + (tmp1 (%allocate-bignum buffer-len)) + (tmp1-len 0) + (tmp2 (%allocate-bignum buffer-len)) + (tmp2-len 0) + (factors-of-two + (bignum-factors-of-two u1 (%bignum-length u1) + v1 (%bignum-length v1)))) (declare (type (or null bignum-index) - buffer-len u-len v-len tmp1-len tmp2-len)) + buffer-len u-len v-len tmp1-len tmp2-len)) (bignum-replace u u1) (bignum-replace v v1) (setf u-len - (make-gcd-bignum-odd u - (bignum-buffer-ashift-right u u-len - factors-of-two))) + (make-gcd-bignum-odd u + (bignum-buffer-ashift-right u u-len + factors-of-two))) (setf v-len - (make-gcd-bignum-odd v - (bignum-buffer-ashift-right v v-len - factors-of-two))) + (make-gcd-bignum-odd v + (bignum-buffer-ashift-right v v-len + factors-of-two))) (loop until (or (< u-len *accelerated-gcd-cutoff*) - (not v-len) - (zerop v-len) - (and (= 1 v-len) - (zerop (%bignum-ref v 0)))) - do - (gcd-assert (= buffer-len (%bignum-length u) - (%bignum-length v) - (%bignum-length tmp1) - (%bignum-length tmp2))) - (if (> (bignum-buffer-integer-length u u-len) - (+ #.(truncate sb!vm:n-word-bits 4) - (bignum-buffer-integer-length v v-len))) - (setf u-len (dmod u u-len - v v-len - tmp1)) - (multiple-value-bind (n d) (reduced-ratio-mod u v) - (setf tmp1-len - (multiply-bignum-buffer-and-smallnum-to-buffer v v-len - n tmp1)) - (setf tmp2-len - (multiply-bignum-buffer-and-smallnum-to-buffer u u-len - d tmp2)) - (gcd-assert (= (copy-bignum tmp2 tmp2-len) - (* (copy-bignum u u-len) d))) - (gcd-assert (= (copy-bignum tmp1 tmp1-len) - (* (copy-bignum v v-len) n))) - (setf u-len - (subtract-bignum-buffers-with-len tmp1 tmp1-len - tmp2 tmp2-len - u - (1+ (max tmp1-len - tmp2-len)))) - (gcd-assert (or (zerop (- (copy-bignum tmp1 tmp1-len) - (copy-bignum tmp2 tmp2-len))) - (= (copy-bignum u u-len) - (- (copy-bignum tmp1 tmp1-len) - (copy-bignum tmp2 tmp2-len))))) - (bignum-abs-buffer u u-len) - (gcd-assert (zerop (modularly u))))) - (setf u-len (make-gcd-bignum-odd u u-len)) - (rotatef u v) - (rotatef u-len v-len)) + (not v-len) + (zerop v-len) + (and (= 1 v-len) + (zerop (%bignum-ref v 0)))) + do + (gcd-assert (= buffer-len (%bignum-length u) + (%bignum-length v) + (%bignum-length tmp1) + (%bignum-length tmp2))) + (if (> (bignum-buffer-integer-length u u-len) + (+ #.(truncate sb!vm:n-word-bits 4) + (bignum-buffer-integer-length v v-len))) + (setf u-len (dmod u u-len + v v-len + tmp1)) + (multiple-value-bind (n d) (reduced-ratio-mod u v) + (setf tmp1-len + (multiply-bignum-buffer-and-smallnum-to-buffer v v-len + n tmp1)) + (setf tmp2-len + (multiply-bignum-buffer-and-smallnum-to-buffer u u-len + d tmp2)) + (gcd-assert (= (copy-bignum tmp2 tmp2-len) + (* (copy-bignum u u-len) d))) + (gcd-assert (= (copy-bignum tmp1 tmp1-len) + (* (copy-bignum v v-len) n))) + (setf u-len + (subtract-bignum-buffers-with-len tmp1 tmp1-len + tmp2 tmp2-len + u + (1+ (max tmp1-len + tmp2-len)))) + (gcd-assert (or (zerop (- (copy-bignum tmp1 tmp1-len) + (copy-bignum tmp2 tmp2-len))) + (= (copy-bignum u u-len) + (- (copy-bignum tmp1 tmp1-len) + (copy-bignum tmp2 tmp2-len))))) + (bignum-abs-buffer u u-len) + (gcd-assert (zerop (modularly u))))) + (setf u-len (make-gcd-bignum-odd u u-len)) + (rotatef u v) + (rotatef u-len v-len)) (setf u (copy-bignum u u-len)) - (let ((n (bignum-mod-gcd v1 u))) - (ash (bignum-mod-gcd u1 (if (fixnump n) - (make-small-bignum n) - n)) - factors-of-two))))) + (let ((n (bignum-mod-gcd v1 u))) + (ash (bignum-mod-gcd u1 (if (fixnump n) + (make-small-bignum n) + n)) + factors-of-two))))) (defun bignum-mod-gcd (a b) (declare (type bignum-type a b)) @@ -801,13 +801,13 @@ ;; A and B pretty quickly). After that, use the binary GCD ;; algorithm to handle the rest. (loop until (and (= (%bignum-length b) 1) (zerop (%bignum-ref b 0))) do - (when (<= (%bignum-length a) (1+ (%bignum-length b))) - (return-from bignum-mod-gcd (bignum-binary-gcd a b))) - (let ((rem (mod a b))) - (if (fixnump rem) - (setf a (make-small-bignum rem)) - (setf a rem)) - (rotatef a b))) + (when (<= (%bignum-length a) (1+ (%bignum-length b))) + (return-from bignum-mod-gcd (bignum-binary-gcd a b))) + (let ((rem (mod a b))) + (if (fixnump rem) + (setf a (make-small-bignum rem)) + (setf a rem)) + (rotatef a b))) (if (= (%bignum-length a) 1) (%normalize-bignum a 1) a)) @@ -815,84 +815,84 @@ (defun bignum-binary-gcd (a b) (declare (type bignum-type a b)) (let* ((len-a (%bignum-length a)) - (len-b (%bignum-length b))) + (len-b (%bignum-length b))) (declare (type bignum-index len-a len-b)) (with-bignum-buffers ((a-buffer len-a a) - (b-buffer len-b b) - (res-buffer (max len-a len-b))) + (b-buffer len-b b) + (res-buffer (max len-a len-b))) (let* ((factors-of-two - (bignum-factors-of-two a-buffer len-a - b-buffer len-b)) - (len-a (make-gcd-bignum-odd - a-buffer - (bignum-buffer-ashift-right a-buffer len-a - factors-of-two))) - (len-b (make-gcd-bignum-odd - b-buffer - (bignum-buffer-ashift-right b-buffer len-b - factors-of-two)))) - (declare (type bignum-index len-a len-b)) - (let ((x a-buffer) - (len-x len-a) - (y b-buffer) - (len-y len-b) - (z res-buffer)) - (loop - (multiple-value-bind (u v len-v r len-r) - (bignum-gcd-order-and-subtract x len-x y len-y z) - (declare (type bignum-index len-v len-r)) - (when (and (= len-r 1) (zerop (%bignum-ref r 0))) - (if (zerop factors-of-two) - (let ((ret (%allocate-bignum len-v))) - (dotimes (i len-v) - (setf (%bignum-ref ret i) (%bignum-ref v i))) - (return (%normalize-bignum ret len-v))) - (return (bignum-ashift-left v factors-of-two len-v)))) - (setf x v len-x len-v) - (setf y r len-y (make-gcd-bignum-odd r len-r)) - (setf z u)))))))) + (bignum-factors-of-two a-buffer len-a + b-buffer len-b)) + (len-a (make-gcd-bignum-odd + a-buffer + (bignum-buffer-ashift-right a-buffer len-a + factors-of-two))) + (len-b (make-gcd-bignum-odd + b-buffer + (bignum-buffer-ashift-right b-buffer len-b + factors-of-two)))) + (declare (type bignum-index len-a len-b)) + (let ((x a-buffer) + (len-x len-a) + (y b-buffer) + (len-y len-b) + (z res-buffer)) + (loop + (multiple-value-bind (u v len-v r len-r) + (bignum-gcd-order-and-subtract x len-x y len-y z) + (declare (type bignum-index len-v len-r)) + (when (and (= len-r 1) (zerop (%bignum-ref r 0))) + (if (zerop factors-of-two) + (let ((ret (%allocate-bignum len-v))) + (dotimes (i len-v) + (setf (%bignum-ref ret i) (%bignum-ref v i))) + (return (%normalize-bignum ret len-v))) + (return (bignum-ashift-left v factors-of-two len-v)))) + (setf x v len-x len-v) + (setf y r len-y (make-gcd-bignum-odd r len-r)) + (setf z u)))))))) (defun bignum-gcd-order-and-subtract (a len-a b len-b res) (declare (type bignum-index len-a len-b) (type bignum-type a b)) (cond ((= len-a len-b) - (do ((i (1- len-a) (1- i))) - ((= i -1) - (setf (%bignum-ref res 0) 0) - (values a b len-b res 1)) - (let ((a-digit (%bignum-ref a i)) - (b-digit (%bignum-ref b i))) - (cond ((%digit-compare a-digit b-digit)) - ((%digit-greater a-digit b-digit) - (return - (values a b len-b res - (subtract-bignum-buffers a len-a b len-b - res)))) - (t - (return - (values b a len-a res - (subtract-bignum-buffers b len-b - a len-a - res)))))))) - ((> len-a len-b) - (values a b len-b res - (subtract-bignum-buffers a len-a b len-b res))) - (t - (values b a len-a res - (subtract-bignum-buffers b len-b a len-a res))))) + (do ((i (1- len-a) (1- i))) + ((= i -1) + (setf (%bignum-ref res 0) 0) + (values a b len-b res 1)) + (let ((a-digit (%bignum-ref a i)) + (b-digit (%bignum-ref b i))) + (cond ((%digit-compare a-digit b-digit)) + ((%digit-greater a-digit b-digit) + (return + (values a b len-b res + (subtract-bignum-buffers a len-a b len-b + res)))) + (t + (return + (values b a len-a res + (subtract-bignum-buffers b len-b + a len-a + res)))))))) + ((> len-a len-b) + (values a b len-b res + (subtract-bignum-buffers a len-a b len-b res))) + (t + (values b a len-a res + (subtract-bignum-buffers b len-b a len-a res))))) (defun make-gcd-bignum-odd (a len-a) (declare (type bignum-type a) (type bignum-index len-a)) (dotimes (index len-a) (declare (type bignum-index index)) (do ((digit (%bignum-ref a index) (%ashr digit 1)) - (increment 0 (1+ increment))) - ((zerop digit)) + (increment 0 (1+ increment))) + ((zerop digit)) (declare (type (mod #.sb!vm:n-word-bits) increment)) (when (oddp digit) - (return-from make-gcd-bignum-odd - (bignum-buffer-ashift-right a len-a - (+ (* index digit-size) - increment))))))) + (return-from make-gcd-bignum-odd + (bignum-buffer-ashift-right a len-a + (+ (* index digit-size) + increment))))))) ;;;; negation @@ -902,33 +902,33 @@ ;;; This negates bignum-len digits of bignum, storing the resulting digits into ;;; result (possibly EQ to bignum) and returning whatever end-carry there is. (sb!xc:defmacro bignum-negate-loop (bignum - bignum-len - &optional (result nil resultp)) + bignum-len + &optional (result nil resultp)) (let ((carry (gensym)) - (end (gensym)) - (value (gensym)) - (last (gensym))) + (end (gensym)) + (value (gensym)) + (last (gensym))) `(let* (,@(if (not resultp) `(,last)) - (,carry - (multiple-value-bind (,value ,carry) - (%add-with-carry (%lognot (%bignum-ref ,bignum 0)) 1 0) - ,(if resultp - `(setf (%bignum-ref ,result 0) ,value) - `(setf ,last ,value)) - ,carry)) - (i 1) - (,end ,bignum-len)) + (,carry + (multiple-value-bind (,value ,carry) + (%add-with-carry (%lognot (%bignum-ref ,bignum 0)) 1 0) + ,(if resultp + `(setf (%bignum-ref ,result 0) ,value) + `(setf ,last ,value)) + ,carry)) + (i 1) + (,end ,bignum-len)) (declare (type bit ,carry) - (type bignum-index i ,end)) + (type bignum-index i ,end)) (loop - (when (= i ,end) (return)) - (multiple-value-bind (,value temp) - (%add-with-carry (%lognot (%bignum-ref ,bignum i)) 0 ,carry) - ,(if resultp - `(setf (%bignum-ref ,result i) ,value) - `(setf ,last ,value)) - (setf ,carry temp)) - (incf i)) + (when (= i ,end) (return)) + (multiple-value-bind (,value temp) + (%add-with-carry (%lognot (%bignum-ref ,bignum i)) 0 ,carry) + ,(if resultp + `(setf (%bignum-ref ,result i) ,value) + `(setf ,last ,value)) + (setf ,carry temp)) + (incf i)) ,(if resultp carry `(values ,carry ,last))))) ) ; EVAL-WHEN @@ -938,15 +938,15 @@ (defun negate-bignum (x &optional (fully-normalize t)) (declare (type bignum-type x)) (let* ((len-x (%bignum-length x)) - (len-res (1+ len-x)) - (res (%allocate-bignum len-res))) + (len-res (1+ len-x)) + (res (%allocate-bignum len-res))) (declare (type bignum-index len-x len-res)) ;Test len-res for range? (let ((carry (bignum-negate-loop x len-x res))) (setf (%bignum-ref res len-x) - (%add-with-carry (%lognot (%sign-digit x len-x)) 0 carry))) + (%add-with-carry (%lognot (%sign-digit x len-x)) 0 carry))) (if fully-normalize - (%normalize-bignum res len-res) - (%mostly-normalize-bignum res len-res)))) + (%normalize-bignum res len-res) + (%mostly-normalize-bignum res len-res)))) ;;; This assumes bignum is positive; that is, the result of negating it will ;;; stay in the provided allocated bignum. @@ -979,26 +979,26 @@ ;;; digit from high bits of the i'th source digit and the start-pos number of ;;; bits from the i+1'th source digit. (sb!xc:defmacro shift-right-unaligned (source - start-digit - start-pos - res-len-form - termination - &optional result) + start-digit + start-pos + res-len-form + termination + &optional result) `(let* ((high-bits-in-first-digit (- digit-size ,start-pos)) - (res-len ,res-len-form) - (res-len-1 (1- res-len)) - ,@(if result `((,result (%allocate-bignum res-len))))) + (res-len ,res-len-form) + (res-len-1 (1- res-len)) + ,@(if result `((,result (%allocate-bignum res-len))))) (declare (type bignum-index res-len res-len-1)) (do ((i ,start-digit i+1) - (i+1 (1+ ,start-digit) (1+ i+1)) - (j 0 (1+ j))) - ,termination + (i+1 (1+ ,start-digit) (1+ i+1)) + (j 0 (1+ j))) + ,termination (declare (type bignum-index i i+1 j)) (setf (%bignum-ref ,(if result result source) j) - (%logior (%digit-logical-shift-right (%bignum-ref ,source i) - ,start-pos) - (%ashl (%bignum-ref ,source i+1) - high-bits-in-first-digit)))))) + (%logior (%digit-logical-shift-right (%bignum-ref ,source i) + ,start-pos) + (%ashl (%bignum-ref ,source i+1) + high-bits-in-first-digit)))))) ) ; EVAL-WHEN @@ -1012,40 +1012,40 @@ ;;; locals established by the macro. (defun bignum-ashift-right (bignum count) (declare (type bignum-type bignum) - (type unsigned-byte count)) + (type unsigned-byte count)) (let ((bignum-len (%bignum-length bignum))) (declare (type bignum-index bignum-len)) (cond ((fixnump count) - (multiple-value-bind (digits n-bits) (truncate count digit-size) - (declare (type bignum-index digits)) - (cond - ((>= digits bignum-len) - (if (%bignum-0-or-plusp bignum bignum-len) 0 -1)) - ((zerop n-bits) - (bignum-ashift-right-digits bignum digits)) - (t - (shift-right-unaligned bignum digits n-bits (- bignum-len digits) - ((= j res-len-1) - (setf (%bignum-ref res j) - (%ashr (%bignum-ref bignum i) n-bits)) - (%normalize-bignum res res-len)) - res))))) - ((> count bignum-len) - (if (%bignum-0-or-plusp bignum bignum-len) 0 -1)) - ;; Since a FIXNUM should be big enough to address anything in - ;; memory, including arrays of bits, and since arrays of bits - ;; take up about the same space as corresponding fixnums, there - ;; should be no way that we fall through to this case: any shift - ;; right by a bignum should give zero. But let's check anyway: - (t (error "bignum overflow: can't shift right by ~S" count))))) + (multiple-value-bind (digits n-bits) (truncate count digit-size) + (declare (type bignum-index digits)) + (cond + ((>= digits bignum-len) + (if (%bignum-0-or-plusp bignum bignum-len) 0 -1)) + ((zerop n-bits) + (bignum-ashift-right-digits bignum digits)) + (t + (shift-right-unaligned bignum digits n-bits (- bignum-len digits) + ((= j res-len-1) + (setf (%bignum-ref res j) + (%ashr (%bignum-ref bignum i) n-bits)) + (%normalize-bignum res res-len)) + res))))) + ((> count bignum-len) + (if (%bignum-0-or-plusp bignum bignum-len) 0 -1)) + ;; Since a FIXNUM should be big enough to address anything in + ;; memory, including arrays of bits, and since arrays of bits + ;; take up about the same space as corresponding fixnums, there + ;; should be no way that we fall through to this case: any shift + ;; right by a bignum should give zero. But let's check anyway: + (t (error "bignum overflow: can't shift right by ~S" count))))) (defun bignum-ashift-right-digits (bignum digits) (declare (type bignum-type bignum) - (type bignum-index digits)) + (type bignum-index digits)) (let* ((res-len (- (%bignum-length bignum) digits)) - (res (%allocate-bignum res-len))) + (res (%allocate-bignum res-len))) (declare (type bignum-index res-len) - (type bignum-type res)) + (type bignum-type res)) (bignum-replace res bignum :start2 digits) (%normalize-bignum res res-len))) @@ -1063,15 +1063,15 @@ (cond ((zerop n-bits) (let ((new-end (- bignum-len digits))) - (bignum-replace bignum bignum :end1 new-end :start2 digits - :end2 bignum-len) - (%normalize-bignum-buffer bignum new-end))) + (bignum-replace bignum bignum :end1 new-end :start2 digits + :end2 bignum-len) + (%normalize-bignum-buffer bignum new-end))) (t (shift-right-unaligned bignum digits n-bits (- bignum-len digits) - ((= j res-len-1) - (setf (%bignum-ref bignum j) - (%ashr (%bignum-ref bignum i) n-bits)) - (%normalize-bignum-buffer bignum res-len))))))) + ((= j res-len-1) + (setf (%bignum-ref bignum j) + (%ashr (%bignum-ref bignum i) n-bits)) + (%normalize-bignum-buffer bignum res-len))))))) ;;; This handles shifting a bignum buffer to provide fresh bignum data for some ;;; internal routines. We know bignum is safe when called with bignum-len. @@ -1081,17 +1081,17 @@ ;;; branch handles the general case. (defun bignum-ashift-left (bignum x &optional bignum-len) (declare (type bignum-type bignum) - (type unsigned-byte x) - (type (or null bignum-index) bignum-len)) + (type unsigned-byte x) + (type (or null bignum-index) bignum-len)) (if (fixnump x) (multiple-value-bind (digits n-bits) (truncate x digit-size) (let* ((bignum-len (or bignum-len (%bignum-length bignum))) - (res-len (+ digits bignum-len 1))) - (when (> res-len maximum-bignum-length) - (error "can't represent result of left shift")) - (if (zerop n-bits) - (bignum-ashift-left-digits bignum bignum-len digits) - (bignum-ashift-left-unaligned bignum digits n-bits res-len)))) + (res-len (+ digits bignum-len 1))) + (when (> res-len maximum-bignum-length) + (error "can't represent result of left shift")) + (if (zerop n-bits) + (bignum-ashift-left-digits bignum bignum-len digits) + (bignum-ashift-left-unaligned bignum digits n-bits res-len)))) ;; Left shift by a number too big to be represented as a fixnum ;; would exceed our memory capacity, since a fixnum is big enough ;; to index any array, including a bit array. @@ -1100,10 +1100,10 @@ (defun bignum-ashift-left-digits (bignum bignum-len digits) (declare (type bignum-index bignum-len digits)) (let* ((res-len (+ bignum-len digits)) - (res (%allocate-bignum res-len))) + (res (%allocate-bignum res-len))) (declare (type bignum-index res-len)) (bignum-replace res bignum :start1 digits :end1 res-len :end2 bignum-len - :from-end t) + :from-end t) res)) ;;; BIGNUM-TRUNCATE uses this to store into a bignum buffer by supplying res. @@ -1116,29 +1116,29 @@ ;;; first non-zero result digit, digits. We also grab some left over high ;;; bits from the last digit of bignum. (defun bignum-ashift-left-unaligned (bignum digits n-bits res-len - &optional (res nil resp)) + &optional (res nil resp)) (declare (type bignum-index digits res-len) - (type (mod #.digit-size) n-bits)) + (type (mod #.digit-size) n-bits)) (let* ((remaining-bits (- digit-size n-bits)) - (res-len-1 (1- res-len)) - (res (or res (%allocate-bignum res-len)))) + (res-len-1 (1- res-len)) + (res (or res (%allocate-bignum res-len)))) (declare (type bignum-index res-len res-len-1)) (do ((i 0 i+1) - (i+1 1 (1+ i+1)) - (j (1+ digits) (1+ j))) - ((= j res-len-1) - (setf (%bignum-ref res digits) - (%ashl (%bignum-ref bignum 0) n-bits)) - (setf (%bignum-ref res j) - (%ashr (%bignum-ref bignum i) remaining-bits)) - (if resp - (%normalize-bignum-buffer res res-len) - (%normalize-bignum res res-len))) + (i+1 1 (1+ i+1)) + (j (1+ digits) (1+ j))) + ((= j res-len-1) + (setf (%bignum-ref res digits) + (%ashl (%bignum-ref bignum 0) n-bits)) + (setf (%bignum-ref res j) + (%ashr (%bignum-ref bignum i) remaining-bits)) + (if resp + (%normalize-bignum-buffer res res-len) + (%normalize-bignum res res-len))) (declare (type bignum-index i i+1 j)) (setf (%bignum-ref res j) - (%logior (%digit-logical-shift-right (%bignum-ref bignum i) - remaining-bits) - (%ashl (%bignum-ref bignum i+1) n-bits)))))) + (%logior (%digit-logical-shift-right (%bignum-ref bignum i) + remaining-bits) + (%ashl (%bignum-ref bignum i+1) n-bits)))))) ;;;; relational operators @@ -1153,27 +1153,27 @@ (defun bignum-compare (a b) (declare (type bignum-type a b)) (let* ((len-a (%bignum-length a)) - (len-b (%bignum-length b)) - (a-plusp (%bignum-0-or-plusp a len-a)) - (b-plusp (%bignum-0-or-plusp b len-b))) + (len-b (%bignum-length b)) + (a-plusp (%bignum-0-or-plusp a len-a)) + (b-plusp (%bignum-0-or-plusp b len-b))) (declare (type bignum-index len-a len-b)) (cond ((not (eq a-plusp b-plusp)) - (if a-plusp 1 -1)) - ((= len-a len-b) - (do ((i (1- len-a) (1- i))) - (()) - (declare (type bignum-index i)) - (let ((a-digit (%bignum-ref a i)) - (b-digit (%bignum-ref b i))) - (declare (type bignum-element-type a-digit b-digit)) - (when (%digit-greater a-digit b-digit) - (return 1)) - (when (%digit-greater b-digit a-digit) - (return -1))) - (when (zerop i) (return 0)))) - ((> len-a len-b) - (if a-plusp 1 -1)) - (t (if a-plusp -1 1))))) + (if a-plusp 1 -1)) + ((= len-a len-b) + (do ((i (1- len-a) (1- i))) + (()) + (declare (type bignum-index i)) + (let ((a-digit (%bignum-ref a i)) + (b-digit (%bignum-ref b i))) + (declare (type bignum-element-type a-digit b-digit)) + (when (%digit-greater a-digit b-digit) + (return 1)) + (when (%digit-greater b-digit a-digit) + (return -1))) + (when (zerop i) (return 0)))) + ((> len-a len-b) + (if a-plusp 1 -1)) + (t (if a-plusp -1 1))))) ;;;; float conversion @@ -1183,28 +1183,28 @@ (declare (fixnum exp)) (declare (optimize #-sb-xc-host (sb!ext:inhibit-warnings 3))) (let ((res (dpb exp - sb!vm:single-float-exponent-byte - (logandc2 (logand #xffffffff - (%bignum-ref bits 1)) - sb!vm:single-float-hidden-bit)))) + sb!vm:single-float-exponent-byte + (logandc2 (logand #xffffffff + (%bignum-ref bits 1)) + sb!vm:single-float-hidden-bit)))) (make-single-float (if plusp - res - (logior res (ash -1 sb!vm:float-sign-shift)))))) + res + (logior res (ash -1 sb!vm:float-sign-shift)))))) (defun double-float-from-bits (bits exp plusp) (declare (fixnum exp)) (declare (optimize #-sb-xc-host (sb!ext:inhibit-warnings 3))) (let ((hi (dpb exp - sb!vm:double-float-exponent-byte - (logandc2 (ecase sb!vm::n-word-bits - (32 (%bignum-ref bits 2)) - (64 (ash (%bignum-ref bits 1) -32))) - sb!vm:double-float-hidden-bit))) - (lo (logand #xffffffff (%bignum-ref bits 1)))) + sb!vm:double-float-exponent-byte + (logandc2 (ecase sb!vm::n-word-bits + (32 (%bignum-ref bits 2)) + (64 (ash (%bignum-ref bits 1) -32))) + sb!vm:double-float-hidden-bit))) + (lo (logand #xffffffff (%bignum-ref bits 1)))) (make-double-float (if plusp - hi - (logior hi (ash -1 sb!vm:float-sign-shift))) - lo))) + hi + (logior hi (ash -1 sb!vm:float-sign-shift))) + lo))) #!+(and long-float x86) (defun long-float-from-bits (bits exp plusp) (declare (fixnum exp)) @@ -1220,60 +1220,60 @@ ;;; approximation. (defun bignum-to-float (bignum format) (let* ((plusp (bignum-plus-p bignum)) - (x (if plusp bignum (negate-bignum bignum))) - (len (bignum-integer-length x)) - (digits (float-format-digits format)) - (keep (+ digits digit-size)) - (shift (- keep len)) - (shifted (if (minusp shift) - (bignum-ashift-right x (- shift)) - (bignum-ashift-left x shift))) - (low (%bignum-ref shifted 0)) - (round-bit (ash 1 (1- digit-size)))) + (x (if plusp bignum (negate-bignum bignum))) + (len (bignum-integer-length x)) + (digits (float-format-digits format)) + (keep (+ digits digit-size)) + (shift (- keep len)) + (shifted (if (minusp shift) + (bignum-ashift-right x (- shift)) + (bignum-ashift-left x shift))) + (low (%bignum-ref shifted 0)) + (round-bit (ash 1 (1- digit-size)))) (declare (type bignum-index len digits keep) (fixnum shift)) (labels ((round-up () - (let ((rounded (add-bignums shifted round-bit))) - (if (> (integer-length rounded) keep) - (float-from-bits (bignum-ashift-right rounded 1) - (1+ len)) - (float-from-bits rounded len)))) - (float-from-bits (bits len) - (declare (type bignum-index len)) - (ecase format - (single-float - (single-float-from-bits - bits - (check-exponent len sb!vm:single-float-bias - sb!vm:single-float-normal-exponent-max) - plusp)) - (double-float - (double-float-from-bits - bits - (check-exponent len sb!vm:double-float-bias - sb!vm:double-float-normal-exponent-max) - plusp)) - #!+long-float - (long-float - (long-float-from-bits - bits - (check-exponent len sb!vm:long-float-bias - sb!vm:long-float-normal-exponent-max) - plusp)))) - (check-exponent (exp bias max) - (declare (type bignum-index len)) - (let ((exp (+ exp bias))) - (when (> exp max) - ;; Why a SIMPLE-TYPE-ERROR? Well, this is mainly - ;; called by COERCE, which requires an error of - ;; TYPE-ERROR if the conversion can't happen - ;; (except in certain circumstances when we are - ;; coercing to a FUNCTION) -- CSR, 2002-09-18 - (error 'simple-type-error - :format-control "Too large to be represented as a ~S:~% ~S" - :format-arguments (list format x) - :expected-type format - :datum x)) - exp))) + (let ((rounded (add-bignums shifted round-bit))) + (if (> (integer-length rounded) keep) + (float-from-bits (bignum-ashift-right rounded 1) + (1+ len)) + (float-from-bits rounded len)))) + (float-from-bits (bits len) + (declare (type bignum-index len)) + (ecase format + (single-float + (single-float-from-bits + bits + (check-exponent len sb!vm:single-float-bias + sb!vm:single-float-normal-exponent-max) + plusp)) + (double-float + (double-float-from-bits + bits + (check-exponent len sb!vm:double-float-bias + sb!vm:double-float-normal-exponent-max) + plusp)) + #!+long-float + (long-float + (long-float-from-bits + bits + (check-exponent len sb!vm:long-float-bias + sb!vm:long-float-normal-exponent-max) + plusp)))) + (check-exponent (exp bias max) + (declare (type bignum-index len)) + (let ((exp (+ exp bias))) + (when (> exp max) + ;; Why a SIMPLE-TYPE-ERROR? Well, this is mainly + ;; called by COERCE, which requires an error of + ;; TYPE-ERROR if the conversion can't happen + ;; (except in certain circumstances when we are + ;; coercing to a FUNCTION) -- CSR, 2002-09-18 + (error 'simple-type-error + :format-control "Too large to be represented as a ~S:~% ~S" + :format-arguments (list format x) + :expected-type format + :datum x)) + exp))) (cond ;; Round down if round bit is 0. @@ -1281,13 +1281,13 @@ (float-from-bits shifted len)) ;; If only round bit is set, then round to even. ((and (= low round-bit) - (dotimes (i (- (%bignum-length x) (ceiling keep digit-size)) - t) - (unless (zerop (%bignum-ref x i)) (return nil)))) + (dotimes (i (- (%bignum-length x) (ceiling keep digit-size)) + t) + (unless (zerop (%bignum-ref x i)) (return nil)))) (let ((next (%bignum-ref shifted 1))) - (if (oddp next) - (round-up) - (float-from-bits shifted len)))) + (if (oddp next) + (round-up) + (float-from-bits shifted len)))) ;; Otherwise, round up. (t (round-up)))))) @@ -1297,9 +1297,9 @@ (defun bignum-buffer-integer-length (bignum len) (declare (type bignum-type bignum)) (let* ((len-1 (1- len)) - (digit (%bignum-ref bignum len-1))) + (digit (%bignum-ref bignum len-1))) (declare (type bignum-index len len-1) - (type bignum-element-type digit)) + (type bignum-element-type digit)) (+ (integer-length (%fixnum-digit-with-correct-sign digit)) (* len-1 digit-size)))) @@ -1312,24 +1312,24 @@ (let ((len (%bignum-length bignum))) (declare (type bignum-index len)) (multiple-value-bind (word-index bit-index) - (floor index digit-size) + (floor index digit-size) (if (>= word-index len) - (not (bignum-plus-p bignum)) - (not (zerop (logand (%bignum-ref bignum word-index) - (ash 1 bit-index)))))))) + (not (bignum-plus-p bignum)) + (not (zerop (logand (%bignum-ref bignum word-index) + (ash 1 bit-index)))))))) (defun bignum-logcount (bignum) (declare (type bignum-type bignum)) (let* ((length (%bignum-length bignum)) - (plusp (%bignum-0-or-plusp bignum length)) - (result 0)) + (plusp (%bignum-0-or-plusp bignum length)) + (result 0)) (declare (type bignum-index length) - (fixnum result)) + (fixnum result)) (do ((index 0 (1+ index))) - ((= index length) result) + ((= index length) result) (let ((digit (%bignum-ref bignum index))) - (declare (type bignum-element-type digit)) - (incf result (logcount (if plusp digit (%lognot digit)))))))) + (declare (type bignum-element-type digit)) + (incf result (logcount (if plusp digit (%lognot digit)))))))) ;;;; logical operations @@ -1338,7 +1338,7 @@ (defun bignum-logical-not (a) (declare (type bignum-type a)) (let* ((len (%bignum-length a)) - (res (%allocate-bignum len))) + (res (%allocate-bignum len))) (declare (type bignum-index len)) (dotimes (i len res) (declare (type bignum-index i)) @@ -1349,19 +1349,19 @@ (defun bignum-logical-and (a b) (declare (type bignum-type a b)) (let* ((len-a (%bignum-length a)) - (len-b (%bignum-length b)) - (a-plusp (%bignum-0-or-plusp a len-a)) - (b-plusp (%bignum-0-or-plusp b len-b))) + (len-b (%bignum-length b)) + (a-plusp (%bignum-0-or-plusp a len-a)) + (b-plusp (%bignum-0-or-plusp b len-b))) (declare (type bignum-index len-a len-b)) (cond ((< len-a len-b) (if a-plusp - (logand-shorter-positive a len-a b (%allocate-bignum len-a)) - (logand-shorter-negative a len-a b len-b (%allocate-bignum len-b)))) + (logand-shorter-positive a len-a b (%allocate-bignum len-a)) + (logand-shorter-negative a len-a b len-b (%allocate-bignum len-b)))) ((< len-b len-a) (if b-plusp - (logand-shorter-positive b len-b a (%allocate-bignum len-b)) - (logand-shorter-negative b len-b a len-a (%allocate-bignum len-a)))) + (logand-shorter-positive b len-b a (%allocate-bignum len-b)) + (logand-shorter-negative b len-b a len-a (%allocate-bignum len-a)))) (t (logand-shorter-positive a len-a b (%allocate-bignum len-a)))))) ;;; This takes a shorter bignum, a and len-a, that is positive. Because this @@ -1369,11 +1369,11 @@ ;;; sign bits will mask the other bits out of b. The result is len-a big. (defun logand-shorter-positive (a len-a b res) (declare (type bignum-type a b res) - (type bignum-index len-a)) + (type bignum-index len-a)) (dotimes (i len-a) (declare (type bignum-index i)) (setf (%bignum-ref res i) - (%logand (%bignum-ref a i) (%bignum-ref b i)))) + (%logand (%bignum-ref a i) (%bignum-ref b i)))) (%normalize-bignum res len-a)) ;;; This takes a shorter bignum, a and len-a, that is negative. Because this @@ -1381,11 +1381,11 @@ ;;; bits will include any bits from b. The result is len-b big. (defun logand-shorter-negative (a len-a b len-b res) (declare (type bignum-type a b res) - (type bignum-index len-a len-b)) + (type bignum-index len-a len-b)) (dotimes (i len-a) (declare (type bignum-index i)) (setf (%bignum-ref res i) - (%logand (%bignum-ref a i) (%bignum-ref b i)))) + (%logand (%bignum-ref a i) (%bignum-ref b i)))) (do ((i len-a (1+ i))) ((= i len-b)) (declare (type bignum-index i)) @@ -1397,19 +1397,19 @@ (defun bignum-logical-ior (a b) (declare (type bignum-type a b)) (let* ((len-a (%bignum-length a)) - (len-b (%bignum-length b)) - (a-plusp (%bignum-0-or-plusp a len-a)) - (b-plusp (%bignum-0-or-plusp b len-b))) + (len-b (%bignum-length b)) + (a-plusp (%bignum-0-or-plusp a len-a)) + (b-plusp (%bignum-0-or-plusp b len-b))) (declare (type bignum-index len-a len-b)) (cond ((< len-a len-b) (if a-plusp - (logior-shorter-positive a len-a b len-b (%allocate-bignum len-b)) - (logior-shorter-negative a len-a b len-b (%allocate-bignum len-b)))) + (logior-shorter-positive a len-a b len-b (%allocate-bignum len-b)) + (logior-shorter-negative a len-a b len-b (%allocate-bignum len-b)))) ((< len-b len-a) (if b-plusp - (logior-shorter-positive b len-b a len-a (%allocate-bignum len-a)) - (logior-shorter-negative b len-b a len-a (%allocate-bignum len-a)))) + (logior-shorter-positive b len-b a len-a (%allocate-bignum len-a)) + (logior-shorter-negative b len-b a len-a (%allocate-bignum len-a)))) (t (logior-shorter-positive a len-a b len-b (%allocate-bignum len-a)))))) ;;; This takes a shorter bignum, a and len-a, that is positive. Because this @@ -1418,11 +1418,11 @@ ;;; is len-b long. (defun logior-shorter-positive (a len-a b len-b res) (declare (type bignum-type a b res) - (type bignum-index len-a len-b)) + (type bignum-index len-a len-b)) (dotimes (i len-a) (declare (type bignum-index i)) (setf (%bignum-ref res i) - (%logior (%bignum-ref a i) (%bignum-ref b i)))) + (%logior (%bignum-ref a i) (%bignum-ref b i)))) (do ((i len-a (1+ i))) ((= i len-b)) (declare (type bignum-index i)) @@ -1434,11 +1434,11 @@ ;;; bits will include any bits from b. The result is len-b long. (defun logior-shorter-negative (a len-a b len-b res) (declare (type bignum-type a b res) - (type bignum-index len-a len-b)) + (type bignum-index len-a len-b)) (dotimes (i len-a) (declare (type bignum-index i)) (setf (%bignum-ref res i) - (%logior (%bignum-ref a i) (%bignum-ref b i)))) + (%logior (%bignum-ref a i) (%bignum-ref b i)))) (do ((i len-a (1+ i)) (sign (%sign-digit a len-a))) ((= i len-b)) @@ -1451,21 +1451,21 @@ (defun bignum-logical-xor (a b) (declare (type bignum-type a b)) (let ((len-a (%bignum-length a)) - (len-b (%bignum-length b))) + (len-b (%bignum-length b))) (declare (type bignum-index len-a len-b)) (if (< len-a len-b) - (bignum-logical-xor-aux a len-a b len-b (%allocate-bignum len-b)) - (bignum-logical-xor-aux b len-b a len-a (%allocate-bignum len-a))))) + (bignum-logical-xor-aux a len-a b len-b (%allocate-bignum len-b)) + (bignum-logical-xor-aux b len-b a len-a (%allocate-bignum len-a))))) ;;; This takes the shorter of two bignums in a and len-a. Res is len-b ;;; long. Do the XOR. (defun bignum-logical-xor-aux (a len-a b len-b res) (declare (type bignum-type a b res) - (type bignum-index len-a len-b)) + (type bignum-index len-a len-b)) (dotimes (i len-a) (declare (type bignum-index i)) (setf (%bignum-ref res i) - (%logxor (%bignum-ref a i) (%bignum-ref b i)))) + (%logxor (%bignum-ref a i) (%bignum-ref b i)))) (do ((i len-a (1+ i)) (sign (%sign-digit a len-a))) ((= i len-b)) @@ -1484,10 +1484,10 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (defun bignum-load-byte (byte bignum) (declare (type bignum-type bignum)) (let ((byte-len (byte-size byte)) - (byte-pos (byte-position byte))) + (byte-pos (byte-position byte))) (if (< byte-len maximum-fixnum-bits) - (bignum-ldb-fixnum-res bignum byte-len byte-pos) - (bignum-ldb-bignum-res bignum byte-len byte-pos)))) + (bignum-ldb-fixnum-res bignum byte-len byte-pos) + (bignum-ldb-bignum-res bignum byte-len byte-pos)))) ;;; This returns a fixnum result of loading a byte from a bignum. In order, we ;;; check for the following conditions: @@ -1502,50 +1502,50 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! ;;; Make a couple masks, grab what we want, shift it around, and ;;; LOGIOR it all together. ;;; Because (< maximum-fixnum-bits digit-size) and -;;; (< byte-len maximum-fixnum-bits), +;;; (< byte-len maximum-fixnum-bits), ;;; we only cross one digit boundary if any. (defun bignum-ldb-fixnum-res (bignum byte-len byte-pos) (multiple-value-bind (skipped-digits pos) (truncate byte-pos digit-size) (let ((bignum-len (%bignum-length bignum)) - (s-digits+1 (1+ skipped-digits))) + (s-digits+1 (1+ skipped-digits))) (declare (type bignum-index bignum-len s-digits+1)) (if (>= skipped-digits bignum-len) - (if (%bignum-0-or-plusp bignum bignum-len) - 0 - (%make-ones byte-len)) - (let ((end (+ pos byte-len))) - (cond ((<= end digit-size) - (logand (ash (%bignum-ref bignum skipped-digits) (- pos)) - ;; Must LOGAND after shift here. - (%make-ones byte-len))) - ((>= s-digits+1 bignum-len) - (let* ((available-bits (- digit-size pos)) - (res (logand (ash (%bignum-ref bignum skipped-digits) - (- pos)) - ;; LOGAND should be unnecessary here - ;; with a logical right shift or a - ;; correct digit-sized one. - (%make-ones available-bits)))) - (if (%bignum-0-or-plusp bignum bignum-len) - res - (logior (%ashl (%make-ones (- end digit-size)) - available-bits) - res)))) - (t - (let* ((high-bits-in-first-digit (- digit-size pos)) - (high-mask (%make-ones high-bits-in-first-digit)) - (low-bits-in-next-digit (- end digit-size)) - (low-mask (%make-ones low-bits-in-next-digit))) - (declare (type bignum-element-type high-mask low-mask)) - (logior (%ashl (logand (%bignum-ref bignum s-digits+1) - low-mask) - high-bits-in-first-digit) - (logand (ash (%bignum-ref bignum skipped-digits) - (- pos)) - ;; LOGAND should be unnecessary here with - ;; a logical right shift or a correct - ;; digit-sized one. - high-mask)))))))))) + (if (%bignum-0-or-plusp bignum bignum-len) + 0 + (%make-ones byte-len)) + (let ((end (+ pos byte-len))) + (cond ((<= end digit-size) + (logand (ash (%bignum-ref bignum skipped-digits) (- pos)) + ;; Must LOGAND after shift here. + (%make-ones byte-len))) + ((>= s-digits+1 bignum-len) + (let* ((available-bits (- digit-size pos)) + (res (logand (ash (%bignum-ref bignum skipped-digits) + (- pos)) + ;; LOGAND should be unnecessary here + ;; with a logical right shift or a + ;; correct digit-sized one. + (%make-ones available-bits)))) + (if (%bignum-0-or-plusp bignum bignum-len) + res + (logior (%ashl (%make-ones (- end digit-size)) + available-bits) + res)))) + (t + (let* ((high-bits-in-first-digit (- digit-size pos)) + (high-mask (%make-ones high-bits-in-first-digit)) + (low-bits-in-next-digit (- end digit-size)) + (low-mask (%make-ones low-bits-in-next-digit))) + (declare (type bignum-element-type high-mask low-mask)) + (logior (%ashl (logand (%bignum-ref bignum s-digits+1) + low-mask) + high-bits-in-first-digit) + (logand (ash (%bignum-ref bignum skipped-digits) + (- pos)) + ;; LOGAND should be unnecessary here with + ;; a logical right shift or a correct + ;; digit-sized one. + high-mask)))))))))) ;;; This returns a bignum result of loading a byte from a bignum. In order, we ;;; check for the following conditions: @@ -1566,18 +1566,18 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (declare (type bignum-index bignum-len)) (cond ((>= skipped-digits bignum-len) - (make-bignum-virtual-ldb-bits bignum bignum-len byte-len)) + (make-bignum-virtual-ldb-bits bignum bignum-len byte-len)) ((zerop pos) - (make-aligned-ldb-bignum bignum bignum-len byte-len skipped-digits)) + (make-aligned-ldb-bignum bignum bignum-len byte-len skipped-digits)) ((< (+ pos byte-len) digit-size) - (let ((res (%allocate-bignum 1))) - (setf (%bignum-ref res 0) - (logand (%ashr (%bignum-ref bignum skipped-digits) pos) - (%make-ones byte-len))) - res)) + (let ((res (%allocate-bignum 1))) + (setf (%bignum-ref res 0) + (logand (%ashr (%bignum-ref bignum skipped-digits) pos) + (%make-ones byte-len))) + res)) (t - (make-unaligned-ldb-bignum bignum bignum-len - byte-len skipped-digits pos)))))) + (make-unaligned-ldb-bignum bignum bignum-len + byte-len skipped-digits pos)))))) ;;; This returns bits from bignum that don't physically exist. These are ;;; all zero or one depending on the sign of the bignum. @@ -1585,16 +1585,16 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (if (%bignum-0-or-plusp bignum bignum-len) 0 (multiple-value-bind (res-len-1 extra) (truncate byte-len digit-size) - (declare (type bignum-index res-len-1)) - (let* ((res-len (1+ res-len-1)) - (res (%allocate-bignum res-len))) - (declare (type bignum-index res-len)) - (do ((j 0 (1+ j))) - ((= j res-len-1) - (setf (%bignum-ref res j) (%make-ones extra)) - (%normalize-bignum res res-len)) - (declare (type bignum-index j)) - (setf (%bignum-ref res j) all-ones-digit)))))) + (declare (type bignum-index res-len-1)) + (let* ((res-len (1+ res-len-1)) + (res (%allocate-bignum res-len))) + (declare (type bignum-index res-len)) + (do ((j 0 (1+ j))) + ((= j res-len-1) + (setf (%bignum-ref res j) (%make-ones extra)) + (%normalize-bignum res res-len)) + (declare (type bignum-index j)) + (setf (%bignum-ref res j) all-ones-digit)))))) ;;; Since we are picking up aligned digits, we just copy the whole digits ;;; we want and fill in extra bits. We might have a byte-len that extends @@ -1604,22 +1604,22 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (multiple-value-bind (res-len-1 extra) (truncate byte-len digit-size) (declare (type bignum-index res-len-1)) (let* ((res-len (1+ res-len-1)) - (res (%allocate-bignum res-len))) + (res (%allocate-bignum res-len))) (declare (type bignum-index res-len)) (do ((i skipped-digits (1+ i)) - (j 0 (1+ j))) - ((or (= j res-len-1) (= i bignum-len)) - (cond ((< i bignum-len) - (setf (%bignum-ref res j) - (logand (%bignum-ref bignum i) - (the bignum-element-type (%make-ones extra))))) - ((%bignum-0-or-plusp bignum bignum-len)) - (t - (do ((j j (1+ j))) - ((= j res-len-1) - (setf (%bignum-ref res j) (%make-ones extra))) - (setf (%bignum-ref res j) all-ones-digit)))) - (%normalize-bignum res res-len)) + (j 0 (1+ j))) + ((or (= j res-len-1) (= i bignum-len)) + (cond ((< i bignum-len) + (setf (%bignum-ref res j) + (logand (%bignum-ref bignum i) + (the bignum-element-type (%make-ones extra))))) + ((%bignum-0-or-plusp bignum bignum-len)) + (t + (do ((j j (1+ j))) + ((= j res-len-1) + (setf (%bignum-ref res j) (%make-ones extra))) + (setf (%bignum-ref res j) all-ones-digit)))) + (%normalize-bignum res res-len)) (declare (type bignum-index i j)) (setf (%bignum-ref res j) (%bignum-ref bignum i)))))) @@ -1627,49 +1627,49 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! ;;; least one digit boundary crossing. We use SHIFT-RIGHT-UNALIGNED referencing ;;; lots of local variables established by it. (defun make-unaligned-ldb-bignum (bignum - bignum-len - byte-len - skipped-digits - pos) + bignum-len + byte-len + skipped-digits + pos) (multiple-value-bind (res-len-1 extra) (truncate byte-len digit-size) (shift-right-unaligned bignum skipped-digits pos (1+ res-len-1) ((or (= j res-len-1) (= i+1 bignum-len)) (cond ((= j res-len-1) - (cond - ((< extra high-bits-in-first-digit) - (setf (%bignum-ref res j) - (logand (ash (%bignum-ref bignum i) minus-start-pos) - ;; Must LOGAND after shift here. - (%make-ones extra)))) - (t - (setf (%bignum-ref res j) - (logand (ash (%bignum-ref bignum i) minus-start-pos) - ;; LOGAND should be unnecessary here with a logical - ;; right shift or a correct digit-sized one. - high-mask)) - (when (%bignum-0-or-plusp bignum bignum-len) - (setf (%bignum-ref res j) - (logior (%bignum-ref res j) - (%ashl (%make-ones - (- extra high-bits-in-first-digit)) - high-bits-in-first-digit))))))) - (t - (setf (%bignum-ref res j) - (logand (ash (%bignum-ref bignum i) minus-start-pos) - ;; LOGAND should be unnecessary here with a logical - ;; right shift or a correct digit-sized one. - high-mask)) - (unless (%bignum-0-or-plusp bignum bignum-len) - ;; Fill in upper half of this result digit with 1's. - (setf (%bignum-ref res j) - (logior (%bignum-ref res j) - (%ashl low-mask high-bits-in-first-digit))) - ;; Fill in any extra 1's we need to be byte-len long. - (do ((j (1+ j) (1+ j))) - ((>= j res-len-1) - (setf (%bignum-ref res j) (%make-ones extra))) - (setf (%bignum-ref res j) all-ones-digit))))) + (cond + ((< extra high-bits-in-first-digit) + (setf (%bignum-ref res j) + (logand (ash (%bignum-ref bignum i) minus-start-pos) + ;; Must LOGAND after shift here. + (%make-ones extra)))) + (t + (setf (%bignum-ref res j) + (logand (ash (%bignum-ref bignum i) minus-start-pos) + ;; LOGAND should be unnecessary here with a logical + ;; right shift or a correct digit-sized one. + high-mask)) + (when (%bignum-0-or-plusp bignum bignum-len) + (setf (%bignum-ref res j) + (logior (%bignum-ref res j) + (%ashl (%make-ones + (- extra high-bits-in-first-digit)) + high-bits-in-first-digit))))))) + (t + (setf (%bignum-ref res j) + (logand (ash (%bignum-ref bignum i) minus-start-pos) + ;; LOGAND should be unnecessary here with a logical + ;; right shift or a correct digit-sized one. + high-mask)) + (unless (%bignum-0-or-plusp bignum bignum-len) + ;; Fill in upper half of this result digit with 1's. + (setf (%bignum-ref res j) + (logior (%bignum-ref res j) + (%ashl low-mask high-bits-in-first-digit))) + ;; Fill in any extra 1's we need to be byte-len long. + (do ((j (1+ j) (1+ j))) + ((>= j res-len-1) + (setf (%bignum-ref res j) (%make-ones extra))) + (setf (%bignum-ref res j) all-ones-digit))))) (%normalize-bignum res res-len)) res))) @@ -1678,12 +1678,12 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (defun bignum-deposit-byte (new-byte byte-spec bignum) (declare (type bignum-type bignum)) (let* ((byte-len (byte-size byte-spec)) - (byte-pos (byte-position byte-spec)) - (bignum-len (%bignum-length bignum)) - (bignum-plusp (%bignum-0-or-plusp bignum bignum-len)) - (byte-end (+ byte-pos byte-len)) - (res-len (1+ (max (ceiling byte-end digit-size) bignum-len))) - (res (%allocate-bignum res-len))) + (byte-pos (byte-position byte-spec)) + (bignum-len (%bignum-length bignum)) + (bignum-plusp (%bignum-0-or-plusp bignum bignum-len)) + (byte-end (+ byte-pos byte-len)) + (res-len (1+ (max (ceiling byte-end digit-size) bignum-len))) + (res (%allocate-bignum res-len))) (declare (type bignum-index bignum-len res-len)) ;; Fill in an extra sign digit in case we set what would otherwise be the ;; last digit's last bit. Normalize at the end in case this was @@ -1694,42 +1694,42 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (declare (type bignum-index end-digit)) ;; Fill in bits from bignum up to byte-pos. (multiple-value-bind (pos-digit pos-bits) (truncate byte-pos digit-size) - (declare (type bignum-index pos-digit)) - (do ((i 0 (1+ i)) - (end (min pos-digit bignum-len))) - ((= i end) - (cond ((< i bignum-len) - (unless (zerop pos-bits) - (setf (%bignum-ref res i) - (logand (%bignum-ref bignum i) - (%make-ones pos-bits))))) - (bignum-plusp) - (t - (do ((i i (1+ i))) - ((= i pos-digit) - (unless (zerop pos-bits) - (setf (%bignum-ref res i) (%make-ones pos-bits)))) - (setf (%bignum-ref res i) all-ones-digit))))) - (setf (%bignum-ref res i) (%bignum-ref bignum i))) - ;; Fill in bits from new-byte. - (if (typep new-byte 'fixnum) - (deposit-fixnum-bits new-byte byte-len pos-digit pos-bits - end-digit end-bits res) - (deposit-bignum-bits new-byte byte-len pos-digit pos-bits - end-digit end-bits res))) + (declare (type bignum-index pos-digit)) + (do ((i 0 (1+ i)) + (end (min pos-digit bignum-len))) + ((= i end) + (cond ((< i bignum-len) + (unless (zerop pos-bits) + (setf (%bignum-ref res i) + (logand (%bignum-ref bignum i) + (%make-ones pos-bits))))) + (bignum-plusp) + (t + (do ((i i (1+ i))) + ((= i pos-digit) + (unless (zerop pos-bits) + (setf (%bignum-ref res i) (%make-ones pos-bits)))) + (setf (%bignum-ref res i) all-ones-digit))))) + (setf (%bignum-ref res i) (%bignum-ref bignum i))) + ;; Fill in bits from new-byte. + (if (typep new-byte 'fixnum) + (deposit-fixnum-bits new-byte byte-len pos-digit pos-bits + end-digit end-bits res) + (deposit-bignum-bits new-byte byte-len pos-digit pos-bits + end-digit end-bits res))) ;; Fill in remaining bits from bignum after byte-spec. (when (< end-digit bignum-len) - (setf (%bignum-ref res end-digit) - (logior (logand (%bignum-ref bignum end-digit) - (%ashl (%make-ones (- digit-size end-bits)) - end-bits)) - ;; DEPOSIT-FIXNUM-BITS and DEPOSIT-BIGNUM-BITS only store - ;; bits from new-byte into res's end-digit element, so - ;; we don't need to mask out unwanted high bits. - (%bignum-ref res end-digit))) - (do ((i (1+ end-digit) (1+ i))) - ((= i bignum-len)) - (setf (%bignum-ref res i) (%bignum-ref bignum i))))) + (setf (%bignum-ref res end-digit) + (logior (logand (%bignum-ref bignum end-digit) + (%ashl (%make-ones (- digit-size end-bits)) + end-bits)) + ;; DEPOSIT-FIXNUM-BITS and DEPOSIT-BIGNUM-BITS only store + ;; bits from new-byte into res's end-digit element, so + ;; we don't need to mask out unwanted high bits. + (%bignum-ref res end-digit))) + (do ((i (1+ end-digit) (1+ i))) + ((= i bignum-len)) + (setf (%bignum-ref res i) (%bignum-ref bignum i))))) (%normalize-bignum res res-len))) ;;; This starts at result's pos-digit skipping pos-bits, and it stores bits @@ -1748,40 +1748,40 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! ;;; in as ones. We call DEPOSIT-FIXNUM-DIGIT to grab what bits actually exist ;;; and to fill in the current result digit. (defun deposit-fixnum-bits (new-byte byte-len pos-digit pos-bits - end-digit end-bits result) + end-digit end-bits result) (declare (type bignum-index pos-digit end-digit)) (let ((other-bits (- digit-size pos-bits)) - (new-byte-digit (%fixnum-to-digit new-byte))) + (new-byte-digit (%fixnum-to-digit new-byte))) (declare (type bignum-element-type new-byte-digit)) (cond ((< byte-len maximum-fixnum-bits) - (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits - other-bits result - (- byte-len other-bits))) - ((or (plusp new-byte) (zerop new-byte)) - (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits - other-bits result pos-bits)) - (t - (multiple-value-bind (digit bits) - (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits - other-bits result - (if (< (- byte-len other-bits) digit-size) - (- byte-len other-bits) - digit-size)) - (declare (type bignum-index digit)) - (cond ((< digit end-digit) - (setf (%bignum-ref result digit) - (logior (%bignum-ref result digit) - (%ashl (%make-ones (- digit-size bits)) bits))) - (do ((i (1+ digit) (1+ i))) - ((= i end-digit) - (setf (%bignum-ref result i) (%make-ones end-bits))) - (setf (%bignum-ref result i) all-ones-digit))) - ((> digit end-digit)) - ((< bits end-bits) - (setf (%bignum-ref result digit) - (logior (%bignum-ref result digit) - (%ashl (%make-ones (- end-bits bits)) - bits)))))))))) + (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits + other-bits result + (- byte-len other-bits))) + ((or (plusp new-byte) (zerop new-byte)) + (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits + other-bits result pos-bits)) + (t + (multiple-value-bind (digit bits) + (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits + other-bits result + (if (< (- byte-len other-bits) digit-size) + (- byte-len other-bits) + digit-size)) + (declare (type bignum-index digit)) + (cond ((< digit end-digit) + (setf (%bignum-ref result digit) + (logior (%bignum-ref result digit) + (%ashl (%make-ones (- digit-size bits)) bits))) + (do ((i (1+ digit) (1+ i))) + ((= i end-digit) + (setf (%bignum-ref result i) (%make-ones end-bits))) + (setf (%bignum-ref result i) all-ones-digit))) + ((> digit end-digit)) + ((< bits end-bits) + (setf (%bignum-ref result digit) + (logior (%bignum-ref result digit) + (%ashl (%make-ones (- end-bits bits)) + bits)))))))))) ;;; This fills in the current result digit from new-byte-digit. The first case ;;; handles everything we want fitting in the current digit, and other-bits is @@ -1792,33 +1792,33 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! ;;; sign. It returns the new current result digit and how many bits already ;;; filled in the result digit. (defun deposit-fixnum-digit (new-byte-digit byte-len pos-digit pos-bits - other-bits result next-digit-bits-needed) + other-bits result next-digit-bits-needed) (declare (type bignum-index pos-digit) - (type bignum-element-type new-byte-digit next-digit-mask)) + (type bignum-element-type new-byte-digit next-digit-mask)) (cond ((<= byte-len other-bits) - ;; Bits from new-byte fit in the current result digit. - (setf (%bignum-ref result pos-digit) - (logior (%bignum-ref result pos-digit) - (%ashl (logand new-byte-digit (%make-ones byte-len)) - pos-bits))) - (if (= byte-len other-bits) - (values (1+ pos-digit) 0) - (values pos-digit (+ byte-len pos-bits)))) - (t - ;; Some of new-byte's bits go in current result digit. - (setf (%bignum-ref result pos-digit) - (logior (%bignum-ref result pos-digit) - (%ashl (logand new-byte-digit (%make-ones other-bits)) - pos-bits))) - (let ((pos-digit+1 (1+ pos-digit))) - ;; The rest of new-byte's bits go in the next result digit. - (setf (%bignum-ref result pos-digit+1) - (logand (ash new-byte-digit (- other-bits)) - ;; Must LOGAND after shift here. - (%make-ones next-digit-bits-needed))) - (if (= next-digit-bits-needed digit-size) - (values (1+ pos-digit+1) 0) - (values pos-digit+1 next-digit-bits-needed)))))) + ;; Bits from new-byte fit in the current result digit. + (setf (%bignum-ref result pos-digit) + (logior (%bignum-ref result pos-digit) + (%ashl (logand new-byte-digit (%make-ones byte-len)) + pos-bits))) + (if (= byte-len other-bits) + (values (1+ pos-digit) 0) + (values pos-digit (+ byte-len pos-bits)))) + (t + ;; Some of new-byte's bits go in current result digit. + (setf (%bignum-ref result pos-digit) + (logior (%bignum-ref result pos-digit) + (%ashl (logand new-byte-digit (%make-ones other-bits)) + pos-bits))) + (let ((pos-digit+1 (1+ pos-digit))) + ;; The rest of new-byte's bits go in the next result digit. + (setf (%bignum-ref result pos-digit+1) + (logand (ash new-byte-digit (- other-bits)) + ;; Must LOGAND after shift here. + (%make-ones next-digit-bits-needed))) + (if (= next-digit-bits-needed digit-size) + (values (1+ pos-digit+1) 0) + (values pos-digit+1 next-digit-bits-needed)))))) ;;; This starts at result's pos-digit skipping pos-bits, and it stores bits ;;; from new-byte, a bignum, into result. It effectively stores byte-len @@ -1828,107 +1828,107 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! ;;; after after pos-bits; DEPOSIT-UNALIGNED-BIGNUM-BITS expects at least one ;;; digit boundary crossing. (defun deposit-bignum-bits (bignum-byte byte-len pos-digit pos-bits - end-digit end-bits result) + end-digit end-bits result) (declare (type bignum-index pos-digit end-digit)) (cond ((zerop pos-bits) - (deposit-aligned-bignum-bits bignum-byte pos-digit end-digit end-bits - result)) - ((or (= end-digit pos-digit) - (and (= end-digit (1+ pos-digit)) - (zerop end-bits))) - (setf (%bignum-ref result pos-digit) - (logior (%bignum-ref result pos-digit) - (%ashl (logand (%bignum-ref bignum-byte 0) - (%make-ones byte-len)) - pos-bits)))) - (t (deposit-unaligned-bignum-bits bignum-byte pos-digit pos-bits - end-digit end-bits result)))) + (deposit-aligned-bignum-bits bignum-byte pos-digit end-digit end-bits + result)) + ((or (= end-digit pos-digit) + (and (= end-digit (1+ pos-digit)) + (zerop end-bits))) + (setf (%bignum-ref result pos-digit) + (logior (%bignum-ref result pos-digit) + (%ashl (logand (%bignum-ref bignum-byte 0) + (%make-ones byte-len)) + pos-bits)))) + (t (deposit-unaligned-bignum-bits bignum-byte pos-digit pos-bits + end-digit end-bits result)))) ;;; This deposits bits from bignum-byte into result starting at pos-digit and ;;; the zero'th bit. It effectively only stores bits to end-bits in the ;;; end-digit element of result. The loop termination code takes care of ;;; picking up the last digit's bits or filling in virtual negative sign bits. (defun deposit-aligned-bignum-bits (bignum-byte pos-digit end-digit end-bits - result) + result) (declare (type bignum-index pos-digit end-digit)) (let* ((bignum-len (%bignum-length bignum-byte)) - (bignum-plusp (%bignum-0-or-plusp bignum-byte bignum-len))) + (bignum-plusp (%bignum-0-or-plusp bignum-byte bignum-len))) (declare (type bignum-index bignum-len)) (do ((i 0 (1+ i )) - (j pos-digit (1+ j))) - ((or (= j end-digit) (= i bignum-len)) - (cond ((= j end-digit) - (cond ((< i bignum-len) - (setf (%bignum-ref result j) - (logand (%bignum-ref bignum-byte i) - (%make-ones end-bits)))) - (bignum-plusp) - (t - (setf (%bignum-ref result j) (%make-ones end-bits))))) - (bignum-plusp) - (t - (do ((j j (1+ j))) - ((= j end-digit) - (setf (%bignum-ref result j) (%make-ones end-bits))) - (setf (%bignum-ref result j) all-ones-digit))))) + (j pos-digit (1+ j))) + ((or (= j end-digit) (= i bignum-len)) + (cond ((= j end-digit) + (cond ((< i bignum-len) + (setf (%bignum-ref result j) + (logand (%bignum-ref bignum-byte i) + (%make-ones end-bits)))) + (bignum-plusp) + (t + (setf (%bignum-ref result j) (%make-ones end-bits))))) + (bignum-plusp) + (t + (do ((j j (1+ j))) + ((= j end-digit) + (setf (%bignum-ref result j) (%make-ones end-bits))) + (setf (%bignum-ref result j) all-ones-digit))))) (setf (%bignum-ref result j) (%bignum-ref bignum-byte i))))) ;;; This assumes at least one digit crossing. (defun deposit-unaligned-bignum-bits (bignum-byte pos-digit pos-bits - end-digit end-bits result) + end-digit end-bits result) (declare (type bignum-index pos-digit end-digit)) (let* ((bignum-len (%bignum-length bignum-byte)) - (bignum-plusp (%bignum-0-or-plusp bignum-byte bignum-len)) - (low-mask (%make-ones pos-bits)) - (bits-past-pos-bits (- digit-size pos-bits)) - (high-mask (%make-ones bits-past-pos-bits)) - (minus-high-bits (- bits-past-pos-bits))) + (bignum-plusp (%bignum-0-or-plusp bignum-byte bignum-len)) + (low-mask (%make-ones pos-bits)) + (bits-past-pos-bits (- digit-size pos-bits)) + (high-mask (%make-ones bits-past-pos-bits)) + (minus-high-bits (- bits-past-pos-bits))) (declare (type bignum-element-type low-mask high-mask) - (type bignum-index bignum-len)) + (type bignum-index bignum-len)) (do ((i 0 (1+ i)) - (j pos-digit j+1) - (j+1 (1+ pos-digit) (1+ j+1))) - ((or (= j end-digit) (= i bignum-len)) - (cond - ((= j end-digit) - (setf (%bignum-ref result j) - (cond - ((>= pos-bits end-bits) - (logand (%bignum-ref result j) (%make-ones end-bits))) - ((< i bignum-len) - (logior (%bignum-ref result j) - (%ashl (logand (%bignum-ref bignum-byte i) - (%make-ones (- end-bits pos-bits))) - pos-bits))) - (bignum-plusp - (logand (%bignum-ref result j) - ;; 0's between pos-bits and end-bits positions. - (logior (%ashl (%make-ones (- digit-size end-bits)) - end-bits) - low-mask))) - (t (logior (%bignum-ref result j) - (%ashl (%make-ones (- end-bits pos-bits)) - pos-bits)))))) - (bignum-plusp) - (t - (setf (%bignum-ref result j) - (%ashl (%make-ones bits-past-pos-bits) pos-bits)) - (do ((j j+1 (1+ j))) - ((= j end-digit) - (setf (%bignum-ref result j) (%make-ones end-bits))) - (declare (type bignum-index j)) - (setf (%bignum-ref result j) all-ones-digit))))) + (j pos-digit j+1) + (j+1 (1+ pos-digit) (1+ j+1))) + ((or (= j end-digit) (= i bignum-len)) + (cond + ((= j end-digit) + (setf (%bignum-ref result j) + (cond + ((>= pos-bits end-bits) + (logand (%bignum-ref result j) (%make-ones end-bits))) + ((< i bignum-len) + (logior (%bignum-ref result j) + (%ashl (logand (%bignum-ref bignum-byte i) + (%make-ones (- end-bits pos-bits))) + pos-bits))) + (bignum-plusp + (logand (%bignum-ref result j) + ;; 0's between pos-bits and end-bits positions. + (logior (%ashl (%make-ones (- digit-size end-bits)) + end-bits) + low-mask))) + (t (logior (%bignum-ref result j) + (%ashl (%make-ones (- end-bits pos-bits)) + pos-bits)))))) + (bignum-plusp) + (t + (setf (%bignum-ref result j) + (%ashl (%make-ones bits-past-pos-bits) pos-bits)) + (do ((j j+1 (1+ j))) + ((= j end-digit) + (setf (%bignum-ref result j) (%make-ones end-bits))) + (declare (type bignum-index j)) + (setf (%bignum-ref result j) all-ones-digit))))) (declare (type bignum-index i j j+1)) (let ((digit (%bignum-ref bignum-byte i))) - (declare (type bignum-element-type digit)) - (setf (%bignum-ref result j) - (logior (%bignum-ref result j) - (%ashl (logand digit high-mask) pos-bits))) - (setf (%bignum-ref result j+1) - (logand (ash digit minus-high-bits) - ;; LOGAND should be unnecessary here with a logical right - ;; shift or a correct digit-sized one. - low-mask)))))) + (declare (type bignum-element-type digit)) + (setf (%bignum-ref result j) + (logior (%bignum-ref result j) + (%ashl (logand digit high-mask) pos-bits))) + (setf (%bignum-ref result j+1) + (logand (ash digit minus-high-bits) + ;; LOGAND should be unnecessary here with a logical right + ;; shift or a correct digit-sized one. + low-mask)))))) |# ;;;; TRUNCATE @@ -2017,228 +2017,228 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (defun bignum-truncate (x y) (declare (type bignum-type x y)) (let (truncate-x truncate-y) - (labels + (labels ;;; Divide X by Y when Y is a single bignum digit. BIGNUM-TRUNCATE ;;; fixes up the quotient and remainder with respect to sign and ;;; normalization. - ;;; - ;;; We don't have to worry about shifting Y to make its most - ;;; significant digit sufficiently large for %FLOOR to return - ;;; digit-size quantities for the q-digit and r-digit. If Y is - ;;; a single digit bignum, it is already large enough for - ;;; %FLOOR. That is, it has some bits on pretty high in the - ;;; digit. - ((bignum-truncate-single-digit (x len-x y) - (declare (type bignum-index len-x)) - (let ((q (%allocate-bignum len-x)) - (r 0) - (y (%bignum-ref y 0))) - (declare (type bignum-element-type r y)) - (do ((i (1- len-x) (1- i))) - ((minusp i)) - (multiple-value-bind (q-digit r-digit) - (%floor r (%bignum-ref x i) y) - (declare (type bignum-element-type q-digit r-digit)) - (setf (%bignum-ref q i) q-digit) - (setf r r-digit))) - (let ((rem (%allocate-bignum 1))) - (setf (%bignum-ref rem 0) r) - (values q rem)))) - ;;; This returns a guess for the next division step. Y1 is the - ;;; highest y digit, and y2 is the second to highest y - ;;; digit. The x... variables are the three highest x digits - ;;; for the next division step. - ;;; - ;;; From Knuth, our guess is either all ones or x-i and x-i-1 - ;;; divided by y1, depending on whether x-i and y1 are the - ;;; same. We test this guess by determining whether guess*y2 - ;;; is greater than the three high digits of x minus guess*y1 - ;;; shifted left one digit: - ;;; ------------------------------ - ;;; | x-i | x-i-1 | x-i-2 | - ;;; ------------------------------ - ;;; ------------------------------ - ;;; - | g*y1 high | g*y1 low | 0 | - ;;; ------------------------------ - ;;; ... < guess*y2 ??? - ;;; If guess*y2 is greater, then we decrement our guess by one - ;;; and try again. This returns a guess that is either - ;;; correct or one too large. - (bignum-truncate-guess (y1 y2 x-i x-i-1 x-i-2) - (declare (type bignum-element-type y1 y2 x-i x-i-1 x-i-2)) - (let ((guess (if (%digit-compare x-i y1) - all-ones-digit - (%floor x-i x-i-1 y1)))) - (declare (type bignum-element-type guess)) - (loop - (multiple-value-bind (high-guess*y1 low-guess*y1) - (%multiply guess y1) - (declare (type bignum-element-type low-guess*y1 - high-guess*y1)) - (multiple-value-bind (high-guess*y2 low-guess*y2) - (%multiply guess y2) - (declare (type bignum-element-type high-guess*y2 - low-guess*y2)) - (multiple-value-bind (middle-digit borrow) - (%subtract-with-borrow x-i-1 low-guess*y1 1) - (declare (type bignum-element-type middle-digit) - (fixnum borrow)) - ;; Supplying borrow of 1 means there was no - ;; borrow, and we know x-i-2 minus 0 requires - ;; no borrow. - (let ((high-digit (%subtract-with-borrow x-i - high-guess*y1 - borrow))) - (declare (type bignum-element-type high-digit)) - (if (and (%digit-compare high-digit 0) - (or (%digit-greater high-guess*y2 - middle-digit) - (and (%digit-compare middle-digit - high-guess*y2) - (%digit-greater low-guess*y2 - x-i-2)))) - (setf guess (%subtract-with-borrow guess 1 1)) - (return guess))))))))) - ;;; Divide TRUNCATE-X by TRUNCATE-Y, returning the quotient - ;;; and destructively modifying TRUNCATE-X so that it holds - ;;; the remainder. - ;;; - ;;; LEN-X and LEN-Y tell us how much of the buffers we care about. - ;;; - ;;; TRUNCATE-X definitely has at least three digits, and it has one - ;;; more than TRUNCATE-Y. This keeps i, i-1, i-2, and low-x-digit - ;;; happy. Thanks to SHIFT-AND-STORE-TRUNCATE-BUFFERS. - (return-quotient-leaving-remainder (len-x len-y) - (declare (type bignum-index len-x len-y)) - (let* ((len-q (- len-x len-y)) - ;; Add one for extra sign digit in case high bit is on. - (q (%allocate-bignum (1+ len-q))) - (k (1- len-q)) - (y1 (%bignum-ref truncate-y (1- len-y))) - (y2 (%bignum-ref truncate-y (- len-y 2))) - (i (1- len-x)) - (i-1 (1- i)) - (i-2 (1- i-1)) - (low-x-digit (- i len-y))) - (declare (type bignum-index len-q k i i-1 i-2 low-x-digit) - (type bignum-element-type y1 y2)) - (loop - (setf (%bignum-ref q k) - (try-bignum-truncate-guess - ;; This modifies TRUNCATE-X. Must access - ;; elements each pass. - (bignum-truncate-guess y1 y2 - (%bignum-ref truncate-x i) - (%bignum-ref truncate-x i-1) - (%bignum-ref truncate-x i-2)) - len-y low-x-digit)) - (cond ((zerop k) (return)) - (t (decf k) - (decf low-x-digit) - (shiftf i i-1 i-2 (1- i-2))))) - q)) - ;;; This takes a digit guess, multiplies it by TRUNCATE-Y for a - ;;; result one greater in length than LEN-Y, and subtracts this result - ;;; from TRUNCATE-X. LOW-X-DIGIT is the first digit of X to start - ;;; the subtraction, and we know X is long enough to subtract a LEN-Y - ;;; plus one length bignum from it. Next we check the result of the - ;;; subtraction, and if the high digit in X became negative, then our - ;;; guess was one too big. In this case, return one less than GUESS - ;;; passed in, and add one value of Y back into X to account for - ;;; subtracting one too many. Knuth shows that the guess is wrong on - ;;; the order of 3/b, where b is the base (2 to the digit-size power) - ;;; -- pretty rarely. - (try-bignum-truncate-guess (guess len-y low-x-digit) - (declare (type bignum-index low-x-digit len-y) - (type bignum-element-type guess)) - (let ((carry-digit 0) - (borrow 1) - (i low-x-digit)) - (declare (type bignum-element-type carry-digit) - (type bignum-index i) - (fixnum borrow)) - ;; Multiply guess and divisor, subtracting from dividend - ;; simultaneously. - (dotimes (j len-y) - (multiple-value-bind (high-digit low-digit) - (%multiply-and-add guess - (%bignum-ref truncate-y j) - carry-digit) - (declare (type bignum-element-type high-digit low-digit)) - (setf carry-digit high-digit) - (multiple-value-bind (x temp-borrow) - (%subtract-with-borrow (%bignum-ref truncate-x i) - low-digit - borrow) - (declare (type bignum-element-type x) - (fixnum temp-borrow)) - (setf (%bignum-ref truncate-x i) x) - (setf borrow temp-borrow))) - (incf i)) - (setf (%bignum-ref truncate-x i) - (%subtract-with-borrow (%bignum-ref truncate-x i) - carry-digit borrow)) - ;; See whether guess is off by one, adding one - ;; Y back in if necessary. - (cond ((%digit-0-or-plusp (%bignum-ref truncate-x i)) - guess) - (t - ;; If subtraction has negative result, add one - ;; divisor value back in. The guess was one too - ;; large in magnitude. - (let ((i low-x-digit) - (carry 0)) - (dotimes (j len-y) - (multiple-value-bind (v k) - (%add-with-carry (%bignum-ref truncate-y j) - (%bignum-ref truncate-x i) - carry) - (declare (type bignum-element-type v)) - (setf (%bignum-ref truncate-x i) v) - (setf carry k)) - (incf i)) - (setf (%bignum-ref truncate-x i) - (%add-with-carry (%bignum-ref truncate-x i) - 0 carry))) - (%subtract-with-borrow guess 1 1))))) - ;;; This returns the amount to shift y to place a one in the - ;;; second highest bit. Y must be positive. If the last digit - ;;; of y is zero, then y has a one in the previous digit's - ;;; sign bit, so we know it will take one less than digit-size - ;;; to get a one where we want. Otherwise, we count how many - ;;; right shifts it takes to get zero; subtracting this value - ;;; from digit-size tells us how many high zeros there are - ;;; which is one more than the shift amount sought. - ;;; - ;;; Note: This is exactly the same as one less than the - ;;; integer-length of the last digit subtracted from the - ;;; digit-size. - ;;; - ;;; We shift y to make it sufficiently large that doing the - ;;; 2*digit-size by digit-size %FLOOR calls ensures the quotient and - ;;; remainder fit in digit-size. - (shift-y-for-truncate (y) - (let* ((len (%bignum-length y)) - (last (%bignum-ref y (1- len)))) - (declare (type bignum-index len) - (type bignum-element-type last)) - (- digit-size (integer-length last) 1))) - ;;; Stores two bignums into the truncation bignum buffers, - ;;; shifting them on the way in. This assumes x and y are - ;;; positive and at least two in length, and it assumes - ;;; truncate-x and truncate-y are one digit longer than x and - ;;; y. - (shift-and-store-truncate-buffers (x len-x y len-y shift) - (declare (type bignum-index len-x len-y) - (type (integer 0 (#.digit-size)) shift)) - (cond ((zerop shift) - (bignum-replace truncate-x x :end1 len-x) - (bignum-replace truncate-y y :end1 len-y)) - (t - (bignum-ashift-left-unaligned x 0 shift (1+ len-x) - truncate-x) - (bignum-ashift-left-unaligned y 0 shift (1+ len-y) - truncate-y))))) ;; LABELS + ;;; + ;;; We don't have to worry about shifting Y to make its most + ;;; significant digit sufficiently large for %FLOOR to return + ;;; digit-size quantities for the q-digit and r-digit. If Y is + ;;; a single digit bignum, it is already large enough for + ;;; %FLOOR. That is, it has some bits on pretty high in the + ;;; digit. + ((bignum-truncate-single-digit (x len-x y) + (declare (type bignum-index len-x)) + (let ((q (%allocate-bignum len-x)) + (r 0) + (y (%bignum-ref y 0))) + (declare (type bignum-element-type r y)) + (do ((i (1- len-x) (1- i))) + ((minusp i)) + (multiple-value-bind (q-digit r-digit) + (%floor r (%bignum-ref x i) y) + (declare (type bignum-element-type q-digit r-digit)) + (setf (%bignum-ref q i) q-digit) + (setf r r-digit))) + (let ((rem (%allocate-bignum 1))) + (setf (%bignum-ref rem 0) r) + (values q rem)))) + ;;; This returns a guess for the next division step. Y1 is the + ;;; highest y digit, and y2 is the second to highest y + ;;; digit. The x... variables are the three highest x digits + ;;; for the next division step. + ;;; + ;;; From Knuth, our guess is either all ones or x-i and x-i-1 + ;;; divided by y1, depending on whether x-i and y1 are the + ;;; same. We test this guess by determining whether guess*y2 + ;;; is greater than the three high digits of x minus guess*y1 + ;;; shifted left one digit: + ;;; ------------------------------ + ;;; | x-i | x-i-1 | x-i-2 | + ;;; ------------------------------ + ;;; ------------------------------ + ;;; - | g*y1 high | g*y1 low | 0 | + ;;; ------------------------------ + ;;; ... < guess*y2 ??? + ;;; If guess*y2 is greater, then we decrement our guess by one + ;;; and try again. This returns a guess that is either + ;;; correct or one too large. + (bignum-truncate-guess (y1 y2 x-i x-i-1 x-i-2) + (declare (type bignum-element-type y1 y2 x-i x-i-1 x-i-2)) + (let ((guess (if (%digit-compare x-i y1) + all-ones-digit + (%floor x-i x-i-1 y1)))) + (declare (type bignum-element-type guess)) + (loop + (multiple-value-bind (high-guess*y1 low-guess*y1) + (%multiply guess y1) + (declare (type bignum-element-type low-guess*y1 + high-guess*y1)) + (multiple-value-bind (high-guess*y2 low-guess*y2) + (%multiply guess y2) + (declare (type bignum-element-type high-guess*y2 + low-guess*y2)) + (multiple-value-bind (middle-digit borrow) + (%subtract-with-borrow x-i-1 low-guess*y1 1) + (declare (type bignum-element-type middle-digit) + (fixnum borrow)) + ;; Supplying borrow of 1 means there was no + ;; borrow, and we know x-i-2 minus 0 requires + ;; no borrow. + (let ((high-digit (%subtract-with-borrow x-i + high-guess*y1 + borrow))) + (declare (type bignum-element-type high-digit)) + (if (and (%digit-compare high-digit 0) + (or (%digit-greater high-guess*y2 + middle-digit) + (and (%digit-compare middle-digit + high-guess*y2) + (%digit-greater low-guess*y2 + x-i-2)))) + (setf guess (%subtract-with-borrow guess 1 1)) + (return guess))))))))) + ;;; Divide TRUNCATE-X by TRUNCATE-Y, returning the quotient + ;;; and destructively modifying TRUNCATE-X so that it holds + ;;; the remainder. + ;;; + ;;; LEN-X and LEN-Y tell us how much of the buffers we care about. + ;;; + ;;; TRUNCATE-X definitely has at least three digits, and it has one + ;;; more than TRUNCATE-Y. This keeps i, i-1, i-2, and low-x-digit + ;;; happy. Thanks to SHIFT-AND-STORE-TRUNCATE-BUFFERS. + (return-quotient-leaving-remainder (len-x len-y) + (declare (type bignum-index len-x len-y)) + (let* ((len-q (- len-x len-y)) + ;; Add one for extra sign digit in case high bit is on. + (q (%allocate-bignum (1+ len-q))) + (k (1- len-q)) + (y1 (%bignum-ref truncate-y (1- len-y))) + (y2 (%bignum-ref truncate-y (- len-y 2))) + (i (1- len-x)) + (i-1 (1- i)) + (i-2 (1- i-1)) + (low-x-digit (- i len-y))) + (declare (type bignum-index len-q k i i-1 i-2 low-x-digit) + (type bignum-element-type y1 y2)) + (loop + (setf (%bignum-ref q k) + (try-bignum-truncate-guess + ;; This modifies TRUNCATE-X. Must access + ;; elements each pass. + (bignum-truncate-guess y1 y2 + (%bignum-ref truncate-x i) + (%bignum-ref truncate-x i-1) + (%bignum-ref truncate-x i-2)) + len-y low-x-digit)) + (cond ((zerop k) (return)) + (t (decf k) + (decf low-x-digit) + (shiftf i i-1 i-2 (1- i-2))))) + q)) + ;;; This takes a digit guess, multiplies it by TRUNCATE-Y for a + ;;; result one greater in length than LEN-Y, and subtracts this result + ;;; from TRUNCATE-X. LOW-X-DIGIT is the first digit of X to start + ;;; the subtraction, and we know X is long enough to subtract a LEN-Y + ;;; plus one length bignum from it. Next we check the result of the + ;;; subtraction, and if the high digit in X became negative, then our + ;;; guess was one too big. In this case, return one less than GUESS + ;;; passed in, and add one value of Y back into X to account for + ;;; subtracting one too many. Knuth shows that the guess is wrong on + ;;; the order of 3/b, where b is the base (2 to the digit-size power) + ;;; -- pretty rarely. + (try-bignum-truncate-guess (guess len-y low-x-digit) + (declare (type bignum-index low-x-digit len-y) + (type bignum-element-type guess)) + (let ((carry-digit 0) + (borrow 1) + (i low-x-digit)) + (declare (type bignum-element-type carry-digit) + (type bignum-index i) + (fixnum borrow)) + ;; Multiply guess and divisor, subtracting from dividend + ;; simultaneously. + (dotimes (j len-y) + (multiple-value-bind (high-digit low-digit) + (%multiply-and-add guess + (%bignum-ref truncate-y j) + carry-digit) + (declare (type bignum-element-type high-digit low-digit)) + (setf carry-digit high-digit) + (multiple-value-bind (x temp-borrow) + (%subtract-with-borrow (%bignum-ref truncate-x i) + low-digit + borrow) + (declare (type bignum-element-type x) + (fixnum temp-borrow)) + (setf (%bignum-ref truncate-x i) x) + (setf borrow temp-borrow))) + (incf i)) + (setf (%bignum-ref truncate-x i) + (%subtract-with-borrow (%bignum-ref truncate-x i) + carry-digit borrow)) + ;; See whether guess is off by one, adding one + ;; Y back in if necessary. + (cond ((%digit-0-or-plusp (%bignum-ref truncate-x i)) + guess) + (t + ;; If subtraction has negative result, add one + ;; divisor value back in. The guess was one too + ;; large in magnitude. + (let ((i low-x-digit) + (carry 0)) + (dotimes (j len-y) + (multiple-value-bind (v k) + (%add-with-carry (%bignum-ref truncate-y j) + (%bignum-ref truncate-x i) + carry) + (declare (type bignum-element-type v)) + (setf (%bignum-ref truncate-x i) v) + (setf carry k)) + (incf i)) + (setf (%bignum-ref truncate-x i) + (%add-with-carry (%bignum-ref truncate-x i) + 0 carry))) + (%subtract-with-borrow guess 1 1))))) + ;;; This returns the amount to shift y to place a one in the + ;;; second highest bit. Y must be positive. If the last digit + ;;; of y is zero, then y has a one in the previous digit's + ;;; sign bit, so we know it will take one less than digit-size + ;;; to get a one where we want. Otherwise, we count how many + ;;; right shifts it takes to get zero; subtracting this value + ;;; from digit-size tells us how many high zeros there are + ;;; which is one more than the shift amount sought. + ;;; + ;;; Note: This is exactly the same as one less than the + ;;; integer-length of the last digit subtracted from the + ;;; digit-size. + ;;; + ;;; We shift y to make it sufficiently large that doing the + ;;; 2*digit-size by digit-size %FLOOR calls ensures the quotient and + ;;; remainder fit in digit-size. + (shift-y-for-truncate (y) + (let* ((len (%bignum-length y)) + (last (%bignum-ref y (1- len)))) + (declare (type bignum-index len) + (type bignum-element-type last)) + (- digit-size (integer-length last) 1))) + ;;; Stores two bignums into the truncation bignum buffers, + ;;; shifting them on the way in. This assumes x and y are + ;;; positive and at least two in length, and it assumes + ;;; truncate-x and truncate-y are one digit longer than x and + ;;; y. + (shift-and-store-truncate-buffers (x len-x y len-y shift) + (declare (type bignum-index len-x len-y) + (type (integer 0 (#.digit-size)) shift)) + (cond ((zerop shift) + (bignum-replace truncate-x x :end1 len-x) + (bignum-replace truncate-y y :end1 len-y)) + (t + (bignum-ashift-left-unaligned x 0 shift (1+ len-x) + truncate-x) + (bignum-ashift-left-unaligned y 0 shift (1+ len-y) + truncate-y))))) ;; LABELS ;;; Divide X by Y returning the quotient and remainder. In the ;;; general case, we shift Y to set up for the algorithm, and we ;;; use two buffers to save consing intermediate values. X gets @@ -2247,58 +2247,58 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! ;;; multiple bind q and r, we first fix up the signs and then ;;; return the normalized results. (let* ((x-plusp (%bignum-0-or-plusp x (%bignum-length x))) - (y-plusp (%bignum-0-or-plusp y (%bignum-length y))) - (x (if x-plusp x (negate-bignum x nil))) - (y (if y-plusp y (negate-bignum y nil))) - (len-x (%bignum-length x)) - (len-y (%bignum-length y))) - (multiple-value-bind (q r) - (cond ((< len-y 2) - (bignum-truncate-single-digit x len-x y)) - ((plusp (bignum-compare y x)) - (let ((res (%allocate-bignum len-x))) - (dotimes (i len-x) - (setf (%bignum-ref res i) (%bignum-ref x i))) - (values 0 res))) - (t - (let ((len-x+1 (1+ len-x))) - (setf truncate-x (%allocate-bignum len-x+1)) - (setf truncate-y (%allocate-bignum (1+ len-y))) - (let ((y-shift (shift-y-for-truncate y))) - (shift-and-store-truncate-buffers x len-x y - len-y y-shift) - (values (return-quotient-leaving-remainder len-x+1 - len-y) - ;; Now that RETURN-QUOTIENT-LEAVING-REMAINDER - ;; has executed, we just tidy up the remainder - ;; (in TRUNCATE-X) and return it. - (cond - ((zerop y-shift) - (let ((res (%allocate-bignum len-y))) - (declare (type bignum-type res)) - (bignum-replace res truncate-x :end2 len-y) - (%normalize-bignum res len-y))) - (t - (shift-right-unaligned - truncate-x 0 y-shift len-y - ((= j res-len-1) - (setf (%bignum-ref res j) - (%ashr (%bignum-ref truncate-x i) - y-shift)) - (%normalize-bignum res res-len)) - res)))))))) - (let ((quotient (cond ((eq x-plusp y-plusp) q) - ((typep q 'fixnum) (the fixnum (- q))) - (t (negate-bignum-in-place q)))) - (rem (cond (x-plusp r) - ((typep r 'fixnum) (the fixnum (- r))) - (t (negate-bignum-in-place r))))) - (values (if (typep quotient 'fixnum) - quotient - (%normalize-bignum quotient (%bignum-length quotient))) - (if (typep rem 'fixnum) - rem - (%normalize-bignum rem (%bignum-length rem)))))))))) + (y-plusp (%bignum-0-or-plusp y (%bignum-length y))) + (x (if x-plusp x (negate-bignum x nil))) + (y (if y-plusp y (negate-bignum y nil))) + (len-x (%bignum-length x)) + (len-y (%bignum-length y))) + (multiple-value-bind (q r) + (cond ((< len-y 2) + (bignum-truncate-single-digit x len-x y)) + ((plusp (bignum-compare y x)) + (let ((res (%allocate-bignum len-x))) + (dotimes (i len-x) + (setf (%bignum-ref res i) (%bignum-ref x i))) + (values 0 res))) + (t + (let ((len-x+1 (1+ len-x))) + (setf truncate-x (%allocate-bignum len-x+1)) + (setf truncate-y (%allocate-bignum (1+ len-y))) + (let ((y-shift (shift-y-for-truncate y))) + (shift-and-store-truncate-buffers x len-x y + len-y y-shift) + (values (return-quotient-leaving-remainder len-x+1 + len-y) + ;; Now that RETURN-QUOTIENT-LEAVING-REMAINDER + ;; has executed, we just tidy up the remainder + ;; (in TRUNCATE-X) and return it. + (cond + ((zerop y-shift) + (let ((res (%allocate-bignum len-y))) + (declare (type bignum-type res)) + (bignum-replace res truncate-x :end2 len-y) + (%normalize-bignum res len-y))) + (t + (shift-right-unaligned + truncate-x 0 y-shift len-y + ((= j res-len-1) + (setf (%bignum-ref res j) + (%ashr (%bignum-ref truncate-x i) + y-shift)) + (%normalize-bignum res res-len)) + res)))))))) + (let ((quotient (cond ((eq x-plusp y-plusp) q) + ((typep q 'fixnum) (the fixnum (- q))) + (t (negate-bignum-in-place q)))) + (rem (cond (x-plusp r) + ((typep r 'fixnum) (the fixnum (- r))) + (t (negate-bignum-in-place r))))) + (values (if (typep quotient 'fixnum) + quotient + (%normalize-bignum quotient (%bignum-length quotient))) + (if (typep rem 'fixnum) + rem + (%normalize-bignum rem (%bignum-length rem)))))))))) ;;;; %FLOOR primitive for BIGNUM-TRUNCATE @@ -2315,7 +2315,7 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! #!-sb-fluid (declaim (inline 32x16-subtract-with-borrow 32x16-add-with-carry - 32x16-divide 32x16-multiply 32x16-multiply-split)) + 32x16-divide 32x16-multiply 32x16-multiply-split)) #!+32x16-divide (defconstant 32x16-base-1 (1- (ash 1 (/ sb!vm:n-word-bits 2)))) @@ -2331,11 +2331,11 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! #!+32x16-divide (defun 32x16-subtract-with-borrow (a b borrow) (declare (type bignum-half-element-type a b) - (type (integer 0 1) borrow)) + (type (integer 0 1) borrow)) (let ((diff (+ (- a b) borrow 32x16-base-1))) (declare (type (unsigned-byte #.(1+ half-digit-size)) diff)) (values (logand diff (1- (ash 1 half-digit-size))) - (ash diff (- half-digit-size))))) + (ash diff (- half-digit-size))))) ;;; This adds a and b, half-digit-size quantities, with the carry k. It ;;; returns a half-digit-size sum and a second value, 0 or 1, indicating @@ -2343,22 +2343,22 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! #!+32x16-divide (defun 32x16-add-with-carry (a b k) (declare (type bignum-half-element-type a b) - (type (integer 0 1) k)) + (type (integer 0 1) k)) (let ((res (the fixnum (+ a b k)))) (declare (type (unsigned-byte #.(1+ half-digit-size)) res)) (if (zerop (the fixnum (logand (ash 1 half-digit-size) res))) - (values res 0) - (values (the bignum-half-element-type (logand (1- (ash 1 half-digit-size)) res)) - 1)))) + (values res 0) + (values (the bignum-half-element-type (logand (1- (ash 1 half-digit-size)) res)) + 1)))) ;;; This is probably a digit-size by digit-size divide instruction. #!+32x16-divide (defun 32x16-divide (a b c) (declare (type bignum-half-element-type a b c)) (floor (the bignum-element-type - (logior (the bignum-element-type (ash a 16)) - b)) - c)) + (logior (the bignum-element-type (ash a 16)) + b)) + c)) ;;; This basically exists since we know the answer won't overflow ;;; bignum-element-type. It's probably just a basic multiply instruction, but @@ -2376,7 +2376,7 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (let ((res (32x16-multiply a b))) (declare (the bignum-element-type res)) (values (the bignum-half-element-type (logand (1- (ash 1 half-digit-size)) (ash res (- half-digit-size)))) - (the bignum-half-element-type (logand (1- (ash 1 half-digit-size)) res))))) + (the bignum-half-element-type (logand (1- (ash 1 half-digit-size)) res))))) ;;; The %FLOOR below uses this buffer the same way BIGNUM-TRUNCATE uses ;;; *truncate-x*. There's no y buffer since we pass around the two @@ -2384,7 +2384,7 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! ;;; general truncation algorithm above. #!+32x16-divide (defvar *32x16-truncate-x* (make-array 4 :element-type 'bignum-half-element-type - :initial-element 0)) + :initial-element 0)) ;;; This does the same thing as the %FLOOR above, but it does it at Lisp level ;;; when there is no 64x32-bit divide instruction on the machine. @@ -2397,45 +2397,45 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (declare (type bignum-element-type a b c)) ;; Setup *32x16-truncate-x* buffer from a and b. (setf (aref *32x16-truncate-x* 0) - (the bignum-half-element-type (logand (1- (ash 1 half-digit-size)) b))) + (the bignum-half-element-type (logand (1- (ash 1 half-digit-size)) b))) (setf (aref *32x16-truncate-x* 1) - (the bignum-half-element-type - (logand (1- (ash 1 half-digit-size)) - (the bignum-half-element-type (ash b (- half-digit-size)))))) + (the bignum-half-element-type + (logand (1- (ash 1 half-digit-size)) + (the bignum-half-element-type (ash b (- half-digit-size)))))) (setf (aref *32x16-truncate-x* 2) - (the bignum-half-element-type (logand (1- (ash 1 half-digit-size)) a))) + (the bignum-half-element-type (logand (1- (ash 1 half-digit-size)) a))) (setf (aref *32x16-truncate-x* 3) - (the bignum-half-element-type - (logand (1- (ash 1 half-digit-size)) - (the bignum-half-element-type (ash a (- half-digit-size)))))) + (the bignum-half-element-type + (logand (1- (ash 1 half-digit-size)) + (the bignum-half-element-type (ash a (- half-digit-size)))))) ;; From DO-TRUNCATE, but unroll the loop. (let* ((y1 (logand (1- (ash 1 half-digit-size)) (ash c (- half-digit-size)))) - (y2 (logand (1- (ash 1 half-digit-size)) c)) - (q (the bignum-element-type - (ash (32x16-try-bignum-truncate-guess - (32x16-truncate-guess y1 y2 - (aref *32x16-truncate-x* 3) - (aref *32x16-truncate-x* 2) - (aref *32x16-truncate-x* 1)) - y1 y2 1) - 16)))) + (y2 (logand (1- (ash 1 half-digit-size)) c)) + (q (the bignum-element-type + (ash (32x16-try-bignum-truncate-guess + (32x16-truncate-guess y1 y2 + (aref *32x16-truncate-x* 3) + (aref *32x16-truncate-x* 2) + (aref *32x16-truncate-x* 1)) + y1 y2 1) + 16)))) (declare (type bignum-element-type q) - (type bignum-half-element-type y1 y2)) + (type bignum-half-element-type y1 y2)) (values (the bignum-element-type - (logior q - (the bignum-half-element-type - (32x16-try-bignum-truncate-guess - (32x16-truncate-guess - y1 y2 - (aref *32x16-truncate-x* 2) - (aref *32x16-truncate-x* 1) - (aref *32x16-truncate-x* 0)) - y1 y2 0)))) - (the bignum-element-type - (logior (the bignum-element-type - (ash (aref *32x16-truncate-x* 1) 16)) - (the bignum-half-element-type - (aref *32x16-truncate-x* 0))))))) + (logior q + (the bignum-half-element-type + (32x16-try-bignum-truncate-guess + (32x16-truncate-guess + y1 y2 + (aref *32x16-truncate-x* 2) + (aref *32x16-truncate-x* 1) + (aref *32x16-truncate-x* 0)) + y1 y2 0)))) + (the bignum-element-type + (logior (the bignum-element-type + (ash (aref *32x16-truncate-x* 1) 16)) + (the bignum-half-element-type + (aref *32x16-truncate-x* 0))))))) ;;; This is similar to TRY-BIGNUM-TRUNCATE-GUESS, but this unrolls the two ;;; loops. This also substitutes for %DIGIT-0-OR-PLUSP the equivalent @@ -2445,48 +2445,48 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! #!+32x16-divide (defun 32x16-try-bignum-truncate-guess (guess y-high y-low low-x-digit) (declare (type bignum-index low-x-digit) - (type bignum-half-element-type guess y-high y-low)) + (type bignum-half-element-type guess y-high y-low)) (let ((high-x-digit (+ 2 low-x-digit))) ;; Multiply guess and divisor, subtracting from dividend simultaneously. (multiple-value-bind (guess*y-hold carry borrow) - (32x16-try-guess-one-result-digit guess y-low 0 0 1 low-x-digit) + (32x16-try-guess-one-result-digit guess y-low 0 0 1 low-x-digit) (declare (type bignum-half-element-type guess*y-hold) - (fixnum carry borrow)) + (fixnum carry borrow)) (multiple-value-bind (guess*y-hold carry borrow) - (32x16-try-guess-one-result-digit guess y-high guess*y-hold - carry borrow (1+ low-x-digit)) - (declare (type bignum-half-element-type guess*y-hold) - (fixnum borrow) - (ignore carry)) - (setf (aref *32x16-truncate-x* high-x-digit) - (32x16-subtract-with-borrow (aref *32x16-truncate-x* high-x-digit) - guess*y-hold borrow)))) + (32x16-try-guess-one-result-digit guess y-high guess*y-hold + carry borrow (1+ low-x-digit)) + (declare (type bignum-half-element-type guess*y-hold) + (fixnum borrow) + (ignore carry)) + (setf (aref *32x16-truncate-x* high-x-digit) + (32x16-subtract-with-borrow (aref *32x16-truncate-x* high-x-digit) + guess*y-hold borrow)))) ;; See whether guess is off by one, adding one Y back in if necessary. (cond ((zerop (logand (ash 1 (1- half-digit-size)) (aref *32x16-truncate-x* high-x-digit))) - ;; The subtraction result is zero or positive. - guess) - (t - ;; If subtraction has negative result, add one divisor value back - ;; in. The guess was one too large in magnitude. - (multiple-value-bind (v carry) - (32x16-add-with-carry y-low - (aref *32x16-truncate-x* low-x-digit) - 0) - (declare (type bignum-half-element-type v)) - (setf (aref *32x16-truncate-x* low-x-digit) v) - (multiple-value-bind (v carry) - (32x16-add-with-carry y-high - (aref *32x16-truncate-x* - (1+ low-x-digit)) - carry) - (setf (aref *32x16-truncate-x* (1+ low-x-digit)) v) - (setf (aref *32x16-truncate-x* high-x-digit) - (32x16-add-with-carry (aref *32x16-truncate-x* high-x-digit) - carry 0)))) - (if (zerop (logand (ash 1 (1- half-digit-size)) guess)) - (1- guess) - (1+ guess)))))) + ;; The subtraction result is zero or positive. + guess) + (t + ;; If subtraction has negative result, add one divisor value back + ;; in. The guess was one too large in magnitude. + (multiple-value-bind (v carry) + (32x16-add-with-carry y-low + (aref *32x16-truncate-x* low-x-digit) + 0) + (declare (type bignum-half-element-type v)) + (setf (aref *32x16-truncate-x* low-x-digit) v) + (multiple-value-bind (v carry) + (32x16-add-with-carry y-high + (aref *32x16-truncate-x* + (1+ low-x-digit)) + carry) + (setf (aref *32x16-truncate-x* (1+ low-x-digit)) v) + (setf (aref *32x16-truncate-x* high-x-digit) + (32x16-add-with-carry (aref *32x16-truncate-x* high-x-digit) + carry 0)))) + (if (zerop (logand (ash 1 (1- half-digit-size)) guess)) + (1- guess) + (1+ guess)))))) ;;; This is similar to the body of the loop in TRY-BIGNUM-TRUNCATE-GUESS that ;;; multiplies the guess by y and subtracts the result from x simultaneously. @@ -2495,22 +2495,22 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! ;;; doing the subtraction. #!+32x16-divide (defun 32x16-try-guess-one-result-digit (guess y-digit guess*y-hold - carry borrow x-index) + carry borrow x-index) (multiple-value-bind (high-digit low-digit) (32x16-multiply-split guess y-digit) (declare (type bignum-half-element-type high-digit low-digit)) (multiple-value-bind (low-digit temp-carry) - (32x16-add-with-carry low-digit guess*y-hold carry) + (32x16-add-with-carry low-digit guess*y-hold carry) (declare (type bignum-half-element-type low-digit)) (multiple-value-bind (high-digit temp-carry) - (32x16-add-with-carry high-digit temp-carry 0) - (declare (type bignum-half-element-type high-digit)) - (multiple-value-bind (x temp-borrow) - (32x16-subtract-with-borrow (aref *32x16-truncate-x* x-index) - low-digit borrow) - (declare (type bignum-half-element-type x)) - (setf (aref *32x16-truncate-x* x-index) x) - (values high-digit temp-carry temp-borrow)))))) + (32x16-add-with-carry high-digit temp-carry 0) + (declare (type bignum-half-element-type high-digit)) + (multiple-value-bind (x temp-borrow) + (32x16-subtract-with-borrow (aref *32x16-truncate-x* x-index) + low-digit borrow) + (declare (type bignum-half-element-type x)) + (setf (aref *32x16-truncate-x* x-index) x) + (values high-digit temp-carry temp-borrow)))))) ;;; This is similar to BIGNUM-TRUNCATE-GUESS, but instead of computing ;;; the guess exactly as described in the its comments (digit by digit), @@ -2520,27 +2520,27 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (defun 32x16-truncate-guess (y1 y2 x-i x-i-1 x-i-2) (declare (type bignum-half-element-type y1 y2 x-i x-i-1 x-i-2)) (let ((guess (if (= x-i y1) - (1- (ash 1 half-digit-size)) - (32x16-divide x-i x-i-1 y1)))) + (1- (ash 1 half-digit-size)) + (32x16-divide x-i x-i-1 y1)))) (declare (type bignum-half-element-type guess)) (loop (let* ((guess*y1 (the bignum-element-type - (ash (logand (1- (ash 1 half-digit-size)) - (the bignum-element-type - (32x16-multiply guess y1))) - 16))) - (x-y (%subtract-with-borrow - (the bignum-element-type - (logior (the bignum-element-type - (ash x-i-1 16)) - x-i-2)) - guess*y1 - 1)) - (guess*y2 (the bignum-element-type (%multiply guess y2)))) - (declare (type bignum-element-type guess*y1 x-y guess*y2)) - (if (%digit-greater guess*y2 x-y) - (decf guess) - (return guess)))))) + (ash (logand (1- (ash 1 half-digit-size)) + (the bignum-element-type + (32x16-multiply guess y1))) + 16))) + (x-y (%subtract-with-borrow + (the bignum-element-type + (logior (the bignum-element-type + (ash x-i-1 16)) + x-i-2)) + guess*y1 + 1)) + (guess*y2 (the bignum-element-type (%multiply guess y2)))) + (declare (type bignum-element-type guess*y1 x-y guess*y2)) + (if (%digit-greater guess*y2 x-y) + (decf guess) + (return guess)))))) ;;;; general utilities @@ -2551,16 +2551,16 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! #!-sb-fluid (declaim (sb!ext:maybe-inline %normalize-bignum-buffer)) (defun %normalize-bignum-buffer (result len) (declare (type bignum-type result) - (type bignum-index len)) + (type bignum-index len)) (unless (= len 1) (do ((next-digit (%bignum-ref result (- len 2)) - (%bignum-ref result (- len 2))) - (sign-digit (%bignum-ref result (1- len)) next-digit)) - ((not (zerop (logxor sign-digit (%ashr next-digit (1- digit-size)))))) - (decf len) - (setf (%bignum-ref result len) 0) - (when (= len 1) - (return)))) + (%bignum-ref result (- len 2))) + (sign-digit (%bignum-ref result (1- len)) next-digit)) + ((not (zerop (logxor sign-digit (%ashr next-digit (1- digit-size)))))) + (decf len) + (setf (%bignum-ref result len) 0) + (when (= len 1) + (return)))) len) ;;; This drops the last digit if it is unnecessary sign information. It repeats @@ -2572,27 +2572,27 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! ;;; we do have a fixnum, shift it over for the two low-tag bits. (defun %normalize-bignum (result len) (declare (type bignum-type result) - (type bignum-index len) - (inline %normalize-bignum-buffer)) + (type bignum-index len) + (inline %normalize-bignum-buffer)) (let ((newlen (%normalize-bignum-buffer result len))) (declare (type bignum-index newlen)) (unless (= newlen len) (%bignum-set-length result newlen)) (if (= newlen 1) - (let ((digit (%bignum-ref result 0))) - (if (= (%ashr digit sb!vm:n-positive-fixnum-bits) + (let ((digit (%bignum-ref result 0))) + (if (= (%ashr digit sb!vm:n-positive-fixnum-bits) (%ashr digit (1- digit-size))) - (%fixnum-digit-with-correct-sign digit) - result)) - result))) + (%fixnum-digit-with-correct-sign digit) + result)) + result))) ;;; This drops the last digit if it is unnecessary sign information. It ;;; repeats this as needed, possibly ending with a fixnum magnitude but never ;;; returning a fixnum. (defun %mostly-normalize-bignum (result len) (declare (type bignum-type result) - (type bignum-index len) - (inline %normalize-bignum-buffer)) + (type bignum-index len) + (inline %normalize-bignum-buffer)) (let ((newlen (%normalize-bignum-buffer result len))) (declare (type bignum-index newlen)) (unless (= newlen len) @@ -2608,8 +2608,8 @@ IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS! (dotimes (i (%bignum-length x)) (declare (type index i)) (let ((xi (%bignum-ref x i))) - (mixf result - (logand most-positive-fixnum - xi - (ash xi -7))))) + (mixf result + (logand most-positive-fixnum + xi + (ash xi -7))))) result)) diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index 6afe33c..ea61c32 100644 --- a/src/code/bit-bash.lisp +++ b/src/code/bit-bash.lisp @@ -21,8 +21,8 @@ ;;; these, or DEFTRANSFORMs to convert them into something supported ;;; by the architecture. (macrolet ((def (name &rest args) - `(defun ,name ,args - (,name ,@args)))) + `(defun ,name ,args + (,name ,@args)))) (def word-logical-not x) (def word-logical-and x y) (def word-logical-or x y) @@ -44,12 +44,12 @@ (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) countoid))) (declare (type bit-offset count)) (if (zerop count) - number - (ecase sb!c:*backend-byte-order* - (:big-endian - (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count)) - (:little-endian - (ash number (- count))))))) + number + (ecase sb!c:*backend-byte-order* + (:big-endian + (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count)) + (:little-endian + (ash number (- count))))))) ;;; Shift NUMBER by COUNT bits, adding zero bits at the "start" and ;;; removing bits from the "end". On big-endian machines this is a @@ -59,12 +59,12 @@ (let ((count (ldb (byte (1- (integer-length sb!vm:n-word-bits)) 0) count))) (declare (type bit-offset count)) (if (zerop count) - number - (ecase sb!c:*backend-byte-order* - (:big-endian - (ash number (- count))) - (:little-endian - (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count)))))) + number + (ecase sb!c:*backend-byte-order* + (:big-endian + (ash number (- count))) + (:little-endian + (ash (ldb (byte (- sb!vm:n-word-bits count) 0) number) count)))))) #!-sb-fluid (declaim (inline start-mask end-mask)) @@ -87,18 +87,18 @@ #!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref)) (defun word-sap-ref (sap offset) (declare (type system-area-pointer sap) - (type index offset) - (values sb!vm:word) - (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3))) + (type index offset) + (values sb!vm:word) + (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3))) (sap-ref-word sap (the index (ash offset sb!vm:n-fixnum-tag-bits)))) (defun %set-word-sap-ref (sap offset value) (declare (type system-area-pointer sap) - (type index offset) - (type sb!vm:word value) - (values sb!vm:word) - (optimize (speed 3) (safety 0) (inhibit-warnings 3))) + (type index offset) + (type sb!vm:word value) + (values sb!vm:word) + (optimize (speed 3) (safety 0) (inhibit-warnings 3))) (setf (sap-ref-word sap (the index (ash offset sb!vm:n-fixnum-tag-bits))) - value)) + value)) ;;; the actual bashers and common uses of same @@ -149,7 +149,7 @@ (8 0) (16 0) (32 0) - (64 0)))) + (64 0)))) (offset `(integer 0 ,max-bytes)) (max-word-offset (ceiling max-bytes bytes-per-word)) (word-offset `(integer 0 ,max-word-offset)) diff --git a/src/code/bsd-os.lisp b/src/code/bsd-os.lisp index 6a96ee9..ed8d868 100644 --- a/src/code/bsd-os.lisp +++ b/src/code/bsd-os.lisp @@ -9,7 +9,7 @@ ;;;; Check that target machine features are set up consistently with ;;;; this file. #!-bsd (eval-when (:compile-toplevel :load-toplevel :execute) - (error "The :BSD feature is missing, we shouldn't be doing this code.")) + (error "The :BSD feature is missing, we shouldn't be doing this code.")) (defun software-type () #!+sb-doc @@ -28,30 +28,30 @@ if not available." (or *software-version* (setf *software-version* - (string-trim '(#\newline) - (with-output-to-string (stream) - (sb!ext:run-program "/usr/bin/uname" `("-r") - :output stream)))))) + (string-trim '(#\newline) + (with-output-to-string (stream) + (sb!ext:run-program "/usr/bin/uname" `("-r") + :output stream)))))) (defun os-cold-init-or-reinit () (setf *software-version* nil) (setf *default-pathname-defaults* - ;; (temporary value, so that #'PATHNAME won't blow up when - ;; we call it below:) - (make-trivial-default-pathname) - *default-pathname-defaults* - ;; (final value, constructed using #'PATHNAME:) - (pathname (sb!unix:posix-getcwd/)))) + ;; (temporary value, so that #'PATHNAME won't blow up when + ;; we call it below:) + (make-trivial-default-pathname) + *default-pathname-defaults* + ;; (final value, constructed using #'PATHNAME:) + (pathname (sb!unix:posix-getcwd/)))) ;;; Return system time, user time and number of page faults. (defun get-system-info () (multiple-value-bind (err? utime stime maxrss ixrss idrss - isrss minflt majflt) - (sb!unix:unix-getrusage sb!unix:rusage_self) + isrss minflt majflt) + (sb!unix:unix-getrusage sb!unix:rusage_self) (declare (ignore maxrss ixrss idrss isrss minflt)) (unless err? (simple-perror "Unix system call getrusage() failed" :errno utime)) - + (values utime stime majflt))) ;;; Return the system page size. diff --git a/src/code/cl-specials.lisp b/src/code/cl-specials.lisp index 7b51118..9c455f8 100644 --- a/src/code/cl-specials.lisp +++ b/src/code/cl-specials.lisp @@ -13,73 +13,73 @@ (in-package "COMMON-LISP") (sb!xc:proclaim '(special cl:* - cl:** - cl:*** - cl:*break-on-signals* - cl:*compile-file-pathname* - cl:*compile-file-truename* - cl:*compile-print* - cl:*compile-verbose* - cl:*debug-io* - cl:*debugger-hook* - cl:*default-pathname-defaults* - cl:*error-output* - cl:*features* - cl:*gensym-counter* - cl:*load-pathname* - cl:*load-print* - cl:*load-truename* - cl:*load-verbose* - cl:*macroexpand-hook* - cl:*modules* - cl:*package* - cl:*print-array* - cl:*print-base* - cl:*print-case* - cl:*print-circle* - cl:*print-escape* - cl:*print-gensym* - cl:*print-length* - cl:*print-level* - cl:*print-lines* - cl:*print-miser-width* - cl:*print-pprint-dispatch* - cl:*print-pretty* - cl:*print-radix* - cl:*print-readably* - cl:*print-right-margin* - cl:*query-io* - cl:*random-state* - cl:*read-base* - cl:*read-default-float-format* - cl:*read-eval* - cl:*read-suppress* - cl:*readtable* - cl:*standard-input* - cl:*standard-output* - cl:*terminal-io* - cl:*trace-output* - cl:+ - cl:++ - cl:+++ - cl:- - cl:/ - cl:// - cl:///)) + cl:** + cl:*** + cl:*break-on-signals* + cl:*compile-file-pathname* + cl:*compile-file-truename* + cl:*compile-print* + cl:*compile-verbose* + cl:*debug-io* + cl:*debugger-hook* + cl:*default-pathname-defaults* + cl:*error-output* + cl:*features* + cl:*gensym-counter* + cl:*load-pathname* + cl:*load-print* + cl:*load-truename* + cl:*load-verbose* + cl:*macroexpand-hook* + cl:*modules* + cl:*package* + cl:*print-array* + cl:*print-base* + cl:*print-case* + cl:*print-circle* + cl:*print-escape* + cl:*print-gensym* + cl:*print-length* + cl:*print-level* + cl:*print-lines* + cl:*print-miser-width* + cl:*print-pprint-dispatch* + cl:*print-pretty* + cl:*print-radix* + cl:*print-readably* + cl:*print-right-margin* + cl:*query-io* + cl:*random-state* + cl:*read-base* + cl:*read-default-float-format* + cl:*read-eval* + cl:*read-suppress* + cl:*readtable* + cl:*standard-input* + cl:*standard-output* + cl:*terminal-io* + cl:*trace-output* + cl:+ + cl:++ + cl:+++ + cl:- + cl:/ + cl:// + cl:///)) (sb!xc:proclaim '(type t cl:+ cl:++ cl:+++ cl:- cl:* cl:** cl:***)) ;;; generalized booleans (sb!xc:proclaim '(type t cl:*compile-print* cl:*compile-verbose* - cl:*load-print* cl:*load-verbose* - cl:*print-array* cl:*print-radix* - cl:*print-circle* cl:*print-escape* - cl:*print-gensym* cl:*print-pretty* - cl:*print-readably* cl:*read-eval* - cl:*read-suppress*)) + cl:*load-print* cl:*load-verbose* + cl:*print-array* cl:*print-radix* + cl:*print-circle* cl:*print-escape* + cl:*print-gensym* cl:*print-pretty* + cl:*print-readably* cl:*read-eval* + cl:*read-suppress*)) (sb!xc:proclaim '(type sb!pretty::pprint-dispatch-table - cl:*print-pprint-dispatch*)) + cl:*print-pprint-dispatch*)) (sb!xc:proclaim '(type readtable cl:*readtable*)) @@ -88,7 +88,7 @@ (sb!xc:proclaim '(type (member :upcase :downcase :capitalize) cl:*print-case*)) (sb!xc:proclaim '(type (member cl:single-float cl:double-float - cl:short-float cl:long-float) cl:*read-default-float-format*)) + cl:short-float cl:long-float) cl:*read-default-float-format*)) (sb!xc:proclaim '(type list cl:/ cl:// cl:/// cl:*features* cl:*modules*)) @@ -104,32 +104,32 @@ ;; even this in Gray streams or simple-streams? apparently not, ;; currently) (sb!xc:proclaim '(type stream - cl:*standard-input* - cl:*error-output* - cl:*standard-output* - cl:*trace-output* - cl:*debug-io* - cl:*query-io* - cl:*terminal-io*)) + cl:*standard-input* + cl:*error-output* + cl:*standard-output* + cl:*trace-output* + cl:*debug-io* + cl:*query-io* + cl:*terminal-io*)) ;;; FIXME: make an SB!INT:FUNCTION-DESIGNATOR type for these (sb!xc:proclaim '(type (or function symbol cons) - cl:*debugger-hook* - cl:*macroexpand-hook*)) + cl:*debugger-hook* + cl:*macroexpand-hook*)) (sb!xc:proclaim '(type unsigned-byte cl:*gensym-counter*)) (sb!xc:proclaim '(type (or unsigned-byte null) - cl:*print-length* - cl:*print-level* - cl:*print-lines* - cl:*print-miser-width* - cl:*print-right-margin*)) + cl:*print-length* + cl:*print-level* + cl:*print-lines* + cl:*print-miser-width* + cl:*print-right-margin*)) (sb!xc:proclaim '(type pathname cl:*default-pathname-defaults*)) (sb!xc:proclaim '(type (or pathname null) - cl:*load-pathname* - cl:*load-truename* - cl:*compile-file-pathname* - cl:*compile-file-truename*)) + cl:*load-pathname* + cl:*load-truename* + cl:*compile-file-pathname* + cl:*compile-file-truename*)) diff --git a/src/code/class-init.lisp b/src/code/class-init.lisp index 45a52ec..b6aab5f 100644 --- a/src/code/class-init.lisp +++ b/src/code/class-init.lisp @@ -25,8 +25,8 @@ (when trans-p (/show0 "in TRANS-P case") (let ((classoid (classoid-cell-classoid (find-classoid-cell name))) - (type (specifier-type translation))) - (setf (built-in-classoid-translation classoid) type) - (setf (info :type :builtin name) type))))) + (type (specifier-type translation))) + (setf (built-in-classoid-translation classoid) type) + (setf (info :type :builtin name) type))))) (/show0 "done with class-init.lisp") diff --git a/src/code/class.lisp b/src/code/class.lisp index a3a8169..dfee729 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -1,6 +1,6 @@ ;;;; This file contains structures and functions for the maintenance of ;;;; basic information about defined types. Different object systems -;;;; can be supported simultaneously. +;;;; can be supported simultaneously. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -23,30 +23,30 @@ ;;; away as with the merger of SB-PCL:CLASS and CL:CLASS it's no ;;; longer necessary) (def!struct (classoid - (:make-load-form-fun classoid-make-load-form-fun) - (:include ctype - (class-info (type-class-or-lose 'classoid))) - (:constructor nil) - #-no-ansi-print-object - (:print-object - (lambda (class stream) - (let ((name (classoid-name class))) - (print-unreadable-object (class stream - :type t - :identity (not name)) - (format stream - ;; FIXME: Make sure that this prints - ;; reasonably for anonymous classes. - "~:[anonymous~;~:*~S~]~@[ (~(~A~))~]" - name - (classoid-state class)))))) - #-sb-xc-host (:pure nil)) + (:make-load-form-fun classoid-make-load-form-fun) + (:include ctype + (class-info (type-class-or-lose 'classoid))) + (:constructor nil) + #-no-ansi-print-object + (:print-object + (lambda (class stream) + (let ((name (classoid-name class))) + (print-unreadable-object (class stream + :type t + :identity (not name)) + (format stream + ;; FIXME: Make sure that this prints + ;; reasonably for anonymous classes. + "~:[anonymous~;~:*~S~]~@[ (~(~A~))~]" + name + (classoid-state class)))))) + #-sb-xc-host (:pure nil)) ;; the value to be returned by CLASSOID-NAME. (name nil :type symbol) ;; the current layout for this class, or NIL if none assigned yet (layout nil :type (or layout null)) ;; How sure are we that this class won't be redefined? - ;; :READ-ONLY = We are committed to not changing the effective + ;; :READ-ONLY = We are committed to not changing the effective ;; slots or superclasses. ;; :SEALED = We can't even add subclasses. ;; NIL = Anything could happen. @@ -70,7 +70,7 @@ (unless (and name (eq (find-classoid name nil) class)) (/show "anonymous/undefined class case") (error "can't use anonymous or undefined class as constant:~% ~S" - class)) + class)) `(locally ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for constant ;; class names which creates fast but non-cold-loadable, @@ -102,11 +102,11 @@ (!cold-init-forms (setq *forward-referenced-layouts* (make-hash-table :test 'equal)) #-sb-xc-host (progn - (/show0 "processing *!INITIAL-LAYOUTS*") - (dolist (x *!initial-layouts*) - (setf (gethash (car x) *forward-referenced-layouts*) - (cdr x))) - (/show0 "done processing *!INITIAL-LAYOUTS*"))) + (/show0 "processing *!INITIAL-LAYOUTS*") + (dolist (x *!initial-layouts*) + (setf (gethash (car x) *forward-referenced-layouts*) + (cdr x))) + (/show0 "done processing *!INITIAL-LAYOUTS*"))) ;;; The LAYOUT structure is pointed to by the first cell of instance ;;; (or structure) objects. It represents what we need to know for @@ -114,28 +114,28 @@ ;;; incompatibly redefined, a new layout is allocated. If two object's ;;; layouts are EQ, then they are exactly the same type. (def!struct (layout - ;; KLUDGE: A special hack keeps this from being - ;; called when building code for the - ;; cross-compiler. See comments at the DEFUN for - ;; this. -- WHN 19990914 - (:make-load-form-fun #-sb-xc-host ignore-it - ;; KLUDGE: DEF!STRUCT at #+SB-XC-HOST - ;; time controls both the - ;; build-the-cross-compiler behavior - ;; and the run-the-cross-compiler - ;; behavior. The value below only - ;; works for build-the-cross-compiler. - ;; There's a special hack in - ;; EMIT-MAKE-LOAD-FORM which gives - ;; effectively IGNORE-IT behavior for - ;; LAYOUT at run-the-cross-compiler - ;; time. It would be cleaner to - ;; actually have an IGNORE-IT value - ;; stored, but it's hard to see how to - ;; do that concisely with the current - ;; DEF!STRUCT setup. -- WHN 19990930 - #+sb-xc-host - make-load-form-for-layout)) + ;; KLUDGE: A special hack keeps this from being + ;; called when building code for the + ;; cross-compiler. See comments at the DEFUN for + ;; this. -- WHN 19990914 + (:make-load-form-fun #-sb-xc-host ignore-it + ;; KLUDGE: DEF!STRUCT at #+SB-XC-HOST + ;; time controls both the + ;; build-the-cross-compiler behavior + ;; and the run-the-cross-compiler + ;; behavior. The value below only + ;; works for build-the-cross-compiler. + ;; There's a special hack in + ;; EMIT-MAKE-LOAD-FORM which gives + ;; effectively IGNORE-IT behavior for + ;; LAYOUT at run-the-cross-compiler + ;; time. It would be cleaner to + ;; actually have an IGNORE-IT value + ;; stored, but it's hard to see how to + ;; do that concisely with the current + ;; DEF!STRUCT setup. -- WHN 19990930 + #+sb-xc-host + make-load-form-for-layout)) ;; hash bits which should be set to constant pseudo-random values ;; for use by CLOS. Sleazily accessed via %INSTANCE-REF, see ;; LAYOUT-CLOS-HASH. @@ -161,7 +161,7 @@ ;; The value of this slot can be: ;; * :UNINITIALIZED if not initialized yet; ;; * NIL if this is the up-to-date layout for a class; or - ;; * T if this layout has been invalidated (by being replaced by + ;; * T if this layout has been invalidated (by being replaced by ;; a new, more-up-to-date LAYOUT). ;; * something else (probably a list) if the class is a PCL wrapper ;; and PCL has made it invalid and made a note to itself about it @@ -174,7 +174,7 @@ ;; Remaining elements are filled by the non-hierarchical layouts or, ;; if they would otherwise be empty, by copies of succeeding layouts. (inherits #() :type simple-vector) - ;; If inheritance is not hierarchical, this is -1. If inheritance is + ;; If inheritance is not hierarchical, this is -1. If inheritance is ;; hierarchical, this is the inheritance depth, i.e. (LENGTH INHERITS). ;; Note: ;; (1) This turns out to be a handy encoding for arithmetically @@ -204,9 +204,9 @@ (def!method print-object ((layout layout) stream) (print-unreadable-object (layout stream :type t :identity t) (format stream - "for ~S~@[, INVALID=~S~]" - (layout-proper-name layout) - (layout-invalid layout)))) + "for ~S~@[, INVALID=~S~]" + (layout-proper-name layout) + (layout-invalid layout)))) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun layout-proper-name (layout) @@ -246,10 +246,10 @@ ;; having to use bignum arithmetic? Or what? An explanation would be ;; nice. (1+ (random layout-clos-hash-max - (if (boundp '*layout-clos-hash-random-state*) - *layout-clos-hash-random-state* - (setf *layout-clos-hash-random-state* - (make-random-state)))))) + (if (boundp '*layout-clos-hash-random-state*) + *layout-clos-hash-random-state* + (setf *layout-clos-hash-random-state* + (make-random-state)))))) ;;; If we can't find any existing layout, then we create a new one ;;; storing it in *FORWARD-REFERENCED-LAYOUTS*. In classic CMU CL, we @@ -261,10 +261,10 @@ (defun find-layout (name) (let ((classoid (find-classoid name nil))) (or (and classoid (classoid-layout classoid)) - (gethash name *forward-referenced-layouts*) - (setf (gethash name *forward-referenced-layouts*) - (make-layout :classoid (or classoid - (make-undefined-classoid name))))))) + (gethash name *forward-referenced-layouts*) + (setf (gethash name *forward-referenced-layouts*) + (make-layout :classoid (or classoid + (make-undefined-classoid name))))))) ;;; If LAYOUT is uninitialized, initialize it with CLASSOID, LENGTH, ;;; INHERITS, and DEPTHOID, otherwise require that it be consistent @@ -276,30 +276,30 @@ ;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This ;;; is no longer true, :UNINITIALIZED used instead. (declaim (ftype (function (layout classoid index simple-vector layout-depthoid - index) - layout) - init-or-check-layout)) + index) + layout) + init-or-check-layout)) (defun init-or-check-layout (layout classoid length inherits depthoid nuntagged) (cond ((eq (layout-invalid layout) :uninitialized) - ;; There was no layout before, we just created one which - ;; we'll now initialize with our information. - (setf (layout-length layout) length - (layout-inherits layout) inherits - (layout-depthoid layout) depthoid - (layout-n-untagged-slots layout) nuntagged - (layout-classoid layout) classoid - (layout-invalid layout) nil)) - ;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this - ;; clause is not needed? - ((not *type-system-initialized*) - (setf (layout-classoid layout) classoid)) - (t - ;; There was an old layout already initialized with old - ;; information, and we'll now check that old information - ;; which was known with certainty is consistent with current - ;; information which is known with certainty. - (check-layout layout classoid length inherits depthoid nuntagged))) + ;; There was no layout before, we just created one which + ;; we'll now initialize with our information. + (setf (layout-length layout) length + (layout-inherits layout) inherits + (layout-depthoid layout) depthoid + (layout-n-untagged-slots layout) nuntagged + (layout-classoid layout) classoid + (layout-invalid layout) nil)) + ;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this + ;; clause is not needed? + ((not *type-system-initialized*) + (setf (layout-classoid layout) classoid)) + (t + ;; There was an old layout already initialized with old + ;; information, and we'll now check that old information + ;; which was known with certainty is consistent with current + ;; information which is known with certainty. + (check-layout layout classoid length inherits depthoid nuntagged))) layout) ;;; In code for the target Lisp, we don't use dump LAYOUTs using the @@ -321,7 +321,7 @@ (declare (ignore env)) (when (layout-invalid layout) (compiler-error "can't dump reference to obsolete class: ~S" - (layout-classoid layout))) + (layout-classoid layout))) (let ((name (classoid-name (layout-classoid layout)))) (unless name (compiler-error "can't dump anonymous LAYOUT: ~S" layout)) @@ -335,84 +335,84 @@ ;; "initialization" form (which actually doesn't initialize ;; preexisting LAYOUTs, just checks that they're consistent). `(init-or-check-layout ',layout - ',(layout-classoid layout) - ',(layout-length layout) - ',(layout-inherits layout) - ',(layout-depthoid layout) - ',(layout-n-untagged-slots layout))))) + ',(layout-classoid layout) + ',(layout-length layout) + ',(layout-inherits layout) + ',(layout-depthoid layout) + ',(layout-n-untagged-slots layout))))) ;;; If LAYOUT's slot values differ from the specified slot values in ;;; any interesting way, then give a warning and return T. (declaim (ftype (function (simple-string - layout - simple-string - index - simple-vector - layout-depthoid - index)) - redefine-layout-warning)) + layout + simple-string + index + simple-vector + layout-depthoid + index)) + redefine-layout-warning)) (defun redefine-layout-warning (old-context old-layout - context length inherits depthoid nuntagged) + context length inherits depthoid nuntagged) (declare (type layout old-layout) (type simple-string old-context context)) (let ((name (layout-proper-name old-layout))) (or (let ((old-inherits (layout-inherits old-layout))) - (or (when (mismatch old-inherits - inherits - :key #'layout-proper-name) - (warn "change in superclasses of class ~S:~% ~ + (or (when (mismatch old-inherits + inherits + :key #'layout-proper-name) + (warn "change in superclasses of class ~S:~% ~ ~A superclasses: ~S~% ~ ~A superclasses: ~S" - name - old-context - (map 'list #'layout-proper-name old-inherits) - context - (map 'list #'layout-proper-name inherits)) - t) - (let ((diff (mismatch old-inherits inherits))) - (when diff - (warn - "in class ~S:~% ~ + name + old-context + (map 'list #'layout-proper-name old-inherits) + context + (map 'list #'layout-proper-name inherits)) + t) + (let ((diff (mismatch old-inherits inherits))) + (when diff + (warn + "in class ~S:~% ~ ~:(~A~) definition of superclass ~S is incompatible with~% ~ ~A definition." - name - old-context - (layout-proper-name (svref old-inherits diff)) - context) - t)))) - (let ((old-length (layout-length old-layout))) - (unless (= old-length length) - (warn "change in instance length of class ~S:~% ~ + name + old-context + (layout-proper-name (svref old-inherits diff)) + context) + t)))) + (let ((old-length (layout-length old-layout))) + (unless (= old-length length) + (warn "change in instance length of class ~S:~% ~ ~A length: ~W~% ~ ~A length: ~W" - name - old-context old-length - context length) - t)) - (let ((old-nuntagged (layout-n-untagged-slots old-layout))) - (unless (= old-nuntagged nuntagged) - (warn "change in instance layout of class ~S:~% ~ + name + old-context old-length + context length) + t)) + (let ((old-nuntagged (layout-n-untagged-slots old-layout))) + (unless (= old-nuntagged nuntagged) + (warn "change in instance layout of class ~S:~% ~ ~A untagged slots: ~W~% ~ ~A untagged slots: ~W" - name - old-context old-nuntagged - context nuntagged) - t)) - (unless (= (layout-depthoid old-layout) depthoid) - (warn "change in the inheritance structure of class ~S~% ~ + name + old-context old-nuntagged + context nuntagged) + t)) + (unless (= (layout-depthoid old-layout) depthoid) + (warn "change in the inheritance structure of class ~S~% ~ between the ~A definition and the ~A definition" - name old-context context) - t)))) + name old-context context) + t)))) ;;; Require that LAYOUT data be consistent with CLASS, LENGTH, ;;; INHERITS, and DEPTHOID. (declaim (ftype (function - (layout classoid index simple-vector layout-depthoid index)) - check-layout)) + (layout classoid index simple-vector layout-depthoid index)) + check-layout)) (defun check-layout (layout classoid length inherits depthoid nuntagged) (aver (eq (layout-classoid layout) classoid)) (when (redefine-layout-warning "current" layout - "compile time" length inherits depthoid - nuntagged) + "compile time" length inherits depthoid + nuntagged) ;; Classic CMU CL had more options here. There are several reasons ;; why they might want more options which are less appropriate for ;; us: (1) It's hard to fit the classic CMU CL flexible approach @@ -428,7 +428,7 @@ ;; order to maintain the SBCL system by modifying running images. (error "The class ~S was not changed, and there's no guarantee that~@ the loaded code (which expected another layout) will work." - (layout-proper-name layout))) + (layout-proper-name layout))) (values)) ;;; a common idiom (the same as CMU CL FIND-LAYOUT) rolled up into a @@ -438,17 +438,17 @@ ;;; definitions may not have been loaded yet. This allows type tests ;;; to be loaded when the type definition hasn't been loaded yet. (declaim (ftype (function (symbol index simple-vector layout-depthoid index) - layout) - find-and-init-or-check-layout)) + layout) + find-and-init-or-check-layout)) (defun find-and-init-or-check-layout (name length inherits depthoid nuntagged) (let ((layout (find-layout name))) (init-or-check-layout layout - (or (find-classoid name nil) - (layout-classoid layout)) - length - inherits - depthoid - nuntagged))) + (or (find-classoid name nil) + (layout-classoid layout)) + length + inherits + depthoid + nuntagged))) ;;; Record LAYOUT as the layout for its class, adding it as a subtype ;;; of all superclasses. This is the operation that "installs" a @@ -463,8 +463,8 @@ (defun register-layout (layout &key (invalidate t) destruct-layout) (declare (type layout layout) (type (or layout null) destruct-layout)) (let* ((classoid (layout-classoid layout)) - (classoid-layout (classoid-layout classoid)) - (subclasses (classoid-subclasses classoid))) + (classoid-layout (classoid-layout classoid)) + (subclasses (classoid-subclasses classoid))) ;; Attempting to register ourselves with a temporary undefined ;; class placeholder is almost certainly a programmer error. (I @@ -481,24 +481,24 @@ (when classoid-layout (modify-classoid classoid) (when subclasses - (dohash (subclass subclass-layout subclasses) - (modify-classoid subclass) - (when invalidate - (invalidate-layout subclass-layout)))) + (dohash (subclass subclass-layout subclasses) + (modify-classoid subclass) + (when invalidate + (invalidate-layout subclass-layout)))) (when invalidate - (invalidate-layout classoid-layout) - (setf (classoid-subclasses classoid) nil))) + (invalidate-layout classoid-layout) + (setf (classoid-subclasses classoid) nil))) (if destruct-layout - (setf (layout-invalid destruct-layout) nil - (layout-inherits destruct-layout) (layout-inherits layout) - (layout-depthoid destruct-layout)(layout-depthoid layout) - (layout-length destruct-layout) (layout-length layout) - (layout-n-untagged-slots destruct-layout) (layout-n-untagged-slots layout) - (layout-info destruct-layout) (layout-info layout) - (classoid-layout classoid) destruct-layout) - (setf (layout-invalid layout) nil - (classoid-layout classoid) layout)) + (setf (layout-invalid destruct-layout) nil + (layout-inherits destruct-layout) (layout-inherits layout) + (layout-depthoid destruct-layout)(layout-depthoid layout) + (layout-length destruct-layout) (layout-length layout) + (layout-n-untagged-slots destruct-layout) (layout-n-untagged-slots layout) + (layout-info destruct-layout) (layout-info layout) + (classoid-layout classoid) destruct-layout) + (setf (layout-invalid layout) nil + (classoid-layout classoid) layout)) (dovector (super-layout (layout-inherits layout)) (let* ((super (layout-classoid super-layout)) @@ -517,7 +517,7 @@ ); EVAL-WHEN ;;; Arrange the inherited layouts to appear at their expected depth, -;;; ensuring that hierarchical type tests succeed. Layouts with +;;; ensuring that hierarchical type tests succeed. Layouts with ;;; DEPTHOID >= 0 (i.e. hierarchical classes) are placed first, ;;; at exactly that index in the INHERITS vector. Then, non-hierarchical ;;; layouts are placed in remaining elements. Then, any still-empty @@ -529,41 +529,41 @@ (defun order-layout-inherits (layouts) (declare (simple-vector layouts)) (let ((length (length layouts)) - (max-depth -1)) + (max-depth -1)) (dotimes (i length) (let ((depth (layout-depthoid (svref layouts i)))) - (when (> depth max-depth) - (setf max-depth depth)))) + (when (> depth max-depth) + (setf max-depth depth)))) (let* ((new-length (max (1+ max-depth) length)) - ;; KLUDGE: 0 here is the "uninitialized" element. We need - ;; to specify it explicitly for portability purposes, as - ;; elements can be read before being set [ see below, "(EQL - ;; OLD-LAYOUT 0)" ]. -- CSR, 2002-04-20 - (inherits (make-array new-length :initial-element 0))) + ;; KLUDGE: 0 here is the "uninitialized" element. We need + ;; to specify it explicitly for portability purposes, as + ;; elements can be read before being set [ see below, "(EQL + ;; OLD-LAYOUT 0)" ]. -- CSR, 2002-04-20 + (inherits (make-array new-length :initial-element 0))) (dotimes (i length) - (let* ((layout (svref layouts i)) - (depth (layout-depthoid layout))) - (unless (eql depth -1) - (let ((old-layout (svref inherits depth))) - (unless (or (eql old-layout 0) (eq old-layout layout)) - (error "layout depth conflict: ~S~%" layouts))) - (setf (svref inherits depth) layout)))) + (let* ((layout (svref layouts i)) + (depth (layout-depthoid layout))) + (unless (eql depth -1) + (let ((old-layout (svref inherits depth))) + (unless (or (eql old-layout 0) (eq old-layout layout)) + (error "layout depth conflict: ~S~%" layouts))) + (setf (svref inherits depth) layout)))) (do ((i 0 (1+ i)) - (j 0)) - ((>= i length)) - (declare (type index i j)) - (let* ((layout (svref layouts i)) - (depth (layout-depthoid layout))) - (when (eql depth -1) - (loop (when (eql (svref inherits j) 0) - (return)) - (incf j)) - (setf (svref inherits j) layout)))) + (j 0)) + ((>= i length)) + (declare (type index i j)) + (let* ((layout (svref layouts i)) + (depth (layout-depthoid layout))) + (when (eql depth -1) + (loop (when (eql (svref inherits j) 0) + (return)) + (incf j)) + (setf (svref inherits j) layout)))) (do ((i (1- new-length) (1- i))) - ((< i 0)) - (declare (type fixnum i)) - (when (eql (svref inherits i) 0) - (setf (svref inherits i) (svref inherits (1+ i))))) + ((< i 0)) + (declare (type fixnum i)) + (when (eql (svref inherits i) 0) + (setf (svref inherits i) (svref inherits (1+ i))))) inherits))) ;;;; class precedence lists @@ -575,71 +575,71 @@ ;;; the reverse ordering built so far. (defun topological-sort (objects constraints tie-breaker) (declare (list objects constraints) - (function tie-breaker)) + (function tie-breaker)) (let ((obj-info (make-hash-table :size (length objects))) - (free-objs nil) - (result nil)) + (free-objs nil) + (result nil)) (dolist (constraint constraints) (let ((obj1 (car constraint)) - (obj2 (cdr constraint))) - (let ((info2 (gethash obj2 obj-info))) - (if info2 - (incf (first info2)) - (setf (gethash obj2 obj-info) (list 1)))) - (let ((info1 (gethash obj1 obj-info))) - (if info1 - (push obj2 (rest info1)) - (setf (gethash obj1 obj-info) (list 0 obj2)))))) + (obj2 (cdr constraint))) + (let ((info2 (gethash obj2 obj-info))) + (if info2 + (incf (first info2)) + (setf (gethash obj2 obj-info) (list 1)))) + (let ((info1 (gethash obj1 obj-info))) + (if info1 + (push obj2 (rest info1)) + (setf (gethash obj1 obj-info) (list 0 obj2)))))) (dolist (obj objects) (let ((info (gethash obj obj-info))) - (when (or (not info) (zerop (first info))) - (push obj free-objs)))) + (when (or (not info) (zerop (first info))) + (push obj free-objs)))) (loop (flet ((next-result (obj) - (push obj result) - (dolist (successor (rest (gethash obj obj-info))) - (let* ((successor-info (gethash successor obj-info)) - (count (1- (first successor-info)))) - (setf (first successor-info) count) - (when (zerop count) - (push successor free-objs)))))) + (push obj result) + (dolist (successor (rest (gethash obj obj-info))) + (let* ((successor-info (gethash successor obj-info)) + (count (1- (first successor-info)))) + (setf (first successor-info) count) + (when (zerop count) + (push successor free-objs)))))) (cond ((endp free-objs) - (dohash (obj info obj-info) - (unless (zerop (first info)) - (error "Topological sort failed due to constraint on ~S." - obj))) - (return (nreverse result))) - ((endp (rest free-objs)) - (next-result (pop free-objs))) - (t - (let ((obj (funcall tie-breaker free-objs result))) - (setf free-objs (remove obj free-objs)) - (next-result obj)))))))) + (dohash (obj info obj-info) + (unless (zerop (first info)) + (error "Topological sort failed due to constraint on ~S." + obj))) + (return (nreverse result))) + ((endp (rest free-objs)) + (next-result (pop free-objs))) + (t + (let ((obj (funcall tie-breaker free-objs result))) + (setf free-objs (remove obj free-objs)) + (next-result obj)))))))) ;;; standard class precedence list computation (defun std-compute-class-precedence-list (class) (let ((classes nil) - (constraints nil)) + (constraints nil)) (labels ((note-class (class) - (unless (member class classes) - (push class classes) - (let ((superclasses (classoid-direct-superclasses class))) - (do ((prev class) - (rest superclasses (rest rest))) - ((endp rest)) - (let ((next (first rest))) - (push (cons prev next) constraints) - (setf prev next))) - (dolist (class superclasses) - (note-class class))))) - (std-cpl-tie-breaker (free-classes rev-cpl) - (dolist (class rev-cpl (first free-classes)) - (let* ((superclasses (classoid-direct-superclasses class)) - (intersection (intersection free-classes - superclasses))) - (when intersection - (return (first intersection))))))) + (unless (member class classes) + (push class classes) + (let ((superclasses (classoid-direct-superclasses class))) + (do ((prev class) + (rest superclasses (rest rest))) + ((endp rest)) + (let ((next (first rest))) + (push (cons prev next) constraints) + (setf prev next))) + (dolist (class superclasses) + (note-class class))))) + (std-cpl-tie-breaker (free-classes rev-cpl) + (dolist (class rev-cpl (first free-classes)) + (let* ((superclasses (classoid-direct-superclasses class)) + (intersection (intersection free-classes + superclasses))) + (when intersection + (return (first intersection))))))) (note-class class) (topological-sort classes constraints #'std-cpl-tie-breaker)))) @@ -648,8 +648,8 @@ ;;; An UNDEFINED-CLASSOID is a cookie we make up to stick in forward ;;; referenced layouts. Users should never see them. (def!struct (undefined-classoid - (:include classoid) - (:constructor make-undefined-classoid (name)))) + (:include classoid) + (:constructor make-undefined-classoid (name)))) ;;; BUILT-IN-CLASS is used to represent the standard classes that ;;; aren't defined with DEFSTRUCT and other specially implemented @@ -662,7 +662,7 @@ ;;; system operations (union, subtypep, etc.) should never encounter ;;; translated classes, only their translation. (def!struct (built-in-classoid (:include classoid) - (:constructor make-built-in-classoid)) + (:constructor make-built-in-classoid)) ;; the type we translate to on parsing. If NIL, then this class ;; stands on its own; or it can be set to :INITIALIZING for a period ;; during cold-load. @@ -673,38 +673,38 @@ ;;; we let CLOS handle our print functions, so that is no longer needed. ;;; Is there any need for this class any more? (def!struct (slot-classoid (:include classoid) - (:constructor nil))) + (:constructor nil))) ;;; STRUCTURE-CLASS represents what we need to know about structure ;;; classes. Non-structure "typed" defstructs are a special case, and ;;; don't have a corresponding class. (def!struct (basic-structure-classoid (:include slot-classoid) - (:constructor nil))) + (:constructor nil))) (def!struct (structure-classoid (:include basic-structure-classoid) - (:constructor make-structure-classoid)) + (:constructor make-structure-classoid)) ;; If true, a default keyword constructor for this structure. (constructor nil :type (or function null))) ;;; FUNCALLABLE-STRUCTURE-CLASS is used to represent funcallable ;;; structures, which are used to implement generic functions. (def!struct (funcallable-structure-classoid - (:include basic-structure-classoid) - (:constructor make-funcallable-structure-classoid))) + (:include basic-structure-classoid) + (:constructor make-funcallable-structure-classoid))) ;;;; classoid namespace ;;; We use an indirection to allow forward referencing of class ;;; definitions with load-time resolution. (def!struct (classoid-cell - (:constructor make-classoid-cell (name &optional classoid)) - (:make-load-form-fun (lambda (c) - `(find-classoid-cell - ',(classoid-cell-name c)))) - #-no-ansi-print-object - (:print-object (lambda (s stream) - (print-unreadable-object (s stream :type t) - (prin1 (classoid-cell-name s) stream))))) + (:constructor make-classoid-cell (name &optional classoid)) + (:make-load-form-fun (lambda (c) + `(find-classoid-cell + ',(classoid-cell-name c)))) + #-no-ansi-print-object + (:print-object (lambda (s stream) + (print-unreadable-object (s stream :type t) + (prin1 (classoid-cell-name s) stream))))) ;; Name of class we expect to find. (name nil :type symbol :read-only t) ;; Class or NIL if not yet defined. @@ -712,7 +712,7 @@ (defun find-classoid-cell (name) (or (info :type :classoid name) (setf (info :type :classoid name) - (make-classoid-cell name)))) + (make-classoid-cell name)))) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun find-classoid (name &optional (errorp t) environment) @@ -722,11 +722,11 @@ NIL is returned when no such class exists." (declare (type symbol name) (ignore environment)) (let ((res (classoid-cell-classoid (find-classoid-cell name)))) (if (or res (not errorp)) - res - (error 'simple-type-error + res + (error 'simple-type-error :datum nil :expected-type 'class - :format-control "class not yet defined:~% ~S" + :format-control "class not yet defined:~% ~S" :format-arguments (list name))))) (defun (setf find-classoid) (new-value name) #-sb-xc (declare (type (or null classoid) new-value)) @@ -736,57 +736,57 @@ NIL is returned when no such class exists." ((nil)) (:defined) (:primitive - (error "attempt to redefine :PRIMITIVE type: ~S" name)) + (error "attempt to redefine :PRIMITIVE type: ~S" name)) ((:forthcoming-defclass-type :instance) - (setf (info :type :kind name) nil - (info :type :classoid name) nil - (info :type :documentation name) nil - (info :type :compiler-layout name) nil)))) + (setf (info :type :kind name) nil + (info :type :classoid name) nil + (info :type :documentation name) nil + (info :type :compiler-layout name) nil)))) (t (ecase (info :type :kind name) ((nil)) (:forthcoming-defclass-type - ;; XXX Currently, nothing needs to be done in this - ;; case. Later, when PCL is integrated tighter into SBCL, this - ;; might need more work. - nil) + ;; XXX Currently, nothing needs to be done in this + ;; case. Later, when PCL is integrated tighter into SBCL, this + ;; might need more work. + nil) (:instance - ;; KLUDGE: The reason these clauses aren't directly parallel - ;; is that we need to use the internal CLASSOID structure - ;; ourselves, because we don't have CLASSes to work with until - ;; PCL is built. In the host, CLASSes have an approximately - ;; one-to-one correspondence with the target CLASSOIDs (as - ;; well as with the target CLASSes, modulo potential - ;; differences with respect to conditions). - #+sb-xc-host - (let ((old (class-of (find-classoid name))) - (new (class-of new-value))) - (unless (eq old new) - (bug "trying to change the metaclass of ~S from ~S to ~S in the ~ + ;; KLUDGE: The reason these clauses aren't directly parallel + ;; is that we need to use the internal CLASSOID structure + ;; ourselves, because we don't have CLASSes to work with until + ;; PCL is built. In the host, CLASSes have an approximately + ;; one-to-one correspondence with the target CLASSOIDs (as + ;; well as with the target CLASSes, modulo potential + ;; differences with respect to conditions). + #+sb-xc-host + (let ((old (class-of (find-classoid name))) + (new (class-of new-value))) + (unless (eq old new) + (bug "trying to change the metaclass of ~S from ~S to ~S in the ~ cross-compiler." - name (class-name old) (class-name new)))) - #-sb-xc-host - (let ((old (classoid-of (find-classoid name))) - (new (classoid-of new-value))) - (unless (eq old new) - (warn "changing meta-class of ~S from ~S to ~S" - name (classoid-name old) (classoid-name new))))) + name (class-name old) (class-name new)))) + #-sb-xc-host + (let ((old (classoid-of (find-classoid name))) + (new (classoid-of new-value))) + (unless (eq old new) + (warn "changing meta-class of ~S from ~S to ~S" + name (classoid-name old) (classoid-name new))))) (:primitive - (error "illegal to redefine standard type ~S" name)) + (error "illegal to redefine standard type ~S" name)) (:defined - (warn "redefining DEFTYPE type to be a class: ~S" name) - (setf (info :type :expander name) nil))) + (warn "redefining DEFTYPE type to be a class: ~S" name) + (setf (info :type :expander name) nil))) (remhash name *forward-referenced-layouts*) (%note-type-defined name) (setf (info :type :kind name) :instance) (setf (classoid-cell-classoid (find-classoid-cell name)) new-value) (unless (eq (info :type :compiler-layout name) - (classoid-layout new-value)) + (classoid-layout new-value)) (setf (info :type :compiler-layout name) (classoid-layout new-value))))) new-value) ) ; EVAL-WHEN - + ;;; Called when we are about to define NAME as a class meeting some ;;; predicate (such as a meta-class type test.) The first result is ;;; always of the desired class. The second result is any existing @@ -794,11 +794,11 @@ NIL is returned when no such class exists." (defun insured-find-classoid (name predicate constructor) (declare (type function predicate constructor)) (let* ((old (find-classoid name nil)) - (res (if (and old (funcall predicate old)) - old - (funcall constructor :name name))) - (found (or (gethash name *forward-referenced-layouts*) - (when old (classoid-layout old))))) + (res (if (and old (funcall predicate old)) + old + (funcall constructor :name name))) + (found (or (gethash name *forward-referenced-layouts*) + (when old (classoid-layout old))))) (when found (setf (layout-classoid found) res)) (values res found))) @@ -809,8 +809,8 @@ NIL is returned when no such class exists." #-sb-xc (declare (type classoid class)) (let ((name (classoid-name class))) (if (and name (eq (find-classoid name nil) class)) - name - class))) + name + class))) ;;;; CLASS type operations @@ -827,8 +827,8 @@ NIL is returned when no such class exists." (aver (not (eq class1 class2))) (let ((subclasses (classoid-subclasses class2))) (if (and subclasses (gethash class1 subclasses)) - (values t t) - (values nil t)))) + (values t t) + (values nil t)))) ;;; When finding the intersection of a sealed class and some other ;;; class (not hierarchically related) the intersection is the union @@ -836,44 +836,44 @@ NIL is returned when no such class exists." (defun sealed-class-intersection2 (sealed other) (declare (type classoid sealed other)) (let ((s-sub (classoid-subclasses sealed)) - (o-sub (classoid-subclasses other))) + (o-sub (classoid-subclasses other))) (if (and s-sub o-sub) - (collect ((res *empty-type* type-union)) - (dohash (subclass layout s-sub) - (declare (ignore layout)) - (when (gethash subclass o-sub) - (res (specifier-type subclass)))) - (res)) - *empty-type*))) + (collect ((res *empty-type* type-union)) + (dohash (subclass layout s-sub) + (declare (ignore layout)) + (when (gethash subclass o-sub) + (res (specifier-type subclass)))) + (res)) + *empty-type*))) (!define-type-method (classoid :simple-intersection2) (class1 class2) (declare (type classoid class1 class2)) (cond ((eq class1 class2) - class1) - ;; If one is a subclass of the other, then that is the - ;; intersection. - ((let ((subclasses (classoid-subclasses class2))) - (and subclasses (gethash class1 subclasses))) - class1) - ((let ((subclasses (classoid-subclasses class1))) - (and subclasses (gethash class2 subclasses))) - class2) - ;; Otherwise, we can't in general be sure that the - ;; intersection is empty, since a subclass of both might be - ;; defined. But we can eliminate it for some special cases. - ((or (basic-structure-classoid-p class1) - (basic-structure-classoid-p class2)) - ;; No subclass of both can be defined. - *empty-type*) - ((eq (classoid-state class1) :sealed) - ;; checking whether a subclass of both can be defined: - (sealed-class-intersection2 class1 class2)) - ((eq (classoid-state class2) :sealed) - ;; checking whether a subclass of both can be defined: - (sealed-class-intersection2 class2 class1)) - (t - ;; uncertain, since a subclass of both might be defined - nil))) + class1) + ;; If one is a subclass of the other, then that is the + ;; intersection. + ((let ((subclasses (classoid-subclasses class2))) + (and subclasses (gethash class1 subclasses))) + class1) + ((let ((subclasses (classoid-subclasses class1))) + (and subclasses (gethash class2 subclasses))) + class2) + ;; Otherwise, we can't in general be sure that the + ;; intersection is empty, since a subclass of both might be + ;; defined. But we can eliminate it for some special cases. + ((or (basic-structure-classoid-p class1) + (basic-structure-classoid-p class2)) + ;; No subclass of both can be defined. + *empty-type*) + ((eq (classoid-state class1) :sealed) + ;; checking whether a subclass of both can be defined: + (sealed-class-intersection2 class1 class2)) + ((eq (classoid-state class2) :sealed) + ;; checking whether a subclass of both can be defined: + (sealed-class-intersection2 class2 class1)) + (t + ;; uncertain, since a subclass of both might be defined + nil))) ;;; KLUDGE: we need this because of the need to represent ;;; intersections of two classes, even when empty at a given time, as @@ -886,7 +886,7 @@ NIL is returned when no such class exists." ;;; mixtures with other type classes. (!define-type-method (classoid :complex-subtypep-arg2) (type1 class2) (if (and (intersection-type-p type1) - (> (count-if #'classoid-p (intersection-type-types type1)) 1)) + (> (count-if #'classoid-p (intersection-type-types type1)) 1)) (values nil nil) (invoke-complex-subtypep-arg1-method type1 class2 nil t))) @@ -899,11 +899,11 @@ NIL is returned when no such class exists." ;;;; PCL stuff (def!struct (std-classoid (:include classoid) - (:constructor nil))) + (:constructor nil))) (def!struct (standard-classoid (:include std-classoid) - (:constructor make-standard-classoid))) + (:constructor make-standard-classoid))) (def!struct (random-pcl-classoid (:include std-classoid) - (:constructor make-random-pcl-classoid))) + (:constructor make-random-pcl-classoid))) ;;;; built-in classes @@ -950,7 +950,7 @@ NIL is returned when no such class exists." (setq *built-in-classes* '((t :state :read-only :translation t) - (character :enumerable t + (character :enumerable t :codes (#.sb!vm:character-widetag) :translation (character-set) :prototype-form (code-char 42)) @@ -971,7 +971,7 @@ NIL is returned when no such class exists." (function :codes (#.sb!vm:closure-header-widetag - #.sb!vm:simple-fun-header-widetag) + #.sb!vm:simple-fun-header-widetag) :state :read-only :prototype-form (function (lambda () 42))) (funcallable-instance @@ -1033,7 +1033,7 @@ NIL is returned when no such class exists." :inherits (rational real number)) (fixnum :translation (integer #.sb!xc:most-negative-fixnum - #.sb!xc:most-positive-fixnum) + #.sb!xc:most-positive-fixnum) :inherits (integer rational real number) :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag) :prototype-form 42) @@ -1069,7 +1069,7 @@ NIL is returned when no such class exists." :translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-widetag) :direct-superclasses (bit-vector simple-array) :inherits (bit-vector vector simple-array - array sequence) + array sequence) :prototype-form (make-array 0 :element-type 'bit)) (simple-array-unsigned-byte-2 :translation (simple-array (unsigned-byte 2) (*)) @@ -1243,7 +1243,7 @@ NIL is returned when no such class exists." :codes (#.sb!vm:simple-array-nil-widetag) :direct-superclasses (vector-nil simple-string) :inherits (vector-nil simple-string string vector simple-array - array sequence) + array sequence) :prototype-form (make-array 0 :element-type 'nil)) (base-string :translation base-string @@ -1256,7 +1256,7 @@ NIL is returned when no such class exists." :codes (#.sb!vm:simple-base-string-widetag) :direct-superclasses (base-string simple-string) :inherits (base-string simple-string string vector simple-array - array sequence) + array sequence) :prototype-form (make-array 0 :element-type 'base-char)) #!+sb-unicode (character-string @@ -1271,7 +1271,7 @@ NIL is returned when no such class exists." :codes (#.sb!vm:simple-character-string-widetag) :direct-superclasses (character-string simple-string) :inherits (character-string simple-string string vector simple-array - array sequence) + array sequence) :prototype-form (make-array 0 :element-type 'character)) (list :translation (or cons (member nil)) @@ -1305,54 +1305,54 @@ NIL is returned when no such class exists." (dolist (x *built-in-classes*) #-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*") (destructuring-bind - (name &key - (translation nil trans-p) - inherits - codes - enumerable - state + (name &key + (translation nil trans-p) + inherits + codes + enumerable + state depth - prototype-form - (hierarchical-p t) ; might be modified below - (direct-superclasses (if inherits - (list (car inherits)) - '(t)))) - x + prototype-form + (hierarchical-p t) ; might be modified below + (direct-superclasses (if inherits + (list (car inherits)) + '(t)))) + x (declare (ignore codes state translation prototype-form)) (let ((inherits-list (if (eq name t) - () - (cons t (reverse inherits)))) - (classoid (make-built-in-classoid - :enumerable enumerable - :name name - :translation (if trans-p :initializing nil) - :direct-superclasses - (if (eq name t) - nil - (mapcar #'find-classoid direct-superclasses))))) - (setf (info :type :kind name) #+sb-xc-host :defined #-sb-xc-host :primitive - (classoid-cell-classoid (find-classoid-cell name)) classoid) - (unless trans-p - (setf (info :type :builtin name) classoid)) - (let* ((inherits-vector - (map 'simple-vector - (lambda (x) - (let ((super-layout - (classoid-layout (find-classoid x)))) - (when (minusp (layout-depthoid super-layout)) - (setf hierarchical-p nil)) - super-layout)) - inherits-list)) - (depthoid (if hierarchical-p + () + (cons t (reverse inherits)))) + (classoid (make-built-in-classoid + :enumerable enumerable + :name name + :translation (if trans-p :initializing nil) + :direct-superclasses + (if (eq name t) + nil + (mapcar #'find-classoid direct-superclasses))))) + (setf (info :type :kind name) #+sb-xc-host :defined #-sb-xc-host :primitive + (classoid-cell-classoid (find-classoid-cell name)) classoid) + (unless trans-p + (setf (info :type :builtin name) classoid)) + (let* ((inherits-vector + (map 'simple-vector + (lambda (x) + (let ((super-layout + (classoid-layout (find-classoid x)))) + (when (minusp (layout-depthoid super-layout)) + (setf hierarchical-p nil)) + super-layout)) + inherits-list)) + (depthoid (if hierarchical-p (or depth (length inherits-vector)) -1))) - (register-layout - (find-and-init-or-check-layout name - 0 - inherits-vector - depthoid - 0) - :invalidate nil))))) + (register-layout + (find-and-init-or-check-layout name + 0 + inherits-vector + depthoid + 0) + :invalidate nil))))) (/show0 "done with loop over *BUILT-IN-CLASSES*")) ;;; Define temporary PCL STANDARD-CLASSes. These will be set up @@ -1379,24 +1379,24 @@ NIL is returned when no such class exists." ;; redefined after PCL is set up, anyway. But to play ;; it safely, we define the class with a valid INHERITS ;; vector. - (fundamental-stream (t instance stream stream)))) + (fundamental-stream (t instance stream stream)))) (/show0 "defining temporary STANDARD-CLASS") (let* ((name (first x)) - (inherits-list (second x)) - (classoid (make-standard-classoid :name name)) - (classoid-cell (find-classoid-cell name))) + (inherits-list (second x)) + (classoid (make-standard-classoid :name name)) + (classoid-cell (find-classoid-cell name))) ;; Needed to open-code the MAP, below (declare (type list inherits-list)) (setf (classoid-cell-classoid classoid-cell) classoid - (info :type :classoid name) classoid-cell - (info :type :kind name) :instance) + (info :type :classoid name) classoid-cell + (info :type :kind name) :instance) (let ((inherits (map 'simple-vector - (lambda (x) - (classoid-layout (find-classoid x))) - inherits-list))) - #-sb-xc-host (/show0 "INHERITS=..") #-sb-xc-host (/hexstr inherits) - (register-layout (find-and-init-or-check-layout name 0 inherits -1 0) - :invalidate nil)))) + (lambda (x) + (classoid-layout (find-classoid x))) + inherits-list))) + #-sb-xc-host (/show0 "INHERITS=..") #-sb-xc-host (/hexstr inherits) + (register-layout (find-and-init-or-check-layout name 0 inherits -1 0) + :invalidate nil)))) (/show0 "done defining temporary STANDARD-CLASSes")) ;;; Now that we have set up the class heterarchy, seal the sealed @@ -1414,8 +1414,8 @@ NIL is returned when no such class exists." (when (member (classoid-state classoid) '(:read-only :frozen)) ;; FIXME: This should probably be CERROR. (warn "making ~(~A~) class ~S writable" - (classoid-state classoid) - (classoid-name classoid)) + (classoid-state classoid) + (classoid-name classoid)) (setf (classoid-state classoid) nil))) ;;; Mark LAYOUT as invalid. Setting DEPTHOID -1 helps cause unsafe @@ -1425,14 +1425,14 @@ NIL is returned when no such class exists." (defun invalidate-layout (layout) (declare (type layout layout)) (setf (layout-invalid layout) t - (layout-depthoid layout) -1) + (layout-depthoid layout) -1) (let ((inherits (layout-inherits layout)) - (classoid (layout-classoid layout))) + (classoid (layout-classoid layout))) (modify-classoid classoid) (dovector (super inherits) (let ((subs (classoid-subclasses (layout-classoid super)))) - (when subs - (remhash classoid subs))))) + (when subs + (remhash classoid subs))))) (values)) ;;;; cold loading initializations @@ -1446,34 +1446,34 @@ NIL is returned when no such class exists." (dohash (name layout *forward-referenced-layouts*) (let ((class (find-classoid name nil))) (cond ((not class) - (setf (layout-classoid layout) (make-undefined-classoid name))) - ((eq (classoid-layout class) layout) - (remhash name *forward-referenced-layouts*)) - (t - ;; FIXME: ERROR? - (warn "something strange with forward layout for ~S:~% ~S" - name - layout)))))) + (setf (layout-classoid layout) (make-undefined-classoid name))) + ((eq (classoid-layout class) layout) + (remhash name *forward-referenced-layouts*)) + (t + ;; FIXME: ERROR? + (warn "something strange with forward layout for ~S:~% ~S" + name + layout)))))) (!cold-init-forms #-sb-xc-host (/show0 "about to set *BUILT-IN-CLASS-CODES*") (setq *built-in-class-codes* - (let* ((initial-element - (locally - ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for - ;; constant class names which creates fast but - ;; non-cold-loadable, non-compact code. In this - ;; context, we'd rather have compact, cold-loadable - ;; code. -- WHN 19990928 - (declare (notinline find-classoid)) - (classoid-layout (find-classoid 'random-class)))) - (res (make-array 256 :initial-element initial-element))) - (dolist (x *built-in-classes* res) - (destructuring-bind (name &key codes &allow-other-keys) - x - (let ((layout (classoid-layout (find-classoid name)))) - (dolist (code codes) - (setf (svref res code) layout))))))) + (let* ((initial-element + (locally + ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for + ;; constant class names which creates fast but + ;; non-cold-loadable, non-compact code. In this + ;; context, we'd rather have compact, cold-loadable + ;; code. -- WHN 19990928 + (declare (notinline find-classoid)) + (classoid-layout (find-classoid 'random-class)))) + (res (make-array 256 :initial-element initial-element))) + (dolist (x *built-in-classes* res) + (destructuring-bind (name &key codes &allow-other-keys) + x + (let ((layout (classoid-layout (find-classoid name)))) + (dolist (code codes) + (setf (svref res code) layout))))))) #-sb-xc-host (/show0 "done setting *BUILT-IN-CLASS-CODES*")) (!defun-from-collected-cold-init-forms !classes-cold-init) diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp index 13762a3..37721ff 100644 --- a/src/code/coerce.lisp +++ b/src/code/coerce.lisp @@ -12,20 +12,20 @@ (in-package "SB!IMPL") (macrolet ((def (name result access src-type &optional typep) - `(defun ,name (object ,@(if typep '(type) ())) - (do* ((index 0 (1+ index)) - (length (length (the ,(ecase src-type - (:list 'list) - (:vector 'vector)) - object))) - (result ,result) - (in-object object)) - ((= index length) result) - (declare (fixnum length index)) - (setf (,access result index) - ,(ecase src-type - (:list '(pop in-object)) - (:vector '(aref in-object index)))))))) + `(defun ,name (object ,@(if typep '(type) ())) + (do* ((index 0 (1+ index)) + (length (length (the ,(ecase src-type + (:list 'list) + (:vector 'vector)) + object))) + (result ,result) + (in-object object)) + ((= index length) result) + (declare (fixnum length index)) + (setf (,access result index) + ,(ecase src-type + (:list '(pop in-object)) + (:vector '(aref in-object index)))))))) (def list-to-vector* (make-sequence type length) aref :list t) @@ -35,11 +35,11 @@ (defun vector-to-list* (object) (let ((result (list nil)) - (length (length object))) + (length (length object))) (declare (fixnum length)) (do ((index 0 (1+ index)) - (splice result (cdr splice))) - ((= index length) (cdr result)) + (splice result (cdr splice))) + ((= index length) (cdr result)) (declare (fixnum index)) (rplacd splice (list (aref object index)))))) @@ -61,33 +61,33 @@ (symbol ;; ANSI lets us return ordinary errors (non-TYPE-ERRORs) here. (cond ((macro-function object) - (error "~S names a macro." object)) - ((special-operator-p object) - (error "~S is a special operator." object)) - (t (fdefinition object)))) + (error "~S names a macro." object)) + ((special-operator-p object) + (error "~S is a special operator." object)) + (t (fdefinition object)))) (list (case (first object) ((setf) - (fdefinition object)) + (fdefinition object)) ((lambda instance-lambda) - ;; FIXME: If we go to a compiler-only implementation, this can - ;; become COMPILE instead of EVAL, which seems nicer to me. - (eval `(function ,object))) + ;; FIXME: If we go to a compiler-only implementation, this can + ;; become COMPILE instead of EVAL, which seems nicer to me. + (eval `(function ,object))) (t - (error 'simple-type-error - :datum object - :expected-type '(or symbol - ;; KLUDGE: ANSI wants us to - ;; return a TYPE-ERROR here, and - ;; a TYPE-ERROR is supposed to - ;; describe the expected type, - ;; but it's not obvious how to - ;; describe the coerceable cons - ;; types, so we punt and just say - ;; CONS. -- WHN 20000503 - cons) - :format-control "~S can't be coerced to a function." - :format-arguments (list object))))))) + (error 'simple-type-error + :datum object + :expected-type '(or symbol + ;; KLUDGE: ANSI wants us to + ;; return a TYPE-ERROR here, and + ;; a TYPE-ERROR is supposed to + ;; describe the expected type, + ;; but it's not obvious how to + ;; describe the coerceable cons + ;; types, so we punt and just say + ;; CONS. -- WHN 20000503 + cons) + :format-control "~S can't be coerced to a function." + :format-arguments (list object))))))) (defun coerce-to-list (object) (etypecase object @@ -103,141 +103,141 @@ #!+sb-doc "Coerce the Object to an object of type Output-Type-Spec." (flet ((coerce-error () - (/show0 "entering COERCE-ERROR") - (error 'simple-type-error - :format-control "~S can't be converted to type ~S." - :format-arguments (list object output-type-spec) - :datum object - :expected-type output-type-spec))) + (/show0 "entering COERCE-ERROR") + (error 'simple-type-error + :format-control "~S can't be converted to type ~S." + :format-arguments (list object output-type-spec) + :datum object + :expected-type output-type-spec))) (let ((type (specifier-type output-type-spec))) (cond - ((%typep object output-type-spec) - object) - ((eq type *empty-type*) - (coerce-error)) - ((csubtypep type (specifier-type 'character)) - (character object)) - ((csubtypep type (specifier-type 'function)) - (when (and (legal-fun-name-p object) - (not (fboundp object))) - (error 'simple-type-error - :datum object - ;; FIXME: SATISFIES FBOUNDP is a kinda bizarre broken - ;; type specifier, since the set of values it describes - ;; isn't in general constant in time. Maybe we could - ;; find a better way of expressing this error? (Maybe - ;; with the UNDEFINED-FUNCTION condition?) - :expected-type '(satisfies fboundp) - :format-control "~S isn't fbound." - :format-arguments (list object))) - (when (and (symbolp object) - (sb!xc:macro-function object)) - (error 'simple-type-error - :datum object - :expected-type '(not (satisfies sb!xc:macro-function)) - :format-control "~S is a macro." - :format-arguments (list object))) - (when (and (symbolp object) - (special-operator-p object)) - (error 'simple-type-error - :datum object - :expected-type '(not (satisfies special-operator-p)) - :format-control "~S is a special operator." - :format-arguments (list object))) - (eval `#',object)) - ((numberp object) - (cond - ((csubtypep type (specifier-type 'single-float)) - (let ((res (%single-float object))) - (unless (typep res output-type-spec) - (coerce-error)) - res)) - ((csubtypep type (specifier-type 'double-float)) - (let ((res (%double-float object))) - (unless (typep res output-type-spec) - (coerce-error)) - res)) - #!+long-float - ((csubtypep type (specifier-type 'long-float)) - (let ((res (%long-float object))) - (unless (typep res output-type-spec) - (coerce-error)) - res)) - ((csubtypep type (specifier-type 'float)) - (let ((res (%single-float object))) - (unless (typep res output-type-spec) - (coerce-error)) - res)) - (t - (let ((res - (cond - ((csubtypep type (specifier-type '(complex single-float))) - (complex (%single-float (realpart object)) - (%single-float (imagpart object)))) - ((csubtypep type (specifier-type '(complex double-float))) - (complex (%double-float (realpart object)) - (%double-float (imagpart object)))) - #!+long-float - ((csubtypep type (specifier-type '(complex long-float))) - (complex (%long-float (realpart object)) - (%long-float (imagpart object)))) + ((%typep object output-type-spec) + object) + ((eq type *empty-type*) + (coerce-error)) + ((csubtypep type (specifier-type 'character)) + (character object)) + ((csubtypep type (specifier-type 'function)) + (when (and (legal-fun-name-p object) + (not (fboundp object))) + (error 'simple-type-error + :datum object + ;; FIXME: SATISFIES FBOUNDP is a kinda bizarre broken + ;; type specifier, since the set of values it describes + ;; isn't in general constant in time. Maybe we could + ;; find a better way of expressing this error? (Maybe + ;; with the UNDEFINED-FUNCTION condition?) + :expected-type '(satisfies fboundp) + :format-control "~S isn't fbound." + :format-arguments (list object))) + (when (and (symbolp object) + (sb!xc:macro-function object)) + (error 'simple-type-error + :datum object + :expected-type '(not (satisfies sb!xc:macro-function)) + :format-control "~S is a macro." + :format-arguments (list object))) + (when (and (symbolp object) + (special-operator-p object)) + (error 'simple-type-error + :datum object + :expected-type '(not (satisfies special-operator-p)) + :format-control "~S is a special operator." + :format-arguments (list object))) + (eval `#',object)) + ((numberp object) + (cond + ((csubtypep type (specifier-type 'single-float)) + (let ((res (%single-float object))) + (unless (typep res output-type-spec) + (coerce-error)) + res)) + ((csubtypep type (specifier-type 'double-float)) + (let ((res (%double-float object))) + (unless (typep res output-type-spec) + (coerce-error)) + res)) + #!+long-float + ((csubtypep type (specifier-type 'long-float)) + (let ((res (%long-float object))) + (unless (typep res output-type-spec) + (coerce-error)) + res)) + ((csubtypep type (specifier-type 'float)) + (let ((res (%single-float object))) + (unless (typep res output-type-spec) + (coerce-error)) + res)) + (t + (let ((res + (cond + ((csubtypep type (specifier-type '(complex single-float))) + (complex (%single-float (realpart object)) + (%single-float (imagpart object)))) + ((csubtypep type (specifier-type '(complex double-float))) + (complex (%double-float (realpart object)) + (%double-float (imagpart object)))) + #!+long-float + ((csubtypep type (specifier-type '(complex long-float))) + (complex (%long-float (realpart object)) + (%long-float (imagpart object)))) ((csubtypep type (specifier-type '(complex float))) (complex (%single-float (realpart object)) (%single-float (imagpart object)))) - ((and (typep object 'rational) - (csubtypep type (specifier-type '(complex float)))) - ;; Perhaps somewhat surprisingly, ANSI specifies - ;; that (COERCE FOO 'FLOAT) is a SINGLE-FLOAT, - ;; not dispatching on - ;; *READ-DEFAULT-FLOAT-FORMAT*. By analogy, we - ;; do the same for complex numbers. -- CSR, - ;; 2002-08-06 - (complex (%single-float object))) - ((csubtypep type (specifier-type 'complex)) - (complex object)) - (t - (coerce-error))))) - ;; If RES has the wrong type, that means that rule of - ;; canonical representation for complex rationals was - ;; invoked. According to the Hyperspec, (coerce 7/2 - ;; 'complex) returns 7/2. Thus, if the object was a - ;; rational, there is no error here. - (unless (or (typep res output-type-spec) - (rationalp object)) - (coerce-error)) - res)))) - ((csubtypep type (specifier-type 'list)) - (if (vectorp object) - (cond - ((type= type (specifier-type 'list)) - (vector-to-list* object)) - ((type= type (specifier-type 'null)) - (if (= (length object) 0) - 'nil - (sequence-type-length-mismatch-error type - (length object)))) - ((cons-type-p type) - (multiple-value-bind (min exactp) - (sb!kernel::cons-type-length-info type) - (let ((length (length object))) - (if exactp - (unless (= length min) - (sequence-type-length-mismatch-error type length)) - (unless (>= length min) - (sequence-type-length-mismatch-error type length))) - (vector-to-list* object)))) - (t (sequence-type-too-hairy (type-specifier type)))) - (coerce-error))) - ((csubtypep type (specifier-type 'vector)) - (typecase object - ;; FOO-TO-VECTOR* go through MAKE-SEQUENCE, so length - ;; errors are caught there. -- CSR, 2002-10-18 - (list (list-to-vector* object output-type-spec)) - (vector (vector-to-vector* object output-type-spec)) - (t - (coerce-error)))) - (t - (coerce-error)))))) + ((and (typep object 'rational) + (csubtypep type (specifier-type '(complex float)))) + ;; Perhaps somewhat surprisingly, ANSI specifies + ;; that (COERCE FOO 'FLOAT) is a SINGLE-FLOAT, + ;; not dispatching on + ;; *READ-DEFAULT-FLOAT-FORMAT*. By analogy, we + ;; do the same for complex numbers. -- CSR, + ;; 2002-08-06 + (complex (%single-float object))) + ((csubtypep type (specifier-type 'complex)) + (complex object)) + (t + (coerce-error))))) + ;; If RES has the wrong type, that means that rule of + ;; canonical representation for complex rationals was + ;; invoked. According to the Hyperspec, (coerce 7/2 + ;; 'complex) returns 7/2. Thus, if the object was a + ;; rational, there is no error here. + (unless (or (typep res output-type-spec) + (rationalp object)) + (coerce-error)) + res)))) + ((csubtypep type (specifier-type 'list)) + (if (vectorp object) + (cond + ((type= type (specifier-type 'list)) + (vector-to-list* object)) + ((type= type (specifier-type 'null)) + (if (= (length object) 0) + 'nil + (sequence-type-length-mismatch-error type + (length object)))) + ((cons-type-p type) + (multiple-value-bind (min exactp) + (sb!kernel::cons-type-length-info type) + (let ((length (length object))) + (if exactp + (unless (= length min) + (sequence-type-length-mismatch-error type length)) + (unless (>= length min) + (sequence-type-length-mismatch-error type length))) + (vector-to-list* object)))) + (t (sequence-type-too-hairy (type-specifier type)))) + (coerce-error))) + ((csubtypep type (specifier-type 'vector)) + (typecase object + ;; FOO-TO-VECTOR* go through MAKE-SEQUENCE, so length + ;; errors are caught there. -- CSR, 2002-10-18 + (list (list-to-vector* object output-type-spec)) + (vector (vector-to-vector* object output-type-spec)) + (t + (coerce-error)))) + (t + (coerce-error)))))) ;;; new version, which seems as though it should be better, but which ;;; does not yet work @@ -247,62 +247,62 @@ "Coerces the Object to an object of type Output-Type-Spec." (flet ((coerce-error () (error 'simple-type-error - :format-control "~S can't be converted to type ~S." - :format-arguments (list object output-type-spec))) - (check-result (result) - #!+high-security (aver (typep result output-type-spec)) - result)) + :format-control "~S can't be converted to type ~S." + :format-arguments (list object output-type-spec))) + (check-result (result) + #!+high-security (aver (typep result output-type-spec)) + result)) (let ((type (specifier-type output-type-spec))) (cond - ((%typep object output-type-spec) - object) - ((eq type *empty-type*) - (coerce-error)) - ((csubtypep type (specifier-type 'character)) - (character object)) - ((csubtypep type (specifier-type 'function)) - (coerce-to-fun object)) - ((numberp object) - (let ((res - (cond - ((csubtypep type (specifier-type 'single-float)) - (%single-float object)) - ((csubtypep type (specifier-type 'double-float)) - (%double-float object)) - #!+long-float - ((csubtypep type (specifier-type 'long-float)) - (%long-float object)) - ((csubtypep type (specifier-type 'float)) - (%single-float object)) - ((csubtypep type (specifier-type '(complex single-float))) - (complex (%single-float (realpart object)) - (%single-float (imagpart object)))) - ((csubtypep type (specifier-type '(complex double-float))) - (complex (%double-float (realpart object)) - (%double-float (imagpart object)))) - #!+long-float - ((csubtypep type (specifier-type '(complex long-float))) - (complex (%long-float (realpart object)) - (%long-float (imagpart object)))) - ((csubtypep type (specifier-type 'complex)) - (complex object)) - (t - (coerce-error))))) - ;; If RES has the wrong type, that means that rule of - ;; canonical representation for complex rationals was - ;; invoked. According to the ANSI spec, (COERCE 7/2 - ;; 'COMPLEX) returns 7/2. Thus, if the object was a - ;; rational, there is no error here. - (unless (or (typep res output-type-spec) (rationalp object)) - (coerce-error)) - res)) - ((csubtypep type (specifier-type 'list)) - (coerce-to-list object)) - ((csubtypep type (specifier-type 'string)) - (check-result (coerce-to-simple-string object))) - ((csubtypep type (specifier-type 'bit-vector)) - (check-result (coerce-to-bit-vector object))) - ((csubtypep type (specifier-type 'vector)) - (check-result (coerce-to-vector object output-type-spec))) - (t - (coerce-error)))))) + ((%typep object output-type-spec) + object) + ((eq type *empty-type*) + (coerce-error)) + ((csubtypep type (specifier-type 'character)) + (character object)) + ((csubtypep type (specifier-type 'function)) + (coerce-to-fun object)) + ((numberp object) + (let ((res + (cond + ((csubtypep type (specifier-type 'single-float)) + (%single-float object)) + ((csubtypep type (specifier-type 'double-float)) + (%double-float object)) + #!+long-float + ((csubtypep type (specifier-type 'long-float)) + (%long-float object)) + ((csubtypep type (specifier-type 'float)) + (%single-float object)) + ((csubtypep type (specifier-type '(complex single-float))) + (complex (%single-float (realpart object)) + (%single-float (imagpart object)))) + ((csubtypep type (specifier-type '(complex double-float))) + (complex (%double-float (realpart object)) + (%double-float (imagpart object)))) + #!+long-float + ((csubtypep type (specifier-type '(complex long-float))) + (complex (%long-float (realpart object)) + (%long-float (imagpart object)))) + ((csubtypep type (specifier-type 'complex)) + (complex object)) + (t + (coerce-error))))) + ;; If RES has the wrong type, that means that rule of + ;; canonical representation for complex rationals was + ;; invoked. According to the ANSI spec, (COERCE 7/2 + ;; 'COMPLEX) returns 7/2. Thus, if the object was a + ;; rational, there is no error here. + (unless (or (typep res output-type-spec) (rationalp object)) + (coerce-error)) + res)) + ((csubtypep type (specifier-type 'list)) + (coerce-to-list object)) + ((csubtypep type (specifier-type 'string)) + (check-result (coerce-to-simple-string object))) + ((csubtypep type (specifier-type 'bit-vector)) + (check-result (coerce-to-bit-vector object))) + ((csubtypep type (specifier-type 'vector)) + (check-result (coerce-to-vector object output-type-spec))) + (t + (coerce-error)))))) diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp index 5dbdf5f..4295160 100644 --- a/src/code/cold-error.lisp +++ b/src/code/cold-error.lisp @@ -23,20 +23,20 @@ (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked before any signalling is done." (let ((condition (coerce-to-condition datum - arguments - 'simple-condition - 'signal)) - (*handler-clusters* *handler-clusters*) - (old-bos *break-on-signals*)) + arguments + 'simple-condition + 'signal)) + (*handler-clusters* *handler-clusters*) + (old-bos *break-on-signals*)) (restart-case - (when (typep condition *break-on-signals*) - (let ((*break-on-signals* nil)) - (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* ~ + (when (typep condition *break-on-signals*) + (let ((*break-on-signals* nil)) + (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* ~ (now rebound to NIL)." - condition))) + condition))) ;; Give the user a chance to unset *BREAK-ON-SIGNALS* on the ;; way out. - ;; + ;; ;; (e.g.: Consider a long compilation. After a failed compile ;; the user sets *BREAK-ON-SIGNALS* to T, and select the ;; RECOMPILE restart. Once the user diagnoses and fixes the @@ -44,35 +44,35 @@ ;; he's entered the *BREAK-ON-SIGNALS* hell with no escape, ;; unless we provide this restart.) (reassign (new-value) - :report - "Return from BREAK and assign a new value to *BREAK-ON-SIGNALS*." - :interactive - (lambda () - (let (new-value) - (loop - (format *query-io* - "Enter new value for *BREAK-ON-SIGNALS*. ~ + :report + "Return from BREAK and assign a new value to *BREAK-ON-SIGNALS*." + :interactive + (lambda () + (let (new-value) + (loop + (format *query-io* + "Enter new value for *BREAK-ON-SIGNALS*. ~ Current value is ~S.~%~ > " - old-bos) - (force-output *query-io*) - (let ((*break-on-signals* nil)) - (setf new-value (eval (read *query-io*))) - (if (typep new-value 'type-specifier) - (return) - (format *query-io* - "~S is not a valid value for *BREAK-ON-SIGNALS* ~ + old-bos) + (force-output *query-io*) + (let ((*break-on-signals* nil)) + (setf new-value (eval (read *query-io*))) + (if (typep new-value 'type-specifier) + (return) + (format *query-io* + "~S is not a valid value for *BREAK-ON-SIGNALS* ~ (must be a type-specifier).~%" - new-value)))) - (list new-value))) - (setf *break-on-signals* new-value))) + new-value)))) + (list new-value))) + (setf *break-on-signals* new-value))) (loop (unless *handler-clusters* - (return)) + (return)) (let ((cluster (pop *handler-clusters*))) - (dolist (handler cluster) - (when (typep condition (car handler)) - (funcall (cdr handler) condition))))) + (dolist (handler cluster) + (when (typep condition (car handler)) + (funcall (cdr handler) condition))))) nil)) ;;; a shared idiom in ERROR, CERROR, and BREAK: The user probably @@ -82,7 +82,7 @@ (eval-when (:compile-toplevel :execute) (defmacro-mundanely maybe-find-stack-top-hint () `(or sb!debug:*stack-top-hint* - (nth-value 1 (find-caller-name-and-frame))))) + (nth-value 1 (find-caller-name-and-frame))))) (defun error (datum &rest arguments) #!+sb-doc @@ -93,33 +93,33 @@ (/show0 "cold-printing ERROR arguments one by one..") #!+sb-show (dolist (argument arguments) - (sb!impl::cold-print argument)) + (sb!impl::cold-print argument)) (/show0 "done cold-printing ERROR arguments") (infinite-error-protect (let ((condition (coerce-to-condition datum arguments - 'simple-error 'error)) - (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint))) + 'simple-error 'error)) + (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint))) (/show0 "done coercing DATUM to CONDITION") (let ((sb!debug:*stack-top-hint* nil)) - (/show0 "signalling CONDITION from within ERROR") - (signal condition)) + (/show0 "signalling CONDITION from within ERROR") + (signal condition)) (/show0 "done signalling CONDITION within ERROR") (invoke-debugger condition)))) (defun cerror (continue-string datum &rest arguments) (infinite-error-protect (with-simple-restart - (continue "~A" (apply #'format nil continue-string arguments)) + (continue "~A" (apply #'format nil continue-string arguments)) (let ((condition (coerce-to-condition datum - arguments - 'simple-error - 'cerror)) - (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint))) - (with-condition-restarts condition (list (find-restart 'continue)) - (let ((sb!debug:*stack-top-hint* nil)) - (signal condition)) - (invoke-debugger condition))))) + arguments + 'simple-error + 'cerror)) + (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint))) + (with-condition-restarts condition (list (find-restart 'continue)) + (let ((sb!debug:*stack-top-hint* nil)) + (signal condition)) + (invoke-debugger condition))))) nil) ;;; like BREAK, but without rebinding *DEBUGGER-HOOK* to NIL, so that @@ -131,8 +131,8 @@ (infinite-error-protect (with-simple-restart (continue "Return from ~S." what) (let ((sb!debug:*stack-top-hint* (maybe-find-stack-top-hint))) - (invoke-debugger - (coerce-to-condition datum arguments 'simple-condition what))))) + (invoke-debugger + (coerce-to-condition datum arguments 'simple-condition what))))) nil) (defun break (&optional (datum "break") &rest arguments) @@ -141,7 +141,7 @@ of condition handling occurring." (let ((*debugger-hook* nil)) ; as specifically required by ANSI (apply #'%break 'break datum arguments))) - + (defun warn (datum &rest arguments) #!+sb-doc "Warn about a situation by signalling a condition formed by DATUM and @@ -155,29 +155,29 @@ ;; -- WHN 19991009 (if (not *cold-init-complete-p*) (progn - (/show0 "ignoring WARN in cold init, arguments=..") - #!+sb-show (dolist (argument arguments) - (sb!impl::cold-print argument))) + (/show0 "ignoring WARN in cold init, arguments=..") + #!+sb-show (dolist (argument arguments) + (sb!impl::cold-print argument))) (infinite-error-protect (/show0 "doing COERCE-TO-CONDITION") (let ((condition (coerce-to-condition datum arguments - 'simple-warning 'warn))) - (/show0 "back from COERCE-TO-CONDITION, doing ENFORCE-TYPE") - (enforce-type condition warning) - (/show0 "back from ENFORCE-TYPE, doing RESTART-CASE MUFFLE-WARNING") - (restart-case (signal condition) - (muffle-warning () - :report "Skip warning." - (return-from warn nil))) - (/show0 "back from RESTART-CASE MUFFLE-WARNING (i.e. normal return)") + 'simple-warning 'warn))) + (/show0 "back from COERCE-TO-CONDITION, doing ENFORCE-TYPE") + (enforce-type condition warning) + (/show0 "back from ENFORCE-TYPE, doing RESTART-CASE MUFFLE-WARNING") + (restart-case (signal condition) + (muffle-warning () + :report "Skip warning." + (return-from warn nil))) + (/show0 "back from RESTART-CASE MUFFLE-WARNING (i.e. normal return)") - (let ((badness (etypecase condition - (style-warning 'style-warning) - (warning 'warning)))) - (/show0 "got BADNESS, calling FORMAT") - (format *error-output* - "~&~@<~S: ~3i~:_~A~:>~%" - badness - condition) - (/show0 "back from FORMAT, voila!"))))) + (let ((badness (etypecase condition + (style-warning 'style-warning) + (warning 'warning)))) + (/show0 "got BADNESS, calling FORMAT") + (format *error-output* + "~&~@<~S: ~3i~:_~A~:>~%" + badness + condition) + (/show0 "back from FORMAT, voila!"))))) nil) diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 8e332ce..b80bfd8 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -29,21 +29,21 @@ (nil) (dolist (package (list-all-packages)) (do-symbols (symbol package) - (let ((name (symbol-name symbol))) - (when (or (string= name "!" :end1 1 :end2 1) - (and (>= (length name) 2) - (string= name "*!" :end1 2 :end2 2))) - (/show0 "uninterning cold-init-only symbol..") - (/primitive-print name) - ;; FIXME: Is this (FIRST (LAST *INFO-ENVIRONMENT*)) really - ;; meant to be an idiom to use? Is there a more obvious - ;; name for this? [e.g. (GLOBAL-ENVIRONMENT)?] - (do-info ((first (last *info-environment*)) - :name entry :class class :type type) - (when (eq entry symbol) - (clear-info class type entry))) - (unintern symbol package) - (setf any-changes? t))))) + (let ((name (symbol-name symbol))) + (when (or (string= name "!" :end1 1 :end2 1) + (and (>= (length name) 2) + (string= name "*!" :end1 2 :end2 2))) + (/show0 "uninterning cold-init-only symbol..") + (/primitive-print name) + ;; FIXME: Is this (FIRST (LAST *INFO-ENVIRONMENT*)) really + ;; meant to be an idiom to use? Is there a more obvious + ;; name for this? [e.g. (GLOBAL-ENVIRONMENT)?] + (do-info ((first (last *info-environment*)) + :name entry :class class :type type) + (when (eq entry symbol) + (clear-info class type entry))) + (unintern symbol package) + (setf any-changes? t))))) (unless any-changes? (return)))) @@ -93,10 +93,10 @@ ;; *TYPE-SYSTEM-INITIALIZED-WHEN-BOUND* so that it doesn't need to ;; be explicitly set in order to be meaningful. (setf *after-gc-hooks* nil - *gc-inhibit* 1 - *need-to-collect-garbage* nil - sb!unix::*interrupts-enabled* t - sb!unix::*interrupt-pending* nil + *gc-inhibit* 1 + *need-to-collect-garbage* nil + sb!unix::*interrupts-enabled* t + sb!unix::*interrupt-pending* nil *break-on-signals* nil *maximum-error-depth* 10 *current-error-depth* 0 @@ -114,7 +114,7 @@ (show-and-call !early-package-cold-init) (show-and-call !package-cold-init) - + ;; All sorts of things need INFO and/or (SETF INFO). (/show0 "about to SHOW-AND-CALL !GLOBALDB-COLD-INIT") (show-and-call !globaldb-cold-init) @@ -144,7 +144,7 @@ (/show0 "back from !POLICY-COLD-INIT-OR-RESANIFY") (show-and-call !early-proclaim-cold-init) - + ;; KLUDGE: Why are fixups mixed up with toplevel forms? Couldn't ;; fixups be done separately? Wouldn't that be clearer and better? ;; -- WHN 19991204 @@ -154,47 +154,47 @@ (/show0 "about to calculate (LENGTH *!REVERSED-COLD-TOPLEVELS*)") (/show0 "(LENGTH *!REVERSED-COLD-TOPLEVELS*)=..") #!+sb-show (let ((r-c-tl-length (length *!reversed-cold-toplevels*))) - (/show0 "(length calculated..)") - (let ((hexstr (hexstr r-c-tl-length))) - (/show0 "(hexstr calculated..)") - (/primitive-print hexstr))) + (/show0 "(length calculated..)") + (let ((hexstr (hexstr r-c-tl-length))) + (/show0 "(hexstr calculated..)") + (/primitive-print hexstr))) (let (#!+sb-show (index-in-cold-toplevels 0)) #!+sb-show (declare (type fixnum index-in-cold-toplevels)) (dolist (toplevel-thing (prog1 - (nreverse *!reversed-cold-toplevels*) - ;; (Now that we've NREVERSEd it, it's - ;; somewhat scrambled, so keep anyone - ;; else from trying to get at it.) - (makunbound '*!reversed-cold-toplevels*))) + (nreverse *!reversed-cold-toplevels*) + ;; (Now that we've NREVERSEd it, it's + ;; somewhat scrambled, so keep anyone + ;; else from trying to get at it.) + (makunbound '*!reversed-cold-toplevels*))) #!+sb-show (when (zerop (mod index-in-cold-toplevels 1024)) - (/show0 "INDEX-IN-COLD-TOPLEVELS=..") - (/hexstr index-in-cold-toplevels)) + (/show0 "INDEX-IN-COLD-TOPLEVELS=..") + (/hexstr index-in-cold-toplevels)) #!+sb-show (setf index-in-cold-toplevels - (the fixnum (1+ index-in-cold-toplevels))) + (the fixnum (1+ index-in-cold-toplevels))) (typecase toplevel-thing - (function - (funcall toplevel-thing)) - (cons - (case (first toplevel-thing) - (:load-time-value - (setf (svref *!load-time-values* (third toplevel-thing)) - (funcall (second toplevel-thing)))) - (:load-time-value-fixup - (setf (sap-ref-word (second toplevel-thing) 0) - (get-lisp-obj-address - (svref *!load-time-values* (third toplevel-thing))))) - #!+(and (or x86 x86-64) gencgc) - (:load-time-code-fixup - (sb!vm::!envector-load-time-code-fixup (second toplevel-thing) - (third toplevel-thing) - (fourth toplevel-thing) - (fifth toplevel-thing))) - (t - (!cold-lose "bogus fixup code in *!REVERSED-COLD-TOPLEVELS*")))) - (t (!cold-lose "bogus function in *!REVERSED-COLD-TOPLEVELS*"))))) + (function + (funcall toplevel-thing)) + (cons + (case (first toplevel-thing) + (:load-time-value + (setf (svref *!load-time-values* (third toplevel-thing)) + (funcall (second toplevel-thing)))) + (:load-time-value-fixup + (setf (sap-ref-word (second toplevel-thing) 0) + (get-lisp-obj-address + (svref *!load-time-values* (third toplevel-thing))))) + #!+(and (or x86 x86-64) gencgc) + (:load-time-code-fixup + (sb!vm::!envector-load-time-code-fixup (second toplevel-thing) + (third toplevel-thing) + (fourth toplevel-thing) + (fifth toplevel-thing))) + (t + (!cold-lose "bogus fixup code in *!REVERSED-COLD-TOPLEVELS*")))) + (t (!cold-lose "bogus function in *!REVERSED-COLD-TOPLEVELS*"))))) (/show0 "done with loop over cold toplevel forms and fixups") ;; Set sane values again, so that the user sees sane values instead @@ -210,7 +210,7 @@ (show-and-call !fixup-type-cold-init) ;; run the PROCLAIMs. (show-and-call !late-proclaim-cold-init) - + (show-and-call os-cold-init-or-reinit) (show-and-call thread-init-or-reinit) @@ -285,7 +285,7 @@ UNIX-like systems, UNIX-STATUS is used as the status code." (defun reinit () (without-interrupts (without-gcing - (os-cold-init-or-reinit) + (os-cold-init-or-reinit) (thread-init-or-reinit) (stream-reinit) (signal-cold-init-or-reinit) @@ -316,20 +316,20 @@ UNIX-like systems, UNIX-STATUS is used as the status code." (defun hexstr (thing) (/noshow0 "entering HEXSTR") (let ((addr (get-lisp-obj-address thing)) - (str (make-string 10 :element-type 'base-char))) + (str (make-string 10 :element-type 'base-char))) (/noshow0 "ADDR and STR calculated") (setf (char str 0) #\0 - (char str 1) #\x) + (char str 1) #\x) (/noshow0 "CHARs 0 and 1 set") (dotimes (i 8) (/noshow0 "at head of DOTIMES loop") (let* ((nibble (ldb (byte 4 0) addr)) - (chr (char "0123456789abcdef" nibble))) - (declare (type (unsigned-byte 4) nibble) - (base-char chr)) - (/noshow0 "NIBBLE and CHR calculated") - (setf (char str (- 9 i)) chr - addr (ash addr -4)))) + (chr (char "0123456789abcdef" nibble))) + (declare (type (unsigned-byte 4) nibble) + (base-char chr)) + (/noshow0 "NIBBLE and CHR calculated") + (setf (char str (- 9 i)) chr + addr (ash addr -4)))) str)) #!+sb-show @@ -338,10 +338,10 @@ UNIX-like systems, UNIX-STATUS is used as the status code." (simple-string (sb!sys:%primitive print x)) (symbol (sb!sys:%primitive print (symbol-name x))) (list (let ((count 0)) - (sb!sys:%primitive print "list:") - (dolist (i x) - (when (>= (incf count) 4) - (sb!sys:%primitive print "...") - (return)) - (cold-print i)))) + (sb!sys:%primitive print "list:") + (dolist (i x) + (when (>= (incf count) 4) + (sb!sys:%primitive print "...") + (return)) + (cold-print i)))) (t (sb!sys:%primitive print (hexstr x))))) diff --git a/src/code/condition.lisp b/src/code/condition.lisp index e599ccb..e704d5e 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -18,7 +18,7 @@ ;;; Signalling an error when trying to print an error condition is ;;; generally a PITA, so whatever the failure encountered when ;;; wondering about FILE-POSITION within a condition printer, 'tis -;;; better silently to give up than to try to complain. +;;; better silently to give up than to try to complain. (defun file-position-or-nil-for-error (stream &optional (pos nil posp)) ;; Arguably FILE-POSITION shouldn't be signalling errors at all; but ;; "NIL if this cannot be determined" in the ANSI spec doesn't seem @@ -42,7 +42,7 @@ (/show0 "condition.lisp 24") (def!struct (condition-classoid (:include slot-classoid) - (:constructor make-condition-classoid)) + (:constructor make-condition-classoid)) ;; list of CONDITION-SLOT structures for the direct slots of this ;; class (slots nil :type list) @@ -104,60 +104,60 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (/show0 "condition.lisp 103") (let ((condition-class (locally - ;; KLUDGE: There's a DEFTRANSFORM - ;; FIND-CLASSOID for constant class names - ;; which creates fast but - ;; non-cold-loadable, non-compact code. In - ;; this context, we'd rather have compact, - ;; cold-loadable code. -- WHN 19990928 - (declare (notinline find-classoid)) - (find-classoid 'condition)))) + ;; KLUDGE: There's a DEFTRANSFORM + ;; FIND-CLASSOID for constant class names + ;; which creates fast but + ;; non-cold-loadable, non-compact code. In + ;; this context, we'd rather have compact, + ;; cold-loadable code. -- WHN 19990928 + (declare (notinline find-classoid)) + (find-classoid 'condition)))) (setf (condition-classoid-cpl condition-class) - (list condition-class))) + (list condition-class))) (/show0 "condition.lisp 103")) (setf (condition-classoid-report (locally - ;; KLUDGE: There's a DEFTRANSFORM - ;; FIND-CLASSOID for constant class - ;; names which creates fast but - ;; non-cold-loadable, non-compact - ;; code. In this context, we'd - ;; rather have compact, - ;; cold-loadable code. -- WHN - ;; 19990928 - (declare (notinline find-classoid)) - (find-classoid 'condition))) + ;; KLUDGE: There's a DEFTRANSFORM + ;; FIND-CLASSOID for constant class + ;; names which creates fast but + ;; non-cold-loadable, non-compact + ;; code. In this context, we'd + ;; rather have compact, + ;; cold-loadable code. -- WHN + ;; 19990928 + (declare (notinline find-classoid)) + (find-classoid 'condition))) (lambda (cond stream) - (format stream "Condition ~S was signalled." (type-of cond)))) + (format stream "Condition ~S was signalled." (type-of cond)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun find-condition-layout (name parent-types) (let* ((cpl (remove-duplicates - (reverse - (reduce #'append - (mapcar (lambda (x) - (condition-classoid-cpl - (find-classoid x))) - parent-types))))) - (cond-layout (info :type :compiler-layout 'condition)) - (olayout (info :type :compiler-layout name)) - ;; FIXME: Does this do the right thing in case of multiple - ;; inheritance? A quick look at DEFINE-CONDITION didn't make - ;; it obvious what ANSI intends to be done in the case of - ;; multiple inheritance, so it's not actually clear what the - ;; right thing is.. - (new-inherits - (order-layout-inherits (concatenate 'simple-vector - (layout-inherits cond-layout) - (mapcar #'classoid-layout cpl))))) + (reverse + (reduce #'append + (mapcar (lambda (x) + (condition-classoid-cpl + (find-classoid x))) + parent-types))))) + (cond-layout (info :type :compiler-layout 'condition)) + (olayout (info :type :compiler-layout name)) + ;; FIXME: Does this do the right thing in case of multiple + ;; inheritance? A quick look at DEFINE-CONDITION didn't make + ;; it obvious what ANSI intends to be done in the case of + ;; multiple inheritance, so it's not actually clear what the + ;; right thing is.. + (new-inherits + (order-layout-inherits (concatenate 'simple-vector + (layout-inherits cond-layout) + (mapcar #'classoid-layout cpl))))) (if (and olayout - (not (mismatch (layout-inherits olayout) new-inherits))) - olayout - (make-layout :classoid (make-undefined-classoid name) - :inherits new-inherits - :depthoid -1 - :length (layout-length cond-layout))))) + (not (mismatch (layout-inherits olayout) new-inherits))) + olayout + (make-layout :classoid (make-undefined-classoid name) + :inherits new-inherits + :depthoid -1 + :length (layout-length cond-layout))))) ) ; EVAL-WHEN @@ -176,10 +176,10 @@ ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of ;; superclasses in define-condition call! (dolist (class (condition-classoid-cpl (classoid-of x)) - (error "no REPORT? shouldn't happen!")) - (let ((report (condition-classoid-report class))) - (when report - (return (funcall report x stream))))))) + (error "no REPORT? shouldn't happen!")) + (let ((report (condition-classoid-report class))) + (when report + (return (funcall report x stream))))))) ;;;; slots of CONDITION objects @@ -187,38 +187,38 @@ (defun find-slot-default (class slot) (let ((initargs (condition-slot-initargs slot)) - (cpl (condition-classoid-cpl class))) + (cpl (condition-classoid-cpl class))) (dolist (class cpl) (let ((default-initargs (condition-classoid-default-initargs class))) - (dolist (initarg initargs) - (let ((val (getf default-initargs initarg *empty-condition-slot*))) - (unless (eq val *empty-condition-slot*) - (return-from find-slot-default - (if (functionp val) - (funcall val) - val))))))) + (dolist (initarg initargs) + (let ((val (getf default-initargs initarg *empty-condition-slot*))) + (unless (eq val *empty-condition-slot*) + (return-from find-slot-default + (if (functionp val) + (funcall val) + val))))))) (if (condition-slot-initform-p slot) - (let ((initform (condition-slot-initform slot))) - (if (functionp initform) - (funcall initform) - initform)) - (error "unbound condition slot: ~S" (condition-slot-name slot))))) + (let ((initform (condition-slot-initform slot))) + (if (functionp initform) + (funcall initform) + initform)) + (error "unbound condition slot: ~S" (condition-slot-name slot))))) (defun find-condition-class-slot (condition-class slot-name) (dolist (sclass - (condition-classoid-cpl condition-class) - (error "There is no slot named ~S in ~S." - slot-name condition-class)) + (condition-classoid-cpl condition-class) + (error "There is no slot named ~S in ~S." + slot-name condition-class)) (dolist (slot (condition-classoid-slots sclass)) (when (eq (condition-slot-name slot) slot-name) - (return-from find-condition-class-slot slot))))) + (return-from find-condition-class-slot slot))))) (defun condition-writer-function (condition new-value name) (dolist (cslot (condition-classoid-class-slots - (layout-classoid (%instance-layout condition))) - (setf (getf (condition-assigned-slots condition) name) - new-value)) + (layout-classoid (%instance-layout condition))) + (setf (getf (condition-assigned-slots condition) name) + new-value)) (when (eq (condition-slot-name cslot) name) (return (setf (car (condition-slot-cell cslot)) new-value))))) @@ -226,25 +226,25 @@ (let ((class (layout-classoid (%instance-layout condition)))) (dolist (cslot (condition-classoid-class-slots class)) (when (eq (condition-slot-name cslot) name) - (return-from condition-reader-function - (car (condition-slot-cell cslot))))) + (return-from condition-reader-function + (car (condition-slot-cell cslot))))) (let ((val (getf (condition-assigned-slots condition) name - *empty-condition-slot*))) + *empty-condition-slot*))) (if (eq val *empty-condition-slot*) - (let ((actual-initargs (condition-actual-initargs condition)) - (slot (find-condition-class-slot class name))) + (let ((actual-initargs (condition-actual-initargs condition)) + (slot (find-condition-class-slot class name))) (unless slot - (error "missing slot ~S of ~S" name condition)) - (do ((initargs actual-initargs (cddr initargs))) - ((endp initargs) - (setf (getf (condition-assigned-slots condition) name) - (find-slot-default class slot))) - (when (member (car initargs) (condition-slot-initargs slot)) - (return-from condition-reader-function - (setf (getf (condition-assigned-slots condition) - name) - (cadr initargs)))))) - val)))) + (error "missing slot ~S of ~S" name condition)) + (do ((initargs actual-initargs (cddr initargs))) + ((endp initargs) + (setf (getf (condition-assigned-slots condition) name) + (find-slot-default class slot))) + (when (member (car initargs) (condition-slot-initargs slot)) + (return-from condition-reader-function + (setf (getf (condition-assigned-slots condition) + name) + (cadr initargs)))))) + val)))) ;;;; MAKE-CONDITION @@ -254,91 +254,91 @@ ;; Note: ANSI specifies no exceptional situations in this function. ;; signalling simple-type-error would not be wrong. (let* ((type (or (and (symbolp type) (find-classoid type nil)) - type)) - (class (typecase type - (condition-classoid type) - (class - ;; Punt to CLOS. - (return-from make-condition (apply #'make-instance type args))) - (classoid - (error 'simple-type-error - :datum type - :expected-type 'condition-class - :format-control "~S is not a condition class." - :format-arguments (list type))) - (t - (error 'simple-type-error - :datum type - :expected-type 'condition-class - :format-control "Bad type argument:~% ~S" - :format-arguments (list type))))) - (res (make-condition-object args))) + type)) + (class (typecase type + (condition-classoid type) + (class + ;; Punt to CLOS. + (return-from make-condition (apply #'make-instance type args))) + (classoid + (error 'simple-type-error + :datum type + :expected-type 'condition-class + :format-control "~S is not a condition class." + :format-arguments (list type))) + (t + (error 'simple-type-error + :datum type + :expected-type 'condition-class + :format-control "Bad type argument:~% ~S" + :format-arguments (list type))))) + (res (make-condition-object args))) (setf (%instance-layout res) (classoid-layout class)) ;; Set any class slots with initargs present in this call. (dolist (cslot (condition-classoid-class-slots class)) (dolist (initarg (condition-slot-initargs cslot)) - (let ((val (getf args initarg *empty-condition-slot*))) - (unless (eq val *empty-condition-slot*) - (setf (car (condition-slot-cell cslot)) val))))) + (let ((val (getf args initarg *empty-condition-slot*))) + (unless (eq val *empty-condition-slot*) + (setf (car (condition-slot-cell cslot)) val))))) ;; Default any slots with non-constant defaults now. (dolist (hslot (condition-classoid-hairy-slots class)) (when (dolist (initarg (condition-slot-initargs hslot) t) - (unless (eq (getf args initarg *empty-condition-slot*) - *empty-condition-slot*) - (return nil))) - (setf (getf (condition-assigned-slots res) (condition-slot-name hslot)) - (find-slot-default class hslot)))) + (unless (eq (getf args initarg *empty-condition-slot*) + *empty-condition-slot*) + (return nil))) + (setf (getf (condition-assigned-slots res) (condition-slot-name hslot)) + (find-slot-default class hslot)))) res)) ;;;; DEFINE-CONDITION (eval-when (:compile-toplevel :load-toplevel :execute) (defun %compiler-define-condition (name direct-supers layout - all-readers all-writers) - (with-single-package-locked-error + all-readers all-writers) + (with-single-package-locked-error (:symbol name "defining ~A as a condition") (sb!xc:proclaim `(ftype (function (t) t) ,@all-readers)) (sb!xc:proclaim `(ftype (function (t t) t) ,@all-writers)) (multiple-value-bind (class old-layout) - (insured-find-classoid name - #'condition-classoid-p - #'make-condition-classoid) + (insured-find-classoid name + #'condition-classoid-p + #'make-condition-classoid) (setf (layout-classoid layout) class) (setf (classoid-direct-superclasses class) - (mapcar #'find-classoid direct-supers)) + (mapcar #'find-classoid direct-supers)) (cond ((not old-layout) - (register-layout layout)) - ((not *type-system-initialized*) - (setf (layout-classoid old-layout) class) - (setq layout old-layout) - (unless (eq (classoid-layout class) layout) - (register-layout layout))) - ((redefine-layout-warning "current" - old-layout - "new" - (layout-length layout) - (layout-inherits layout) - (layout-depthoid layout) - (layout-n-untagged-slots layout)) - (register-layout layout :invalidate t)) - ((not (classoid-layout class)) - (register-layout layout))) - + (register-layout layout)) + ((not *type-system-initialized*) + (setf (layout-classoid old-layout) class) + (setq layout old-layout) + (unless (eq (classoid-layout class) layout) + (register-layout layout))) + ((redefine-layout-warning "current" + old-layout + "new" + (layout-length layout) + (layout-inherits layout) + (layout-depthoid layout) + (layout-n-untagged-slots layout)) + (register-layout layout :invalidate t)) + ((not (classoid-layout class)) + (register-layout layout))) + (setf (layout-info layout) - (locally - ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class - ;; names which creates fast but non-cold-loadable, non-compact - ;; code. In this context, we'd rather have compact, cold-loadable - ;; code. -- WHN 19990928 - (declare (notinline find-classoid)) - (layout-info (classoid-layout (find-classoid 'condition))))) - + (locally + ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class + ;; names which creates fast but non-cold-loadable, non-compact + ;; code. In this context, we'd rather have compact, cold-loadable + ;; code. -- WHN 19990928 + (declare (notinline find-classoid)) + (layout-info (classoid-layout (find-classoid 'condition))))) + (setf (find-classoid name) class) - + ;; Initialize CPL slot. (setf (condition-classoid-cpl class) - (remove-if-not #'condition-classoid-p - (std-compute-class-precedence-list class))))) + (remove-if-not #'condition-classoid-p + (std-compute-class-precedence-list class))))) (values)) ) ; EVAL-WHEN @@ -354,22 +354,22 @@ (collect ((res (copy-list (condition-classoid-slots class)))) (dolist (sclass (cdr (condition-classoid-cpl class))) (dolist (sslot (condition-classoid-slots sclass)) - (let ((found (find (condition-slot-name sslot) (res) + (let ((found (find (condition-slot-name sslot) (res) :key #'condition-slot-name))) - (cond (found - (setf (condition-slot-initargs found) - (union (condition-slot-initargs found) - (condition-slot-initargs sslot))) - (unless (condition-slot-initform-p found) - (setf (condition-slot-initform-p found) - (condition-slot-initform-p sslot)) - (setf (condition-slot-initform found) - (condition-slot-initform sslot))) - (unless (condition-slot-allocation found) - (setf (condition-slot-allocation found) - (condition-slot-allocation sslot)))) - (t - (res (copy-structure sslot))))))) + (cond (found + (setf (condition-slot-initargs found) + (union (condition-slot-initargs found) + (condition-slot-initargs sslot))) + (unless (condition-slot-initform-p found) + (setf (condition-slot-initform-p found) + (condition-slot-initform-p sslot)) + (setf (condition-slot-initform found) + (condition-slot-initform sslot))) + (unless (condition-slot-allocation found) + (setf (condition-slot-allocation found) + (condition-slot-allocation sslot)))) + (t + (res (copy-structure sslot))))))) (res))) ;;; Early definitions of slot accessor creators. @@ -392,8 +392,8 @@ (condition-writer-function condition new-value slot-name)))) (defun %define-condition (name parent-types layout slots documentation - report default-initargs all-readers all-writers) - (with-single-package-locked-error + report default-initargs all-readers all-writers) + (with-single-package-locked-error (:symbol name "defining ~A as a condition") (%compiler-define-condition name parent-types layout all-readers all-writers) (let ((class (find-classoid name))) @@ -401,46 +401,46 @@ (setf (condition-classoid-report class) report) (setf (condition-classoid-default-initargs class) default-initargs) (setf (fdocumentation name 'type) documentation) - + (dolist (slot slots) - - ;; Set up reader and writer functions. - (let ((slot-name (condition-slot-name slot))) - (dolist (reader (condition-slot-readers slot)) - (install-condition-slot-reader reader name slot-name)) - (dolist (writer (condition-slot-writers slot)) - (install-condition-slot-writer writer name slot-name)))) - + + ;; Set up reader and writer functions. + (let ((slot-name (condition-slot-name slot))) + (dolist (reader (condition-slot-readers slot)) + (install-condition-slot-reader reader name slot-name)) + (dolist (writer (condition-slot-writers slot)) + (install-condition-slot-writer writer name slot-name)))) + ;; Compute effective slots and set up the class and hairy slots ;; (subsets of the effective slots.) (let ((eslots (compute-effective-slots class)) - (e-def-initargs - (reduce #'append - (mapcar #'condition-classoid-default-initargs - (condition-classoid-cpl class))))) - (dolist (slot eslots) - (ecase (condition-slot-allocation slot) - (:class - (unless (condition-slot-cell slot) - (setf (condition-slot-cell slot) - (list (if (condition-slot-initform-p slot) - (let ((initform (condition-slot-initform slot))) - (if (functionp initform) - (funcall initform) - initform)) - *empty-condition-slot*)))) - (push slot (condition-classoid-class-slots class))) - ((:instance nil) - (setf (condition-slot-allocation slot) :instance) - (when (or (functionp (condition-slot-initform slot)) - (dolist (initarg (condition-slot-initargs slot) nil) - (when (functionp (getf e-def-initargs initarg)) - (return t)))) - (push slot (condition-classoid-hairy-slots class)))))))) + (e-def-initargs + (reduce #'append + (mapcar #'condition-classoid-default-initargs + (condition-classoid-cpl class))))) + (dolist (slot eslots) + (ecase (condition-slot-allocation slot) + (:class + (unless (condition-slot-cell slot) + (setf (condition-slot-cell slot) + (list (if (condition-slot-initform-p slot) + (let ((initform (condition-slot-initform slot))) + (if (functionp initform) + (funcall initform) + initform)) + *empty-condition-slot*)))) + (push slot (condition-classoid-class-slots class))) + ((:instance nil) + (setf (condition-slot-allocation slot) :instance) + (when (or (functionp (condition-slot-initform slot)) + (dolist (initarg (condition-slot-initargs slot) nil) + (when (functionp (getf e-def-initargs initarg)) + (return t)))) + (push slot (condition-classoid-hairy-slots class)))))))) name)) (defmacro define-condition (name (&rest parent-types) (&rest slot-specs) - &body options) + &body options) #!+sb-doc "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option* Define NAME as a condition type. This new type inherits slots and its @@ -460,111 +460,111 @@ CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and SLOT-VALUE may not be used on condition objects." (let* ((parent-types (or parent-types '(condition))) - (layout (find-condition-layout name parent-types)) - (documentation nil) - (report nil) - (default-initargs ())) + (layout (find-condition-layout name parent-types)) + (documentation nil) + (report nil) + (default-initargs ())) (collect ((slots) - (all-readers nil append) - (all-writers nil append)) + (all-readers nil append) + (all-writers nil append)) (dolist (spec slot-specs) - (when (keywordp spec) - (warn "Keyword slot name indicates probable syntax error:~% ~S" - spec)) - (let* ((spec (if (consp spec) spec (list spec))) - (slot-name (first spec)) - (allocation :instance) - (initform-p nil) - documentation - initform) - (collect ((initargs) - (readers) - (writers)) - (do ((options (rest spec) (cddr options))) - ((null options)) - (unless (and (consp options) (consp (cdr options))) - (error "malformed condition slot spec:~% ~S." spec)) - (let ((arg (second options))) - (case (first options) - (:reader (readers arg)) - (:writer (writers arg)) - (:accessor - (readers arg) - (writers `(setf ,arg))) - (:initform - (when initform-p - (error "more than one :INITFORM in ~S" spec)) - (setq initform-p t) - (setq initform arg)) - (:initarg (initargs arg)) - (:allocation - (setq allocation arg)) - (:documentation - (when documentation - (error "more than one :DOCUMENTATION in ~S" spec)) - (unless (stringp arg) - (error "slot :DOCUMENTATION argument is not a string: ~S" - arg)) - (setq documentation arg)) - (:type) - (t - (error "unknown slot option:~% ~S" (first options)))))) - - (all-readers (readers)) - (all-writers (writers)) - (slots `(make-condition-slot - :name ',slot-name - :initargs ',(initargs) - :readers ',(readers) - :writers ',(writers) - :initform-p ',initform-p - :documentation ',documentation - :initform - ,(if (constantp initform) - `',(eval initform) - `#'(lambda () ,initform))))))) + (when (keywordp spec) + (warn "Keyword slot name indicates probable syntax error:~% ~S" + spec)) + (let* ((spec (if (consp spec) spec (list spec))) + (slot-name (first spec)) + (allocation :instance) + (initform-p nil) + documentation + initform) + (collect ((initargs) + (readers) + (writers)) + (do ((options (rest spec) (cddr options))) + ((null options)) + (unless (and (consp options) (consp (cdr options))) + (error "malformed condition slot spec:~% ~S." spec)) + (let ((arg (second options))) + (case (first options) + (:reader (readers arg)) + (:writer (writers arg)) + (:accessor + (readers arg) + (writers `(setf ,arg))) + (:initform + (when initform-p + (error "more than one :INITFORM in ~S" spec)) + (setq initform-p t) + (setq initform arg)) + (:initarg (initargs arg)) + (:allocation + (setq allocation arg)) + (:documentation + (when documentation + (error "more than one :DOCUMENTATION in ~S" spec)) + (unless (stringp arg) + (error "slot :DOCUMENTATION argument is not a string: ~S" + arg)) + (setq documentation arg)) + (:type) + (t + (error "unknown slot option:~% ~S" (first options)))))) + + (all-readers (readers)) + (all-writers (writers)) + (slots `(make-condition-slot + :name ',slot-name + :initargs ',(initargs) + :readers ',(readers) + :writers ',(writers) + :initform-p ',initform-p + :documentation ',documentation + :initform + ,(if (constantp initform) + `',(eval initform) + `#'(lambda () ,initform))))))) (dolist (option options) - (unless (consp option) - (error "bad option:~% ~S" option)) - (case (first option) - (:documentation (setq documentation (second option))) - (:report - (let ((arg (second option))) - (setq report - (if (stringp arg) - `#'(lambda (condition stream) - (declare (ignore condition)) - (write-string ,arg stream)) - `#'(lambda (condition stream) - (funcall #',arg condition stream)))))) - (:default-initargs - (do ((initargs (rest option) (cddr initargs))) - ((endp initargs)) - (let ((val (second initargs))) - (setq default-initargs - (list* `',(first initargs) - (if (constantp val) - `',(eval val) - `#'(lambda () ,val)) - default-initargs))))) - (t - (error "unknown option: ~S" (first option))))) + (unless (consp option) + (error "bad option:~% ~S" option)) + (case (first option) + (:documentation (setq documentation (second option))) + (:report + (let ((arg (second option))) + (setq report + (if (stringp arg) + `#'(lambda (condition stream) + (declare (ignore condition)) + (write-string ,arg stream)) + `#'(lambda (condition stream) + (funcall #',arg condition stream)))))) + (:default-initargs + (do ((initargs (rest option) (cddr initargs))) + ((endp initargs)) + (let ((val (second initargs))) + (setq default-initargs + (list* `',(first initargs) + (if (constantp val) + `',(eval val) + `#'(lambda () ,val)) + default-initargs))))) + (t + (error "unknown option: ~S" (first option))))) `(progn - (eval-when (:compile-toplevel) - (%compiler-define-condition ',name ',parent-types ',layout - ',(all-readers) ',(all-writers))) - (eval-when (:load-toplevel :execute) - (%define-condition ',name - ',parent-types - ',layout - (list ,@(slots)) - ,documentation - ,report - (list ,@default-initargs) - ',(all-readers) - ',(all-writers))))))) + (eval-when (:compile-toplevel) + (%compiler-define-condition ',name ',parent-types ',layout + ',(all-readers) ',(all-writers))) + (eval-when (:load-toplevel :execute) + (%define-condition ',name + ',parent-types + ',layout + (list ,@(slots)) + ,documentation + ,report + (list ,@default-initargs) + ',(all-readers) + ',(all-writers))))))) ;;;; DESCRIBE on CONDITIONs @@ -573,12 +573,12 @@ ;;; methods) (defun describe-condition (condition stream) (format stream - "~&~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>~%" - condition - (type-of condition) - (concatenate 'list - (condition-actual-initargs condition) - (condition-assigned-slots condition)))) + "~&~@<~S ~_is a ~S. ~_Its slot values are ~_~S.~:>~%" + condition + (type-of condition) + (concatenate 'list + (condition-actual-initargs condition) + (condition-assigned-slots condition)))) ;;;; various CONDITIONs specified by ANSI @@ -591,17 +591,17 @@ (defun simple-condition-printer (condition stream) (apply #'format - stream - (simple-condition-format-control condition) - (simple-condition-format-arguments condition))) + stream + (simple-condition-format-control condition) + (simple-condition-format-arguments condition))) (define-condition simple-condition () ((format-control :reader simple-condition-format-control - :initarg :format-control + :initarg :format-control :type format-control) (format-arguments :reader simple-condition-format-arguments - :initarg :format-arguments - :initform '() + :initarg :format-arguments + :initform '() :type list)) (:report simple-condition-printer)) @@ -620,9 +620,9 @@ (:report (lambda (condition stream) (format stream - "~@" - (type-error-datum condition) - (type-error-expected-type condition))))) + "~@" + (type-error-datum condition) + (type-error-expected-type condition))))) (define-condition simple-type-error (simple-condition type-error) ()) @@ -636,8 +636,8 @@ (:report (lambda (condition stream) (format stream - "end of file on ~S" - (stream-error-stream condition))))) + "end of file on ~S" + (stream-error-stream condition))))) (define-condition file-error (error) ((pathname :reader file-error-pathname :initarg :pathname)) @@ -654,45 +654,45 @@ (def!method print-object ((condition cell-error) stream) (if (and *print-escape* (slot-boundp condition 'name)) (print-unreadable-object (condition stream :type t :identity t) - (princ (cell-error-name condition) stream)) + (princ (cell-error-name condition) stream)) (call-next-method))) (define-condition unbound-variable (cell-error) () (:report (lambda (condition stream) (format stream - "The variable ~S is unbound." - (cell-error-name condition))))) + "The variable ~S is unbound." + (cell-error-name condition))))) (define-condition undefined-function (cell-error) () (:report (lambda (condition stream) (format stream - "The function ~S is undefined." - (cell-error-name condition))))) + "The function ~S is undefined." + (cell-error-name condition))))) (define-condition special-form-function (undefined-function) () (:report (lambda (condition stream) (format stream - "Cannot FUNCALL the SYMBOL-FUNCTION of special operator ~S." - (cell-error-name condition))))) + "Cannot FUNCALL the SYMBOL-FUNCTION of special operator ~S." + (cell-error-name condition))))) (define-condition arithmetic-error (error) ((operation :reader arithmetic-error-operation - :initarg :operation - :initform nil) + :initarg :operation + :initform nil) (operands :reader arithmetic-error-operands - :initarg :operands)) + :initarg :operands)) (:report (lambda (condition stream) - (format stream - "arithmetic error ~S signalled" - (type-of condition)) - (when (arithmetic-error-operation condition) - (format stream - "~%Operation was ~S, operands ~S." - (arithmetic-error-operation condition) - (arithmetic-error-operands condition)))))) + (format stream + "arithmetic error ~S signalled" + (type-of condition)) + (when (arithmetic-error-operation condition) + (format stream + "~%Operation was ~S, operands ~S." + (arithmetic-error-operation condition) + (arithmetic-error-operands condition)))))) (define-condition division-by-zero (arithmetic-error) ()) (define-condition floating-point-overflow (arithmetic-error) ()) @@ -705,7 +705,7 @@ (:report (lambda (condition stream) (let ((obj (print-not-readable-object condition)) - (*print-array* nil)) + (*print-array* nil)) (format stream "~S cannot be printed readably." obj))))) (define-condition reader-error (parse-error stream-error) @@ -719,39 +719,39 @@ (:report (lambda (condition stream) (let* ((error-stream (stream-error-stream condition)) - (pos (file-position-or-nil-for-error error-stream))) + (pos (file-position-or-nil-for-error error-stream))) (let (lineno colno) - (when (and pos - (< pos sb!xc:array-dimension-limit) - ;; KLUDGE: lseek() (which is what FILE-POSITION - ;; reduces to on file-streams) is undefined on - ;; "some devices", which in practice means that it - ;; can claim to succeed on /dev/stdin on Darwin - ;; and Solaris. This is obviously bad news, - ;; because the READ-SEQUENCE below will then - ;; block, not complete, and the report will never - ;; be printed. As a workaround, we exclude - ;; interactive streams from this attempt to report - ;; positions. -- CSR, 2003-08-21 - (not (interactive-stream-p error-stream)) - (file-position error-stream :start)) - (let ((string - (make-string pos - :element-type (stream-element-type - error-stream)))) - (when (= pos (read-sequence string error-stream)) - (setq lineno (1+ (count #\Newline string)) - colno (- pos - (or (position #\Newline string :from-end t) -1) - 1)))) - (file-position-or-nil-for-error error-stream pos)) - (format stream - "READER-ERROR ~@[at ~W ~]~ + (when (and pos + (< pos sb!xc:array-dimension-limit) + ;; KLUDGE: lseek() (which is what FILE-POSITION + ;; reduces to on file-streams) is undefined on + ;; "some devices", which in practice means that it + ;; can claim to succeed on /dev/stdin on Darwin + ;; and Solaris. This is obviously bad news, + ;; because the READ-SEQUENCE below will then + ;; block, not complete, and the report will never + ;; be printed. As a workaround, we exclude + ;; interactive streams from this attempt to report + ;; positions. -- CSR, 2003-08-21 + (not (interactive-stream-p error-stream)) + (file-position error-stream :start)) + (let ((string + (make-string pos + :element-type (stream-element-type + error-stream)))) + (when (= pos (read-sequence string error-stream)) + (setq lineno (1+ (count #\Newline string)) + colno (- pos + (or (position #\Newline string :from-end t) -1) + 1)))) + (file-position-or-nil-for-error error-stream pos)) + (format stream + "READER-ERROR ~@[at ~W ~]~ ~@[(line ~W~]~@[, column ~W) ~]~ on ~S:~%~?" - pos lineno colno error-stream - (reader-error-format-control condition) - (reader-error-format-arguments condition))))))) + pos lineno colno error-stream + (reader-error-format-control condition) + (reader-error-format-arguments condition))))))) ;;;; special SBCL extension conditions @@ -771,10 +771,10 @@ (:report (lambda (condition stream) (format stream - "~@< ~? ~:@_~?~:>" - (simple-condition-format-control condition) - (simple-condition-format-arguments condition) - "~@" + (simple-condition-format-control condition) + (simple-condition-format-arguments condition) + "~@.~:@>" - '((fmakunbound 'compile)))))) + '((fmakunbound 'compile)))))) (define-condition simple-storage-condition (storage-condition simple-condition) ()) @@ -799,7 +799,7 @@ ;;; By signalling a standard condition in this case, we make it ;;; possible for test code to distinguish between (1) intentionally ;;; unimplemented and (2) unintentionally just screwed up somehow. -;;; (Before this condition was defined, test code tried to deal with +;;; (Before this condition was defined, test code tried to deal with ;;; this by checking for FBOUNDP, but that didn't work reliably. In ;;; sbcl-0.7.0, a a package screwup left the definition of ;;; LOAD-FOREIGN in the wrong package, so it was unFBOUNDP even on @@ -825,27 +825,27 @@ (format stream ", ") (destructuring-bind (type data) (cdr reference) (ecase type - (:generic-function (format stream "Generic Function ~S" data)) - (:section (format stream "Section ~{~D~^.~}" data))))) + (:generic-function (format stream "Generic Function ~S" data)) + (:section (format stream "Section ~{~D~^.~}" data))))) (:ansi-cl (format stream "The ANSI Standard") (format stream ", ") (destructuring-bind (type data) (cdr reference) (ecase type - (:function (format stream "Function ~S" data)) - (:special-operator (format stream "Special Operator ~S" data)) - (:macro (format stream "Macro ~S" data)) - (:section (format stream "Section ~{~D~^.~}" data)) - (:glossary (format stream "Glossary entry for ~S" data)) - (:issue (format stream "writeup for Issue ~A" data))))) + (:function (format stream "Function ~S" data)) + (:special-operator (format stream "Special Operator ~S" data)) + (:macro (format stream "Macro ~S" data)) + (:section (format stream "Section ~{~D~^.~}" data)) + (:glossary (format stream "Glossary entry for ~S" data)) + (:issue (format stream "writeup for Issue ~A" data))))) (:sbcl (format stream "The SBCL Manual") (format stream ", ") (destructuring-bind (type data) (cdr reference) (ecase type - (:node (format stream "Node ~S" data)) - (:variable (format stream "Variable ~S" data)) - (:function (format stream "Function ~S" data))))) + (:node (format stream "Node ~S" data)) + (:variable (format stream "Variable ~S" data)) + (:function (format stream "Function ~S" data))))) ;; FIXME: other documents (e.g. CLIM, Franz documentation :-) )) (define-condition reference-condition () @@ -858,22 +858,22 @@ (reference-condition-references o)) (format s "~&See also:~%") (pprint-logical-block (s nil :per-line-prefix " ") - (do* ((rs (reference-condition-references o) (cdr rs)) - (r (car rs) (car rs))) - ((null rs)) - (print-reference r s) - (unless (null (cdr rs)) - (terpri s))))))) + (do* ((rs (reference-condition-references o) (cdr rs)) + (r (car rs) (car rs))) + ((null rs)) + (print-reference r s) + (unless (null (cdr rs)) + (terpri s))))))) (define-condition duplicate-definition (reference-condition warning) ((name :initarg :name :reader duplicate-definition-name)) (:report (lambda (c s) - (format s "~@" - (duplicate-definition-name c)))) + (duplicate-definition-name c)))) (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3))))) -(define-condition package-at-variance (reference-condition simple-warning) +(define-condition package-at-variance (reference-condition simple-warning) () (:default-initargs :references (list '(:ansi-cl :macro defpackage)))) @@ -884,20 +884,20 @@ (:report (lambda (condition stream) (format stream - "~@" - (defconstant-uneql-name condition) - (defconstant-uneql-old-value condition) - (defconstant-uneql-new-value condition)))) + "~@" + (defconstant-uneql-name condition) + (defconstant-uneql-old-value condition) + (defconstant-uneql-new-value condition)))) (:default-initargs :references (list '(:ansi-cl :macro defconstant) - '(:sbcl :node "Idiosyncrasies")))) + '(:sbcl :node "Idiosyncrasies")))) -(define-condition array-initial-element-mismatch +(define-condition array-initial-element-mismatch (reference-condition simple-warning) () - (:default-initargs - :references (list - '(:ansi-cl :function make-array) - '(:ansi-cl :function sb!xc:upgraded-array-element-type)))) + (:default-initargs + :references (list + '(:ansi-cl :function make-array) + '(:ansi-cl :function sb!xc:upgraded-array-element-type)))) (define-condition displaced-to-array-too-small-error (reference-condition simple-error) @@ -917,7 +917,7 @@ () (:default-initargs :references (list '(:ansi-cl :section (22 3 10 2))))) -(define-condition format-too-few-args-warning +(define-condition format-too-few-args-warning (format-args-mismatch simple-warning) ()) (define-condition format-too-many-args-warning @@ -936,21 +936,21 @@ (progn (define-condition package-lock-violation (reference-condition package-error) - ((format-control :initform nil :initarg :format-control - :reader package-error-format-control) + ((format-control :initform nil :initarg :format-control + :reader package-error-format-control) (format-arguments :initform nil :initarg :format-arguments - :reader package-error-format-arguments)) - (:report + :reader package-error-format-arguments)) + (:report (lambda (condition stream) (let ((control (package-error-format-control condition))) (if control - (apply #'format stream + (apply #'format stream (format nil "~~@" (package-name (package-error-package condition)) control) (package-error-format-arguments condition)) - (format stream "~@" - (package-name (package-error-package condition))))))) + (format stream "~@" + (package-name (package-error-package condition))))))) ;; no :default-initargs -- reference-stuff provided by the ;; signalling form in target-package.lisp #!+sb-doc @@ -979,8 +979,8 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (:report (lambda (condition stream) (if (slot-boundp condition 'name) - (format stream "Undefined alien: ~S" (cell-error-name condition)) - (format stream "Undefined alien symbol."))))) + (format stream "Undefined alien: ~S" (cell-error-name condition)) + (format stream "Undefined alien symbol."))))) (define-condition undefined-alien-variable-error (undefined-alien-error) () (:report @@ -1010,9 +1010,9 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (:report (lambda (condition stream) (format stream - "~@" - (type-error-datum condition) - (type-error-expected-type condition))))) + "~@" + (type-error-datum condition) + (type-error-expected-type condition))))) ;;; KLUDGE: a condition for floating point errors when we can't or ;;; won't figure out what type they are. (In FreeBSD and OpenBSD we @@ -1025,64 +1025,64 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (define-condition floating-point-exception (arithmetic-error) ((flags :initarg :traps :initform nil - :reader floating-point-exception-traps)) + :reader floating-point-exception-traps)) (:report (lambda (condition stream) - (format stream - "An arithmetic error ~S was signalled.~%" - (type-of condition)) - (let ((traps (floating-point-exception-traps condition))) - (if traps - (format stream - "Trapping conditions are: ~%~{ ~S~^~}~%" - traps) - (write-line - "No traps are enabled? How can this be?" - stream)))))) + (format stream + "An arithmetic error ~S was signalled.~%" + (type-of condition)) + (let ((traps (floating-point-exception-traps condition))) + (if traps + (format stream + "Trapping conditions are: ~%~{ ~S~^~}~%" + traps) + (write-line + "No traps are enabled? How can this be?" + stream)))))) (define-condition index-too-large-error (type-error) () (:report (lambda (condition stream) (format stream - "The index ~S is too large." - (type-error-datum condition))))) + "The index ~S is too large." + (type-error-datum condition))))) (define-condition bounding-indices-bad-error (reference-condition type-error) ((object :reader bounding-indices-bad-object :initarg :object)) (:report (lambda (condition stream) (let* ((datum (type-error-datum condition)) - (start (car datum)) - (end (cdr datum)) - (object (bounding-indices-bad-object condition))) + (start (car datum)) + (end (cdr datum)) + (object (bounding-indices-bad-object condition))) (etypecase object - (sequence - (format stream - "The bounding indices ~S and ~S are bad ~ + (sequence + (format stream + "The bounding indices ~S and ~S are bad ~ for a sequence of length ~S." - start end (length object))) - (array - ;; from WITH-ARRAY-DATA - (format stream - "The START and END parameters ~S and ~S are ~ + start end (length object))) + (array + ;; from WITH-ARRAY-DATA + (format stream + "The START and END parameters ~S and ~S are ~ bad for an array of total size ~S." - start end (array-total-size object))))))) - (:default-initargs - :references + start end (array-total-size object))))))) + (:default-initargs + :references (list '(:ansi-cl :glossary "bounding index designator") - '(:ansi-cl :issue "SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR")))) + '(:ansi-cl :issue "SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR")))) (define-condition nil-array-accessed-error (reference-condition type-error) () (:report (lambda (condition stream) - (declare (ignore condition)) - (format stream - "An attempt to access an array of element-type ~ + (declare (ignore condition)) + (format stream + "An attempt to access an array of element-type ~ NIL was made. Congratulations!"))) (:default-initargs :references (list '(:ansi-cl :function sb!xc:upgraded-array-element-type) - '(:ansi-cl :section (15 1 2 1)) - '(:ansi-cl :section (15 1 2 2))))) + '(:ansi-cl :section (15 1 2 1)) + '(:ansi-cl :section (15 1 2 2))))) (define-condition io-timeout (stream-error) ((direction :reader io-timeout-direction :initarg :direction)) @@ -1090,9 +1090,9 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (lambda (condition stream) (declare (type stream stream)) (format stream - "I/O timeout ~(~A~)ing ~S" - (io-timeout-direction condition) - (stream-error-stream condition))))) + "I/O timeout ~(~A~)ing ~S" + (io-timeout-direction condition) + (stream-error-stream condition))))) (define-condition namestring-parse-error (parse-error) ((complaint :reader namestring-parse-error-complaint :initarg :complaint) @@ -1102,11 +1102,11 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (:report (lambda (condition stream) (format stream - "parse error in namestring: ~?~% ~A~% ~V@T^" - (namestring-parse-error-complaint condition) - (namestring-parse-error-args condition) - (namestring-parse-error-namestring condition) - (namestring-parse-error-offset condition))))) + "parse error in namestring: ~?~% ~A~% ~V@T^" + (namestring-parse-error-complaint condition) + (namestring-parse-error-args condition) + (namestring-parse-error-namestring condition) + (namestring-parse-error-offset condition))))) (define-condition simple-package-error (simple-condition package-error) ()) @@ -1117,9 +1117,9 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (:report (lambda (condition stream) (format stream - "unexpected end of file on ~S ~A" - (stream-error-stream condition) - (reader-eof-error-context condition))))) + "unexpected end of file on ~S ~A" + (stream-error-stream condition) + (reader-eof-error-context condition))))) (define-condition reader-impossible-number-error (reader-error) ((error :reader reader-impossible-number-error-error :initarg :error)) @@ -1127,15 +1127,15 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (lambda (condition stream) (let ((error-stream (stream-error-stream condition))) (format stream "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A" - (file-position-or-nil-for-error error-stream) error-stream - (reader-error-format-control condition) - (reader-error-format-arguments condition) - (reader-impossible-number-error-error condition)))))) + (file-position-or-nil-for-error error-stream) error-stream + (reader-error-format-control condition) + (reader-error-format-arguments condition) + (reader-impossible-number-error-error condition)))))) (define-condition timeout (serious-condition) ()) (define-condition declaration-type-conflict-error (reference-condition - simple-error) + simple-error) () (:default-initargs :format-control "symbol ~S cannot be both the name of a type and the name of a declaration" @@ -1222,14 +1222,14 @@ the value of the variable. No associated restarts.")) (invoke-restart (find-restart-or-control-error 'muffle-warning condition))) (macrolet ((define-nil-returning-restart (name args doc) - #!-sb-doc (declare (ignore doc)) - `(defun ,name (,@args &optional condition) - #!+sb-doc ,doc - ;; FIXME: Perhaps this shared logic should be pulled out into - ;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code.. - (let ((restart (find-restart ',name condition))) - (when restart - (invoke-restart restart ,@args)))))) + #!-sb-doc (declare (ignore doc)) + `(defun ,name (,@args &optional condition) + #!+sb-doc ,doc + ;; FIXME: Perhaps this shared logic should be pulled out into + ;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code.. + (let ((restart (find-restart ',name condition))) + (when restart + (invoke-restart restart ,@args)))))) (define-nil-returning-restart continue () "Transfer control to a restart named CONTINUE, or return NIL if none exists.") (define-nil-returning-restart store-value (value) @@ -1242,10 +1242,10 @@ the value of the variable. No associated restarts.")) ;;; single-stepping restarts (macrolet ((def (name doc) - #!-sb-doc (declare (ignore doc)) - `(defun ,name (condition) - #!+sb-doc ,doc - (invoke-restart (find-restart-or-control-error ',name condition))))) + #!-sb-doc (declare (ignore doc)) + `(defun ,name (condition) + #!+sb-doc ,doc + (invoke-restart (find-restart-or-control-error ',name condition))))) (def step-continue "Transfers control to the STEP-CONTINUE restart associated with the condition, continuing execution without stepping. Signals a diff --git a/src/code/cross-byte.lisp b/src/code/cross-byte.lisp index 4b6f4a2..d693a7c 100644 --- a/src/code/cross-byte.lisp +++ b/src/code/cross-byte.lisp @@ -50,14 +50,14 @@ (when (cdr stores) (bug "SETF SB!XC:LDB too hairy!")) (let ((btemp (gensym)) - (store (gensym))) + (store (gensym))) (values (cons btemp temps) - (cons cross-byte vals) - (list store) - `(let ((,(car stores) (cl:dpb ,store (uncross-byte ,btemp) ,access-form))) - ,store-form - ,store) - `(cl:ldb (uncross-byte ,btemp) ,access-form))))) + (cons cross-byte vals) + (list store) + `(let ((,(car stores) (cl:dpb ,store (uncross-byte ,btemp) ,access-form))) + ,store-form + ,store) + `(cl:ldb (uncross-byte ,btemp) ,access-form))))) (define-setf-expander sb!xc:mask-field (cross-byte int &environment env) (multiple-value-bind (temps vals stores store-form access-form) @@ -65,11 +65,11 @@ (when (cdr stores) (bug "SETF SB!XC:MASK-FIELD too hairy!")) (let ((btemp (gensym)) - (store (gensym))) + (store (gensym))) (values (cons btemp temps) - (cons cross-byte vals) - (list store) - `(let ((,(car stores) (cl:deposit-field ,store (uncross-byte ,btemp) ,access-form))) - ,store-form - ,store) - `(cl:mask-field (uncross-byte ,btemp) ,access-form))))) + (cons cross-byte vals) + (list store) + `(let ((,(car stores) (cl:deposit-field ,store (uncross-byte ,btemp) ,access-form))) + ,store-form + ,store) + `(cl:mask-field (uncross-byte ,btemp) ,access-form))))) diff --git a/src/code/cross-char.lisp b/src/code/cross-char.lisp index 57a60eb..c6cdf15 100644 --- a/src/code/cross-char.lisp +++ b/src/code/cross-char.lisp @@ -16,10 +16,10 @@ (defun sb!xc:code-char (x) (declare (type (or (integer 10 10) (integer 32 126)) x)) (if (= x 10) - #\Newline - (char ascii-standard-chars (- x 32)))) + #\Newline + (char ascii-standard-chars (- x 32)))) (defun sb!xc:char-code (character) (declare (type standard-char character)) (if (char= character #\Newline) - 10 - (+ (position character ascii-standard-chars) 32)))) + 10 + (+ (position character ascii-standard-chars) 32)))) diff --git a/src/code/cross-condition.lisp b/src/code/cross-condition.lisp index 5c2f821..cd8580c 100644 --- a/src/code/cross-condition.lisp +++ b/src/code/cross-condition.lisp @@ -45,17 +45,17 @@ (:report (lambda (condition stream) (format stream - "~@< ~? ~:@_~?~:>" - (simple-condition-format-control condition) - (simple-condition-format-arguments condition) - "~@" + (simple-condition-format-control condition) + (simple-condition-format-arguments condition) + "~@.~:@>" - ())))) + ())))) ;;; These are should never be instantiated before the real definitions ;;; come in. diff --git a/src/code/cross-float.lisp b/src/code/cross-float.lisp index f7b995e..71f0754 100644 --- a/src/code/cross-float.lisp +++ b/src/code/cross-float.lisp @@ -20,7 +20,7 @@ (declare (ignore traps)) ;; FIXME: should become STYLE-WARNING? (format *error-output* - "~&(can't portably mask float traps, proceeding anyway)~%") + "~&(can't portably mask float traps, proceeding anyway)~%") `(progn ,@body)) ;;; a helper function for DOUBLE-FLOAT-FOO-BITS functions @@ -29,12 +29,12 @@ (defun mask-and-sign-extend (x n) (assert (plusp n)) (let* ((high-bit (ash 1 (1- n))) - (mask (1- (ash high-bit 1))) - (uresult (logand mask x))) + (mask (1- (ash high-bit 1))) + (uresult (logand mask x))) (if (zerop (logand uresult high-bit)) - uresult - (logior uresult - (logand -1 (lognot mask)))))) + uresult + (logior uresult + (logand -1 (lognot mask)))))) ;;; portable implementations of SINGLE-FLOAT-BITS, ;;; DOUBLE-FLOAT-LOW-BITS, and DOUBLE-FLOAT-HIGH-BITS @@ -57,61 +57,61 @@ (if (zerop x) (if (eql x 0.0f0) 0 #x-80000000) (multiple-value-bind (lisp-significand lisp-exponent lisp-sign) - (integer-decode-float x) - (assert (plusp lisp-significand)) - ;; Calculate IEEE-style fields from Common-Lisp-style fields. - ;; - ;; KLUDGE: This code was written from my foggy memory of what IEEE - ;; format looks like, augmented by some experiments with - ;; the existing implementation of SINGLE-FLOAT-BITS, and what - ;; I found floating around on the net at - ;; , - ;; , - ;; and - ;; . - ;; And beyond the probable sheer flakiness of the code, all the bare - ;; numbers floating around here are sort of ugly, too. -- WHN 19990711 - (let* ((significand lisp-significand) - (exponent (+ lisp-exponent 23 127)) - (unsigned-result - (if (plusp exponent) ; if not obviously denormalized - (do () - (nil) - (cond (;; special termination case, denormalized - ;; float number - (zerop exponent) - ;; Denormalized numbers have exponent one - ;; greater than the exponent field. - (return (ash significand -1))) - (;; ordinary termination case - (>= significand (expt 2 23)) - (assert (< 0 significand (expt 2 24))) - ;; Exponent 0 is reserved for - ;; denormalized numbers, and 255 is - ;; reserved for specials like NaN. - (assert (< 0 exponent 255)) - (return (logior (ash exponent 23) - (logand significand - (1- (ash 1 23)))))) + (integer-decode-float x) + (assert (plusp lisp-significand)) + ;; Calculate IEEE-style fields from Common-Lisp-style fields. + ;; + ;; KLUDGE: This code was written from my foggy memory of what IEEE + ;; format looks like, augmented by some experiments with + ;; the existing implementation of SINGLE-FLOAT-BITS, and what + ;; I found floating around on the net at + ;; , + ;; , + ;; and + ;; . + ;; And beyond the probable sheer flakiness of the code, all the bare + ;; numbers floating around here are sort of ugly, too. -- WHN 19990711 + (let* ((significand lisp-significand) + (exponent (+ lisp-exponent 23 127)) + (unsigned-result + (if (plusp exponent) ; if not obviously denormalized + (do () + (nil) + (cond (;; special termination case, denormalized + ;; float number + (zerop exponent) + ;; Denormalized numbers have exponent one + ;; greater than the exponent field. + (return (ash significand -1))) + (;; ordinary termination case + (>= significand (expt 2 23)) + (assert (< 0 significand (expt 2 24))) + ;; Exponent 0 is reserved for + ;; denormalized numbers, and 255 is + ;; reserved for specials like NaN. + (assert (< 0 exponent 255)) + (return (logior (ash exponent 23) + (logand significand + (1- (ash 1 23)))))) - (t - ;; Shift as necessary to set bit 24 of - ;; significand. - (setf significand (ash significand 1) - exponent (1- exponent))))) - (do () - ((zerop exponent) - ;; Denormalized numbers have exponent one - ;; greater than the exponent field. - (ash significand -1)) - (unless (zerop (logand significand 1)) - (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits" - x)) - (setf significand (ash significand -1) - exponent (1+ exponent)))))) - (ecase lisp-sign - (1 unsigned-result) - (-1 (logior unsigned-result (- (expt 2 31))))))))) + (t + ;; Shift as necessary to set bit 24 of + ;; significand. + (setf significand (ash significand 1) + exponent (1- exponent))))) + (do () + ((zerop exponent) + ;; Denormalized numbers have exponent one + ;; greater than the exponent field. + (ash significand -1)) + (unless (zerop (logand significand 1)) + (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits" + x)) + (setf significand (ash significand -1) + exponent (1+ exponent)))))) + (ecase lisp-sign + (1 unsigned-result) + (-1 (logior unsigned-result (- (expt 2 31))))))))) (defun double-float-bits (x) (declare (type double-float x)) @@ -120,48 +120,48 @@ (if (eql x 0.0d0) 0 #x-8000000000000000) ;; KLUDGE: As per comments in SINGLE-FLOAT-BITS, above. (multiple-value-bind (lisp-significand lisp-exponent lisp-sign) - (integer-decode-float x) - (assert (plusp lisp-significand)) - (let* ((significand lisp-significand) - (exponent (+ lisp-exponent 52 1023)) - (unsigned-result - (if (plusp exponent) ; if not obviously denormalized - (do () - (nil) - (cond (;; special termination case, denormalized - ;; float number - (zerop exponent) - ;; Denormalized numbers have exponent one - ;; greater than the exponent field. - (return (ash significand -1))) - (;; ordinary termination case - (>= significand (expt 2 52)) - (assert (< 0 significand (expt 2 53))) - ;; Exponent 0 is reserved for - ;; denormalized numbers, and 2047 is - ;; reserved for specials like NaN. - (assert (< 0 exponent 2047)) - (return (logior (ash exponent 52) - (logand significand - (1- (ash 1 52)))))) - (t - ;; Shift as necessary to set bit 53 of - ;; significand. - (setf significand (ash significand 1) - exponent (1- exponent))))) - (do () - ((zerop exponent) - ;; Denormalized numbers have exponent one - ;; greater than the exponent field. - (ash significand -1)) - (unless (zerop (logand significand 1)) - (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits" - x)) - (setf significand (ash significand -1) - exponent (1+ exponent)))))) - (ecase lisp-sign - (1 unsigned-result) - (-1 (logior unsigned-result (- (expt 2 63))))))))) + (integer-decode-float x) + (assert (plusp lisp-significand)) + (let* ((significand lisp-significand) + (exponent (+ lisp-exponent 52 1023)) + (unsigned-result + (if (plusp exponent) ; if not obviously denormalized + (do () + (nil) + (cond (;; special termination case, denormalized + ;; float number + (zerop exponent) + ;; Denormalized numbers have exponent one + ;; greater than the exponent field. + (return (ash significand -1))) + (;; ordinary termination case + (>= significand (expt 2 52)) + (assert (< 0 significand (expt 2 53))) + ;; Exponent 0 is reserved for + ;; denormalized numbers, and 2047 is + ;; reserved for specials like NaN. + (assert (< 0 exponent 2047)) + (return (logior (ash exponent 52) + (logand significand + (1- (ash 1 52)))))) + (t + ;; Shift as necessary to set bit 53 of + ;; significand. + (setf significand (ash significand 1) + exponent (1- exponent))))) + (do () + ((zerop exponent) + ;; Denormalized numbers have exponent one + ;; greater than the exponent field. + (ash significand -1)) + (unless (zerop (logand significand 1)) + (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits" + x)) + (setf significand (ash significand -1) + exponent (1+ exponent)))))) + (ecase lisp-sign + (1 unsigned-result) + (-1 (logior unsigned-result (- (expt 2 63))))))))) (defun double-float-low-bits (x) (declare (type double-float x)) @@ -226,7 +226,7 @@ 0 (ash 1 23))) (expt 0.5 23)))) - (* sign (kludge-opaque-expt 2.0 expt) mant))))) + (* sign (kludge-opaque-expt 2.0 expt) mant))))) (defun make-double-float (hi lo) (cond @@ -234,17 +234,17 @@ ((and (zerop hi) (zerop lo)) 0.0d0) ((and (= hi #x-80000000) (zerop lo)) -0.0d0) (t (let* ((bits (logior (ash hi 32) lo)) - (sign (ecase (ldb (byte 1 63) bits) - (0 1.0d0) - (1 -1.0d0))) + (sign (ecase (ldb (byte 1 63) bits) + (0 1.0d0) + (1 -1.0d0))) (iexpt (ldb (byte 11 52) bits)) - (expt (if (zerop iexpt) ; denormalized + (expt (if (zerop iexpt) ; denormalized -1022 (- iexpt 1023))) - (mant (* (logior (ldb (byte 52 0) bits) - (if (zerop iexpt) + (mant (* (logior (ldb (byte 52 0) bits) + (if (zerop iexpt) 0 (ash 1 52))) - (expt 0.5d0 52)))) - (* sign (kludge-opaque-expt 2.0d0 expt) mant))))) + (expt 0.5d0 52)))) + (* sign (kludge-opaque-expt 2.0d0 expt) mant))))) diff --git a/src/code/cross-make-load-form.lisp b/src/code/cross-make-load-form.lisp index 22bde12..90b9eef 100644 --- a/src/code/cross-make-load-form.lisp +++ b/src/code/cross-make-load-form.lisp @@ -35,7 +35,7 @@ (in-package "SB!INT") (defun sb!xc:make-load-form-saving-slots (object &rest args - &key slot-names environment) + &key slot-names environment) (declare (ignore environment)) (if (member :sb-xc-host *features*) ;; we're still building the cross-compiler, so use the host's @@ -47,7 +47,7 @@ ;; target's MAKE-LOAD-FORM-SAVING-SLOTS; it would be nice to ;; share code with that if possible. -- CSR, 2002-05-30 (if slot-names - (bug "MAKE-LOAD-FORM-SAVING-SLOTS ~ + (bug "MAKE-LOAD-FORM-SAVING-SLOTS ~ called with :SLOT-NAMES argument during cross-compilation") - :sb-just-dump-it-normally))) + :sb-just-dump-it-normally))) diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index 12d9312..e57a563 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -63,7 +63,7 @@ (defun sb!kernel:array-header-p (x) (and (typep x 'array) (or (not (typep x 'simple-array)) - (/= (array-rank x) 1)))) + (/= (array-rank x) 1)))) ;;; GENESIS needs these at cross-compile time. The target ;;; implementation of these is reasonably efficient by virtue of its @@ -80,10 +80,10 @@ ;; of this function at cross-compile time don't really care if ;; the count is a little too high.) -- WHN 19990826 (multiple-value-bind (symbol status) - (find-symbol (symbol-name i) package) - (declare (ignore symbol)) - (when (member status '(:internal :inherited)) - (incf result)))) + (find-symbol (symbol-name i) package) + (declare (ignore symbol)) + (when (member status '(:internal :inherited)) + (incf result)))) result)) (defun package-external-symbol-count (package) (let ((result 0)) @@ -144,8 +144,8 @@ (defmacro without-package-locks (&body body) `(progn ,@body)) -(defmacro with-single-package-locked-error ((&optional kind thing &rest format) - &body body) +(defmacro with-single-package-locked-error ((&optional kind thing &rest format) + &body body) (declare (ignore kind thing format)) `(progn ,@body)) diff --git a/src/code/cross-sap.lisp b/src/code/cross-sap.lisp index 574adeb..46f72de 100644 --- a/src/code/cross-sap.lisp +++ b/src/code/cross-sap.lisp @@ -16,7 +16,7 @@ ;;; so we need a compound type to represent it in the host Common Lisp ;;; at cross-compile time: (defstruct (system-area-pointer (:constructor make-sap) - (:conc-name "SAP-")) + (:conc-name "SAP-")) ;; the integer representation of the address (int (error "missing SAP-INT argument") :type sap-int :read-only t)) @@ -28,10 +28,10 @@ (make-sap :int (+ (sap-int sap) offset))) #.`(progn ,@(mapcar (lambda (info) - (destructuring-bind (sap-fun int-fun) info - `(defun ,sap-fun (x y) - (,int-fun (sap-int x) (sap-int y))))) - '((sap< <) (sap<= <=) (sap= =) (sap>= >=) (sap> >) (sap- -)))) + (destructuring-bind (sap-fun int-fun) info + `(defun ,sap-fun (x y) + (,int-fun (sap-int x) (sap-int y))))) + '((sap< <) (sap<= <=) (sap= =) (sap>= >=) (sap> >) (sap- -)))) ;;; dummies, defined so that we can declare they never return and ;;; thereby eliminate a thundering herd of optimization notes along @@ -41,26 +41,26 @@ (error "~S doesn't make sense on cross-compilation host." name)) #.`(progn ,@(mapcan (lambda (name) - `((declaim (ftype (function (system-area-pointer fixnum) nil) - ,name)) - (defun ,name (sap offset) - (declare (ignore sap offset)) - (sap-ref-stub ',name)) - ,@(let ((setter-stub (gensym "SETTER-STUB-"))) - `((defun ,setter-stub (foo sap offset) - (declare (ignore foo sap offset)) - (sap-ref-stub '(setf ,name))) - (defsetf ,name ,setter-stub))))) - '(sap-ref-8 - sap-ref-16 - sap-ref-32 - sap-ref-64 - sap-ref-sap - sap-ref-word - sap-ref-single - sap-ref-double - signed-sap-ref-8 - signed-sap-ref-16 - signed-sap-ref-32 - signed-sap-ref-64 - signed-sap-ref-word))) + `((declaim (ftype (function (system-area-pointer fixnum) nil) + ,name)) + (defun ,name (sap offset) + (declare (ignore sap offset)) + (sap-ref-stub ',name)) + ,@(let ((setter-stub (gensym "SETTER-STUB-"))) + `((defun ,setter-stub (foo sap offset) + (declare (ignore foo sap offset)) + (sap-ref-stub '(setf ,name))) + (defsetf ,name ,setter-stub))))) + '(sap-ref-8 + sap-ref-16 + sap-ref-32 + sap-ref-64 + sap-ref-sap + sap-ref-word + sap-ref-single + sap-ref-double + signed-sap-ref-8 + signed-sap-ref-16 + signed-sap-ref-32 + signed-sap-ref-64 + signed-sap-ref-word))) diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index 47fc196..c68b2ce 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -21,16 +21,16 @@ ;;; works.) (define-condition cross-type-style-warning (style-warning) ((call :initarg :call - :reader cross-type-style-warning-call) + :reader cross-type-style-warning-call) (message :reader cross-type-style-warning-message - #+cmu :initarg #+cmu :message ; (to stop bogus non-STYLE WARNING) - )) + #+cmu :initarg #+cmu :message ; (to stop bogus non-STYLE WARNING) + )) (:report (lambda (c s) - (format - s - "cross-compilation-time type ambiguity (should be OK) in ~S:~%~A" - (cross-type-style-warning-call c) - (cross-type-style-warning-message c))))) + (format + s + "cross-compilation-time type ambiguity (should be OK) in ~S:~%~A" + (cross-type-style-warning-call c) + (cross-type-style-warning-message c))))) ;;; This warning is issued when giving up on a type calculation where a ;;; conservative answer is acceptable. Since a conservative answer is @@ -38,8 +38,8 @@ (define-condition cross-type-giving-up-conservatively (cross-type-style-warning) ((message :initform "giving up conservatively" - #+cmu :reader #+cmu #.(gensym) ; (to stop bogus non-STYLE WARNING) - ))) + #+cmu :reader #+cmu #.(gensym) ; (to stop bogus non-STYLE WARNING) + ))) ;;; This warning refers to the flexibility in the ANSI spec with ;;; regard to run-time distinctions between floating point types. @@ -62,34 +62,34 @@ ;;; situation will get a lot more complicated. (defun warn-possible-cross-type-float-info-loss (call) (when (or (subtypep 'single-float 'double-float) - (subtypep 'double-float 'single-float)) + (subtypep 'double-float 'single-float)) (warn "possible floating point information loss in ~S" call))) (defun sb!xc:type-of (object) (let ((raw-result (type-of object))) (cond ((or (subtypep raw-result 'float) - (subtypep raw-result 'complex)) - (warn-possible-cross-type-float-info-loss - `(sb!xc:type-of ,object)) - raw-result) - ((subtypep raw-result 'integer) - (cond ((<= 0 object 1) - 'bit) - (;; We can't rely on the host's opinion of whether - ;; it's a FIXNUM, but instead test against target - ;; MOST-fooITIVE-FIXNUM limits. - (fixnump object) - 'fixnum) - (t - 'integer))) + (subtypep raw-result 'complex)) + (warn-possible-cross-type-float-info-loss + `(sb!xc:type-of ,object)) + raw-result) + ((subtypep raw-result 'integer) + (cond ((<= 0 object 1) + 'bit) + (;; We can't rely on the host's opinion of whether + ;; it's a FIXNUM, but instead test against target + ;; MOST-fooITIVE-FIXNUM limits. + (fixnump object) + 'fixnum) + (t + 'integer))) ((subtypep raw-result 'simple-string) `(simple-base-string ,(length object))) ((subtypep raw-result 'string) 'base-string) - ((some (lambda (type) (subtypep raw-result type)) - '(array character list symbol)) - raw-result) - (t - (error "can't handle TYPE-OF ~S in cross-compilation" object))))) + ((some (lambda (type) (subtypep raw-result type)) + '(array character list symbol)) + raw-result) + (t + (error "can't handle TYPE-OF ~S in cross-compilation" object))))) ;;; Is SYMBOL in the CL package? Note that we're testing this on the ;;; cross-compilation host, which could do things any old way. In @@ -110,214 +110,214 @@ (defun cross-typep (host-object raw-target-type) (let ((target-type (type-expand raw-target-type))) (flet ((warn-and-give-up () - ;; We don't have to keep track of this as long as system - ;; performance is acceptable, since giving up - ;; conservatively is a safe way out. - #+nil - (warn 'cross-type-giving-up-conservatively - :call `(cross-typep ,host-object ,raw-target-type)) - (values nil nil)) - (warn-about-possible-float-info-loss () - (warn-possible-cross-type-float-info-loss - `(cross-typep ,host-object ,raw-target-type))) - ;; a convenient idiom for making more matches to special cases: - ;; Test both forms of target type for membership in LIST. - ;; - ;; (In order to avoid having to use too much deep knowledge - ;; of types, it's sometimes convenient to test RAW-TARGET-TYPE - ;; as well as the expanded type, since we can get matches with - ;; just EQL. E.g. SIMPLE-STRING can be matched with EQL, while - ;; safely matching its expansion, - ;; (OR (SIMPLE-ARRAY CHARACTER (*)) (SIMPLE-BASE-STRING *)) - ;; would require logic clever enough to know that, e.g., OR is - ;; commutative.) - (target-type-is-in (list) - (or (member raw-target-type list) - (member target-type list)))) + ;; We don't have to keep track of this as long as system + ;; performance is acceptable, since giving up + ;; conservatively is a safe way out. + #+nil + (warn 'cross-type-giving-up-conservatively + :call `(cross-typep ,host-object ,raw-target-type)) + (values nil nil)) + (warn-about-possible-float-info-loss () + (warn-possible-cross-type-float-info-loss + `(cross-typep ,host-object ,raw-target-type))) + ;; a convenient idiom for making more matches to special cases: + ;; Test both forms of target type for membership in LIST. + ;; + ;; (In order to avoid having to use too much deep knowledge + ;; of types, it's sometimes convenient to test RAW-TARGET-TYPE + ;; as well as the expanded type, since we can get matches with + ;; just EQL. E.g. SIMPLE-STRING can be matched with EQL, while + ;; safely matching its expansion, + ;; (OR (SIMPLE-ARRAY CHARACTER (*)) (SIMPLE-BASE-STRING *)) + ;; would require logic clever enough to know that, e.g., OR is + ;; commutative.) + (target-type-is-in (list) + (or (member raw-target-type list) + (member target-type list)))) (cond (;; Handle various SBCL-specific types which can't exist on - ;; the ANSI cross-compilation host. KLUDGE: This code will - ;; need to be tweaked by hand if the names of these types - ;; ever change, ugh! - (if (consp target-type) - (member (car target-type) - '(sb!alien:alien)) - (member target-type - '(system-area-pointer - funcallable-instance - sb!alien-internals:alien-value))) - (values nil t)) - (;; special case when TARGET-TYPE isn't a type spec, but - ;; instead a CLASS object. - (typep target-type 'class) - (bug "We don't support CROSS-TYPEP of CLASS type specifiers")) - ((and (symbolp target-type) - (find-classoid target-type nil) - (sb!xc:subtypep target-type 'cl:structure-object) - (typep host-object '(or symbol number list character))) - (values nil t)) - ((and (symbolp target-type) - (find-class target-type nil) - (subtypep target-type 'sb!kernel::structure!object)) - (values (typep host-object target-type) t)) - (;; easy cases of arrays and vectors - (target-type-is-in - '(array simple-string simple-vector string vector)) - (values (typep host-object target-type) t)) - (;; general cases of vectors - (and (not (unknown-type-p (values-specifier-type target-type))) - (sb!xc:subtypep target-type 'cl:vector)) - (if (vectorp host-object) - (warn-and-give-up) ; general-case vectors being way too hard - (values nil t))) ; but "obviously not a vector" being easy - (;; general cases of arrays - (and (not (unknown-type-p (values-specifier-type target-type))) - (sb!xc:subtypep target-type 'cl:array)) - (if (arrayp host-object) - (warn-and-give-up) ; general-case arrays being way too hard - (values nil t))) ; but "obviously not an array" being easy - ((target-type-is-in '(*)) - ;; KLUDGE: SBCL has * as an explicit wild type. While - ;; this is sort of logical (because (e.g. (ARRAY * 1)) is - ;; a valid type) it's not ANSI: looking at the ANSI - ;; definitions of complex types like like ARRAY shows - ;; that they consider * different from other type names. - ;; Someday we should probably get rid of this non-ANSIism - ;; in base SBCL, but until we do, we might as well here - ;; in the cross compiler. And in order to make sure that - ;; we don't continue doing it after we someday patch - ;; SBCL's type system so that * is no longer a type, we - ;; make this assertion. -- WHN 2001-08-08 - (aver (typep (values-specifier-type '*) 'named-type)) - (values t t)) - (;; Many simple types are guaranteed to correspond exactly - ;; between any host ANSI Common Lisp and the target - ;; Common Lisp. (Some array types are too, but they - ;; were picked off earlier.) - (target-type-is-in - '(atom bit character complex cons float function integer keyword - list nil null number rational real signed-byte symbol t - unsigned-byte)) - (values (typep host-object target-type) t)) - (;; Floating point types are guaranteed to correspond, - ;; too, but less exactly. - (target-type-is-in - '(single-float double-float)) - (cond ((floatp host-object) - (warn-about-possible-float-info-loss) - (values (typep host-object target-type) t)) - (t - (values nil t)))) - (;; Complexes suffer the same kind of problems as arrays - (and (not (unknown-type-p (values-specifier-type target-type))) - (sb!xc:subtypep target-type 'cl:complex)) - (if (complexp host-object) - (warn-and-give-up) ; general-case complexes being way too hard - (values nil t))) ; but "obviously not a complex" being easy - ;; Some types require translation between the cross-compilation - ;; host Common Lisp and the target SBCL. - ((target-type-is-in '(classoid)) - (values (typep host-object 'classoid) t)) - ((target-type-is-in '(fixnum)) - (values (fixnump host-object) t)) - ;; Some types are too hard to handle in the positive - ;; case, but at least we can be confident in a large - ;; fraction of the negative cases.. - ((target-type-is-in - '(base-string simple-base-string simple-string)) - (if (stringp host-object) - (warn-and-give-up) - (values nil t))) - ((target-type-is-in '(character base-char)) - (cond ((typep host-object 'standard-char) - (values t t)) - ((not (characterp host-object)) - (values nil t)) - (t - (warn-and-give-up)))) - ((target-type-is-in '(stream instance)) - ;; Neither target CL:STREAM nor target SB!KERNEL:INSTANCE - ;; is implemented as a STRUCTURE-OBJECT, so they'll fall - ;; through the tests above. We don't want to assume too - ;; much about them here, but at least we know enough - ;; about them to say that neither T nor NIL nor indeed - ;; any other symbol in the cross-compilation host is one. - ;; That knowledge suffices to answer so many of the - ;; questions that the cross-compiler asks that it's well - ;; worth special-casing it here. - (if (symbolp host-object) - (values nil t) - (warn-and-give-up))) - ;; various hacks for composite types.. - ((consp target-type) - (let ((first (first target-type)) - (rest (rest target-type))) - (case first - ;; Many complex types are guaranteed to correspond exactly - ;; between any host ANSI Common Lisp and the target SBCL. - ((integer member mod rational real signed-byte unsigned-byte) - (values (typep host-object target-type) t)) - ;; Floating point types are guaranteed to correspond, - ;; too, but less exactly. - ((single-float double-float) - (cond ((floatp host-object) - (warn-about-possible-float-info-loss) - (values (typep host-object target-type) t)) - (t - (values nil t)))) - ;; Some complex types have translations that are less - ;; trivial. - (and (every/type #'cross-typep host-object rest)) - (or (any/type #'cross-typep host-object rest)) - ;; If we want to work with the KEYWORD type, we need - ;; to grok (SATISFIES KEYWORDP). - (satisfies - (destructuring-bind (predicate-name) rest - (if (and (in-cl-package-p predicate-name) - (fboundp predicate-name)) - ;; Many predicates like KEYWORDP, ODDP, PACKAGEP, - ;; and NULL correspond between host and target. - ;; But we still need to handle errors, because - ;; the code which calls us may not understand - ;; that a type is unreachable. (E.g. when compiling - ;; (AND STRING (SATISFIES ARRAY-HAS-FILL-POINTER-P)) - ;; CTYPEP may be called on the SATISFIES expression - ;; even for non-STRINGs.) - (multiple-value-bind (result error?) - (ignore-errors (funcall predicate-name - host-object)) - (if error? - (values nil nil) - (values result t))) - ;; For symbols not in the CL package, it's not - ;; in general clear how things correspond - ;; between host and target, so we punt. - (warn-and-give-up)))) - ;; Some complex types are too hard to handle in the - ;; positive case, but at least we can be confident in - ;; a large fraction of the negative cases.. - ((base-string simple-base-string simple-string) - (if (stringp host-object) - (warn-and-give-up) - (values nil t))) - ((vector simple-vector) - (if (vectorp host-object) - (warn-and-give-up) - (values nil t))) - ((array simple-array) - (if (arrayp host-object) - (warn-and-give-up) - (values nil t))) - (function - (if (functionp host-object) - (warn-and-give-up) - (values nil t))) - ;; And the Common Lisp type system is complicated, - ;; and we don't try to implement everything. - (otherwise (warn-and-give-up))))) - ;; And the Common Lisp type system is complicated, and - ;; we don't try to implement everything. - (t - (warn-and-give-up)))))) + ;; the ANSI cross-compilation host. KLUDGE: This code will + ;; need to be tweaked by hand if the names of these types + ;; ever change, ugh! + (if (consp target-type) + (member (car target-type) + '(sb!alien:alien)) + (member target-type + '(system-area-pointer + funcallable-instance + sb!alien-internals:alien-value))) + (values nil t)) + (;; special case when TARGET-TYPE isn't a type spec, but + ;; instead a CLASS object. + (typep target-type 'class) + (bug "We don't support CROSS-TYPEP of CLASS type specifiers")) + ((and (symbolp target-type) + (find-classoid target-type nil) + (sb!xc:subtypep target-type 'cl:structure-object) + (typep host-object '(or symbol number list character))) + (values nil t)) + ((and (symbolp target-type) + (find-class target-type nil) + (subtypep target-type 'sb!kernel::structure!object)) + (values (typep host-object target-type) t)) + (;; easy cases of arrays and vectors + (target-type-is-in + '(array simple-string simple-vector string vector)) + (values (typep host-object target-type) t)) + (;; general cases of vectors + (and (not (unknown-type-p (values-specifier-type target-type))) + (sb!xc:subtypep target-type 'cl:vector)) + (if (vectorp host-object) + (warn-and-give-up) ; general-case vectors being way too hard + (values nil t))) ; but "obviously not a vector" being easy + (;; general cases of arrays + (and (not (unknown-type-p (values-specifier-type target-type))) + (sb!xc:subtypep target-type 'cl:array)) + (if (arrayp host-object) + (warn-and-give-up) ; general-case arrays being way too hard + (values nil t))) ; but "obviously not an array" being easy + ((target-type-is-in '(*)) + ;; KLUDGE: SBCL has * as an explicit wild type. While + ;; this is sort of logical (because (e.g. (ARRAY * 1)) is + ;; a valid type) it's not ANSI: looking at the ANSI + ;; definitions of complex types like like ARRAY shows + ;; that they consider * different from other type names. + ;; Someday we should probably get rid of this non-ANSIism + ;; in base SBCL, but until we do, we might as well here + ;; in the cross compiler. And in order to make sure that + ;; we don't continue doing it after we someday patch + ;; SBCL's type system so that * is no longer a type, we + ;; make this assertion. -- WHN 2001-08-08 + (aver (typep (values-specifier-type '*) 'named-type)) + (values t t)) + (;; Many simple types are guaranteed to correspond exactly + ;; between any host ANSI Common Lisp and the target + ;; Common Lisp. (Some array types are too, but they + ;; were picked off earlier.) + (target-type-is-in + '(atom bit character complex cons float function integer keyword + list nil null number rational real signed-byte symbol t + unsigned-byte)) + (values (typep host-object target-type) t)) + (;; Floating point types are guaranteed to correspond, + ;; too, but less exactly. + (target-type-is-in + '(single-float double-float)) + (cond ((floatp host-object) + (warn-about-possible-float-info-loss) + (values (typep host-object target-type) t)) + (t + (values nil t)))) + (;; Complexes suffer the same kind of problems as arrays + (and (not (unknown-type-p (values-specifier-type target-type))) + (sb!xc:subtypep target-type 'cl:complex)) + (if (complexp host-object) + (warn-and-give-up) ; general-case complexes being way too hard + (values nil t))) ; but "obviously not a complex" being easy + ;; Some types require translation between the cross-compilation + ;; host Common Lisp and the target SBCL. + ((target-type-is-in '(classoid)) + (values (typep host-object 'classoid) t)) + ((target-type-is-in '(fixnum)) + (values (fixnump host-object) t)) + ;; Some types are too hard to handle in the positive + ;; case, but at least we can be confident in a large + ;; fraction of the negative cases.. + ((target-type-is-in + '(base-string simple-base-string simple-string)) + (if (stringp host-object) + (warn-and-give-up) + (values nil t))) + ((target-type-is-in '(character base-char)) + (cond ((typep host-object 'standard-char) + (values t t)) + ((not (characterp host-object)) + (values nil t)) + (t + (warn-and-give-up)))) + ((target-type-is-in '(stream instance)) + ;; Neither target CL:STREAM nor target SB!KERNEL:INSTANCE + ;; is implemented as a STRUCTURE-OBJECT, so they'll fall + ;; through the tests above. We don't want to assume too + ;; much about them here, but at least we know enough + ;; about them to say that neither T nor NIL nor indeed + ;; any other symbol in the cross-compilation host is one. + ;; That knowledge suffices to answer so many of the + ;; questions that the cross-compiler asks that it's well + ;; worth special-casing it here. + (if (symbolp host-object) + (values nil t) + (warn-and-give-up))) + ;; various hacks for composite types.. + ((consp target-type) + (let ((first (first target-type)) + (rest (rest target-type))) + (case first + ;; Many complex types are guaranteed to correspond exactly + ;; between any host ANSI Common Lisp and the target SBCL. + ((integer member mod rational real signed-byte unsigned-byte) + (values (typep host-object target-type) t)) + ;; Floating point types are guaranteed to correspond, + ;; too, but less exactly. + ((single-float double-float) + (cond ((floatp host-object) + (warn-about-possible-float-info-loss) + (values (typep host-object target-type) t)) + (t + (values nil t)))) + ;; Some complex types have translations that are less + ;; trivial. + (and (every/type #'cross-typep host-object rest)) + (or (any/type #'cross-typep host-object rest)) + ;; If we want to work with the KEYWORD type, we need + ;; to grok (SATISFIES KEYWORDP). + (satisfies + (destructuring-bind (predicate-name) rest + (if (and (in-cl-package-p predicate-name) + (fboundp predicate-name)) + ;; Many predicates like KEYWORDP, ODDP, PACKAGEP, + ;; and NULL correspond between host and target. + ;; But we still need to handle errors, because + ;; the code which calls us may not understand + ;; that a type is unreachable. (E.g. when compiling + ;; (AND STRING (SATISFIES ARRAY-HAS-FILL-POINTER-P)) + ;; CTYPEP may be called on the SATISFIES expression + ;; even for non-STRINGs.) + (multiple-value-bind (result error?) + (ignore-errors (funcall predicate-name + host-object)) + (if error? + (values nil nil) + (values result t))) + ;; For symbols not in the CL package, it's not + ;; in general clear how things correspond + ;; between host and target, so we punt. + (warn-and-give-up)))) + ;; Some complex types are too hard to handle in the + ;; positive case, but at least we can be confident in + ;; a large fraction of the negative cases.. + ((base-string simple-base-string simple-string) + (if (stringp host-object) + (warn-and-give-up) + (values nil t))) + ((vector simple-vector) + (if (vectorp host-object) + (warn-and-give-up) + (values nil t))) + ((array simple-array) + (if (arrayp host-object) + (warn-and-give-up) + (values nil t))) + (function + (if (functionp host-object) + (warn-and-give-up) + (values nil t))) + ;; And the Common Lisp type system is complicated, + ;; and we don't try to implement everything. + (otherwise (warn-and-give-up))))) + ;; And the Common Lisp type system is complicated, and + ;; we don't try to implement everything. + (t + (warn-and-give-up)))))) ;;; This is an incomplete TYPEP which runs at cross-compile time to ;;; tell whether OBJECT is the host Lisp representation of a target @@ -333,17 +333,17 @@ ;; A program that calls TYPEP doesn't want uncertainty and ;; probably can't handle it. (if certain-p - opinion - (error "uncertain in SB!XC:TYPEP ~S ~S" - host-object - target-type-spec)))) + opinion + (error "uncertain in SB!XC:TYPEP ~S ~S" + host-object + target-type-spec)))) ;;; This is an incomplete, portable implementation for use at ;;; cross-compile time only. (defun ctypep (obj ctype) (check-type ctype ctype) (let (;; the Common Lisp type specifier corresponding to CTYPE - (type (type-specifier ctype))) + (type (type-specifier ctype))) (check-type type (or symbol cons)) (cross-typep obj type))) @@ -351,14 +351,14 @@ (typecase x (function (if (typep x 'generic-function) - ;; Since at cross-compile time we build a CLOS-free bootstrap - ;; version of SBCL, it's unclear how to explain to it what a - ;; generic function is. - (error "not implemented: cross CTYPE-OF generic function") - ;; There's no ANSI way to find out what the function is - ;; declared to be, so we just return the CTYPE for the - ;; most-general function. - *universal-fun-type*)) + ;; Since at cross-compile time we build a CLOS-free bootstrap + ;; version of SBCL, it's unclear how to explain to it what a + ;; generic function is. + (error "not implemented: cross CTYPE-OF generic function") + ;; There's no ANSI way to find out what the function is + ;; declared to be, so we just return the CTYPE for the + ;; most-general function. + *universal-fun-type*)) (symbol (make-member-type :members (list x))) (number @@ -371,20 +371,20 @@ (array (let ((etype (specifier-type (array-element-type x)))) (make-array-type :dimensions (array-dimensions x) - :complexp (not (typep x 'simple-array)) - :element-type etype - :specialized-element-type etype))) + :complexp (not (typep x 'simple-array)) + :element-type etype + :specialized-element-type etype))) (cons (specifier-type 'cons)) (character (cond ((typep x 'standard-char) - ;; (Note that SBCL doesn't distinguish between BASE-CHAR and - ;; CHARACTER.) - (specifier-type 'base-char)) - ((not (characterp x)) - nil) - (t - ;; Beyond this, there seems to be no portable correspondence. - (error "can't map host Lisp CHARACTER ~S to target Lisp" x)))) + ;; (Note that SBCL doesn't distinguish between BASE-CHAR and + ;; CHARACTER.) + (specifier-type 'base-char)) + ((not (characterp x)) + nil) + (t + ;; Beyond this, there seems to be no portable correspondence. + (error "can't map host Lisp CHARACTER ~S to target Lisp" x)))) (structure!object (find-classoid (uncross (class-name (class-of x))))) (t diff --git a/src/code/debug-info.lisp b/src/code/debug-info.lisp index 3ca15e0..991d158 100644 --- a/src/code/debug-info.lisp +++ b/src/code/debug-info.lisp @@ -17,13 +17,13 @@ ;;; Compiled debug variables are in a packed binary representation in the ;;; DEBUG-FUN-VARS: ;;; single byte of boolean flags: -;;; uninterned name -;;; packaged name -;;; environment-live -;;; has distinct save location -;;; has ID (name not unique in this fun) -;;; minimal debug-info argument (name generated as ARG-0, ...) -;;; deleted: placeholder for unused minimal argument +;;; uninterned name +;;; packaged name +;;; environment-live +;;; has distinct save location +;;; has ID (name not unique in this fun) +;;; minimal debug-info argument (name generated as ARG-0, ...) +;;; deleted: placeholder for unused minimal argument ;;; [name length in bytes (as var-length integer), if not minimal] ;;; [...name bytes..., if not minimal] ;;; [if packaged, var-length integer that is package name length] @@ -33,20 +33,20 @@ ;;; [If has save SC, SC-OFFSET of save location (as var-length integer)] ;;; FIXME: The first two are no longer used in SBCL. -;;;(defconstant compiled-debug-var-uninterned #b00000001) -;;;(defconstant compiled-debug-var-packaged #b00000010) -(def!constant compiled-debug-var-environment-live #b00000100) -(def!constant compiled-debug-var-save-loc-p #b00001000) -(def!constant compiled-debug-var-id-p #b00010000) -(def!constant compiled-debug-var-minimal-p #b00100000) -(def!constant compiled-debug-var-deleted-p #b01000000) +;;;(defconstant compiled-debug-var-uninterned #b00000001) +;;;(defconstant compiled-debug-var-packaged #b00000010) +(def!constant compiled-debug-var-environment-live #b00000100) +(def!constant compiled-debug-var-save-loc-p #b00001000) +(def!constant compiled-debug-var-id-p #b00010000) +(def!constant compiled-debug-var-minimal-p #b00100000) +(def!constant compiled-debug-var-deleted-p #b01000000) ;;;; compiled debug blocks ;;;; ;;;; Compiled debug blocks are in a packed binary representation in the ;;;; DEBUG-FUN-BLOCKS: ;;;; number of successors + bit flags (single byte) -;;;; elsewhere-p +;;;; elsewhere-p ;;;; ...ordinal number of each successor in the function's blocks vector... ;;;; number of locations in this block ;;;; kind of first location (single byte) @@ -70,7 +70,7 @@ (def!struct (debug-fun (:constructor nil))) (def!struct (compiled-debug-fun (:include debug-fun) - #-sb-xc-host (:pure t)) + #-sb-xc-host (:pure t)) ;; KLUDGE: Courtesy of more than a decade of, ah, organic growth in ;; CMU CL, there are two distinct -- but coupled -- mechanisms to ;; finding the name of a function. The slot here is one mechanism @@ -196,33 +196,33 @@ ;;; of records in this format: ;;; name representation + kind + return convention (single byte) ;;; bit flags (single byte) -;;; setf, nfp, variables +;;; setf, nfp, variables ;;; [package name length (as var-length int), if name is packaged] ;;; [...package name bytes, if name is packaged] ;;; [name length (as var-length int), if there is a name] ;;; [...name bytes, if there is a name] ;;; [variables length (as var-length int), if variables flag] ;;; [...bytes holding variable descriptions] -;;; If variables are dumped (level 1), then the variables are all -;;; arguments (in order) with the minimal-arg bit set. +;;; If variables are dumped (level 1), then the variables are all +;;; arguments (in order) with the minimal-arg bit set. ;;; [If returns is specified, then the number of return values] ;;; [...sequence of var-length ints holding sc-offsets of the return -;;; value locations, if fixed return values are specified.] +;;; value locations, if fixed return values are specified.] ;;; return-pc location sc-offset (as var-length int) ;;; old-fp location sc-offset (as var-length int) ;;; [nfp location sc-offset (as var-length int), if nfp flag] ;;; code-start-pc (as a var-length int) -;;; This field implicitly encodes start of this function's code in the -;;; function map, as a delta from the previous function's code start. -;;; If the first function in the component, then this is the delta from -;;; 0 (i.e. the absolute offset.) +;;; This field implicitly encodes start of this function's code in the +;;; function map, as a delta from the previous function's code start. +;;; If the first function in the component, then this is the delta from +;;; 0 (i.e. the absolute offset.) ;;; start-pc (as a var-length int) -;;; This encodes the environment start PC as an offset from the -;;; code-start PC. +;;; This encodes the environment start PC as an offset from the +;;; code-start PC. ;;; elsewhere-pc -;;; This encodes the elsewhere code start for this function, as a delta -;;; from the previous function's elsewhere code start. (i.e. the -;;; encoding is the same as for code-start-pc.) +;;; This encodes the elsewhere code start for this function, as a delta +;;; from the previous function's elsewhere code start. (i.e. the +;;; encoding is the same as for code-start-pc.) ;;; ### For functions with XEPs, name could be represented more simply ;;; and compactly as some sort of info about with how to find the @@ -272,14 +272,14 @@ ;; component came from, in the order that they were read. ;; ;; KLUDGE: comment from CMU CL: - ;; *** NOTE: the offset of this slot is wired into the fasl dumper + ;; *** NOTE: the offset of this slot is wired into the fasl dumper ;; *** so that it can backpatch the source info when compilation ;; *** is complete. (source nil)) (def!struct (compiled-debug-info - (:include debug-info) - #-sb-xc-host (:pure t)) + (:include debug-info) + #-sb-xc-host (:pure t)) ;; a SIMPLE-VECTOR of alternating DEBUG-FUN objects and fixnum ;; PCs, used to map PCs to functions, so that we can figure out what ;; function we were running in. Each function is valid between the diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 77fd6dc..9d1097f 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -43,64 +43,64 @@ (define-condition no-debug-fun-returns (debug-condition) ((debug-fun :reader no-debug-fun-returns-debug-fun - :initarg :debug-fun)) + :initarg :debug-fun)) #!+sb-doc (:documentation "The system could not return values from a frame with DEBUG-FUN since it lacked information about returning values.") (:report (lambda (condition stream) - (let ((fun (debug-fun-fun - (no-debug-fun-returns-debug-fun condition)))) - (format stream - "~&Cannot return values from ~:[frame~;~:*~S~] since ~ + (let ((fun (debug-fun-fun + (no-debug-fun-returns-debug-fun condition)))) + (format stream + "~&Cannot return values from ~:[frame~;~:*~S~] since ~ the debug information lacks details about returning ~ values here." - fun))))) + fun))))) (define-condition no-debug-blocks (debug-condition) ((debug-fun :reader no-debug-blocks-debug-fun - :initarg :debug-fun)) + :initarg :debug-fun)) #!+sb-doc (:documentation "The debug-fun has no debug-block information.") (:report (lambda (condition stream) - (format stream "~&~S has no debug-block information." - (no-debug-blocks-debug-fun condition))))) + (format stream "~&~S has no debug-block information." + (no-debug-blocks-debug-fun condition))))) (define-condition no-debug-vars (debug-condition) ((debug-fun :reader no-debug-vars-debug-fun - :initarg :debug-fun)) + :initarg :debug-fun)) #!+sb-doc (:documentation "The DEBUG-FUN has no DEBUG-VAR information.") (:report (lambda (condition stream) - (format stream "~&~S has no debug variable information." - (no-debug-vars-debug-fun condition))))) + (format stream "~&~S has no debug variable information." + (no-debug-vars-debug-fun condition))))) (define-condition lambda-list-unavailable (debug-condition) ((debug-fun :reader lambda-list-unavailable-debug-fun - :initarg :debug-fun)) + :initarg :debug-fun)) #!+sb-doc (:documentation "The DEBUG-FUN has no lambda list since argument DEBUG-VARs are unavailable.") (:report (lambda (condition stream) - (format stream "~&~S has no lambda-list information available." - (lambda-list-unavailable-debug-fun condition))))) + (format stream "~&~S has no lambda-list information available." + (lambda-list-unavailable-debug-fun condition))))) (define-condition invalid-value (debug-condition) ((debug-var :reader invalid-value-debug-var :initarg :debug-var) (frame :reader invalid-value-frame :initarg :frame)) (:report (lambda (condition stream) - (format stream "~&~S has :invalid or :unknown value in ~S." - (invalid-value-debug-var condition) - (invalid-value-frame condition))))) + (format stream "~&~S has :invalid or :unknown value in ~S." + (invalid-value-debug-var condition) + (invalid-value-frame condition))))) (define-condition ambiguous-var-name (debug-condition) ((name :reader ambiguous-var-name-name :initarg :name) (frame :reader ambiguous-var-name-frame :initarg :frame)) (:report (lambda (condition stream) - (format stream "~&~S names more than one valid variable in ~S." - (ambiguous-var-name-name condition) - (ambiguous-var-name-frame condition))))) + (format stream "~&~S names more than one valid variable in ~S." + (ambiguous-var-name-name condition) + (ambiguous-var-name-frame condition))))) ;;;; errors and DEBUG-SIGNAL @@ -121,44 +121,44 @@ (define-condition unhandled-debug-condition (debug-error) ((condition :reader unhandled-debug-condition-condition :initarg :condition)) (:report (lambda (condition stream) - (format stream "~&unhandled DEBUG-CONDITION:~%~A" - (unhandled-debug-condition-condition condition))))) + (format stream "~&unhandled DEBUG-CONDITION:~%~A" + (unhandled-debug-condition-condition condition))))) (define-condition unknown-code-location (debug-error) ((code-location :reader unknown-code-location-code-location - :initarg :code-location)) + :initarg :code-location)) (:report (lambda (condition stream) - (format stream "~&invalid use of an unknown code-location: ~S" - (unknown-code-location-code-location condition))))) + (format stream "~&invalid use of an unknown code-location: ~S" + (unknown-code-location-code-location condition))))) (define-condition unknown-debug-var (debug-error) ((debug-var :reader unknown-debug-var-debug-var :initarg :debug-var) (debug-fun :reader unknown-debug-var-debug-fun - :initarg :debug-fun)) + :initarg :debug-fun)) (:report (lambda (condition stream) - (format stream "~&~S is not in ~S." - (unknown-debug-var-debug-var condition) - (unknown-debug-var-debug-fun condition))))) + (format stream "~&~S is not in ~S." + (unknown-debug-var-debug-var condition) + (unknown-debug-var-debug-fun condition))))) (define-condition invalid-control-stack-pointer (debug-error) () (:report (lambda (condition stream) - (declare (ignore condition)) - (fresh-line stream) - (write-string "invalid control stack pointer" stream)))) + (declare (ignore condition)) + (fresh-line stream) + (write-string "invalid control stack pointer" stream)))) (define-condition frame-fun-mismatch (debug-error) ((code-location :reader frame-fun-mismatch-code-location - :initarg :code-location) + :initarg :code-location) (frame :reader frame-fun-mismatch-frame :initarg :frame) (form :reader frame-fun-mismatch-form :initarg :form)) (:report (lambda (condition stream) - (format - stream - "~&Form was preprocessed for ~S,~% but called on ~S:~% ~S" - (frame-fun-mismatch-code-location condition) - (frame-fun-mismatch-frame condition) - (frame-fun-mismatch-form condition))))) + (format + stream + "~&Form was preprocessed for ~S,~% but called on ~S:~% ~S" + (frame-fun-mismatch-code-location condition) + (frame-fun-mismatch-frame condition) + (frame-fun-mismatch-form condition))))) ;;; This signals debug-conditions. If they go unhandled, then signal ;;; an UNHANDLED-DEBUG-CONDITION error. @@ -182,7 +182,7 @@ ;;; These exist for caching data stored in packed binary form in ;;; compiler DEBUG-FUNs. (defstruct (debug-var (:constructor nil) - (:copier nil)) + (:copier nil)) ;; the name of the variable (symbol (missing-arg) :type symbol) ;; a unique integer identification relative to other variables with the same @@ -193,9 +193,9 @@ (def!method print-object ((debug-var debug-var) stream) (print-unreadable-object (debug-var stream :type t :identity t) (format stream - "~S ~W" - (debug-var-symbol debug-var) - (debug-var-id debug-var)))) + "~S ~W" + (debug-var-symbol debug-var) + (debug-var-id debug-var)))) #!+sb-doc (setf (fdocumentation 'debug-var-id 'function) @@ -203,10 +203,10 @@ with respect to other DEBUG-VARs in the same function.") (defstruct (compiled-debug-var - (:include debug-var) - (:constructor make-compiled-debug-var - (symbol id alive-p sc-offset save-sc-offset)) - (:copier nil)) + (:include debug-var) + (:constructor make-compiled-debug-var + (symbol id alive-p sc-offset save-sc-offset)) + (:copier nil)) ;; storage class and offset (unexported) (sc-offset nil :type sb!c:sc-offset) ;; storage class and offset when saved somewhere @@ -216,7 +216,7 @@ ;;; These represent call frames on the stack. (defstruct (frame (:constructor nil) - (:copier nil)) + (:copier nil)) ;; the next frame up, or NIL when top frame (up nil :type (or frame null)) ;; the previous frame down, or NIL when the bottom frame. Before @@ -239,11 +239,11 @@ (number 0 :type index)) (defstruct (compiled-frame - (:include frame) - (:constructor make-compiled-frame - (pointer up debug-fun code-location number - &optional escaped)) - (:copier nil)) + (:include frame) + (:constructor make-compiled-frame + (pointer up debug-fun code-location number + &optional escaped)) + (:copier nil)) ;; This indicates whether someone interrupted the frame. ;; (unexported). If escaped, this is a pointer to the state that was ;; saved when we were interrupted, an os_context_t, i.e. the third @@ -252,9 +252,9 @@ (def!method print-object ((obj compiled-frame) str) (print-unreadable-object (obj str :type t) (format str - "~S~:[~;, interrupted~]" - (debug-fun-name (frame-debug-fun obj)) - (compiled-frame-escaped obj)))) + "~S~:[~;, interrupted~]" + (debug-fun-name (frame-debug-fun obj)) + (compiled-frame-escaped obj)))) ;;;; DEBUG-FUNs @@ -265,7 +265,7 @@ ;;; that reference DEBUG-FUNs point to unique objects. This is ;;; due to the overhead in cached information. (defstruct (debug-fun (:constructor nil) - (:copier nil)) + (:copier nil)) ;; some representation of the function arguments. See ;; DEBUG-FUN-LAMBDA-LIST. ;; NOTE: must parse vars before parsing arg list stuff. @@ -283,10 +283,10 @@ (prin1 (debug-fun-name obj) stream))) (defstruct (compiled-debug-fun - (:include debug-fun) - (:constructor %make-compiled-debug-fun - (compiler-debug-fun component)) - (:copier nil)) + (:include debug-fun) + (:constructor %make-compiled-debug-fun + (compiler-debug-fun component)) + (:copier nil)) ;; compiler's dumped DEBUG-FUN information (unexported) (compiler-debug-fun nil :type sb!c::compiled-debug-fun) ;; code object (unexported). @@ -308,17 +308,17 @@ (defun make-compiled-debug-fun (compiler-debug-fun component) (or (gethash compiler-debug-fun *compiled-debug-funs*) (setf (gethash compiler-debug-fun *compiled-debug-funs*) - (%make-compiled-debug-fun compiler-debug-fun component)))) + (%make-compiled-debug-fun compiler-debug-fun component)))) (defstruct (bogus-debug-fun - (:include debug-fun) - (:constructor make-bogus-debug-fun - (%name &aux - (%lambda-list nil) - (%debug-vars nil) - (blocks nil) - (%function nil))) - (:copier nil)) + (:include debug-fun) + (:constructor make-bogus-debug-fun + (%name &aux + (%lambda-list nil) + (%debug-vars nil) + (blocks nil) + (%function nil))) + (:copier nil)) %name) (defvar *ir1-lambda-debug-fun* (make-hash-table :test 'eq)) @@ -328,7 +328,7 @@ ;;; These exist for caching data stored in packed binary form in compiler ;;; DEBUG-BLOCKs. (defstruct (debug-block (:constructor nil) - (:copier nil)) + (:copier nil)) ;; Code-locations where execution continues after this block. (successors nil :type list) ;; This indicates whether the block is a special glob of code shared @@ -350,10 +350,10 @@ "Return whether debug-block represents elsewhere code.") (defstruct (compiled-debug-block (:include debug-block) - (:constructor - make-compiled-debug-block - (code-locations successors elsewhere-p)) - (:copier nil)) + (:constructor + make-compiled-debug-block + (code-locations successors elsewhere-p)) + (:copier nil)) ;; code-location information for the block (code-locations nil :type simple-vector)) @@ -364,8 +364,8 @@ ;;; This is an internal structure that manages information about a ;;; breakpoint locations. See *COMPONENT-BREAKPOINT-OFFSETS*. (defstruct (breakpoint-data (:constructor make-breakpoint-data - (component offset)) - (:copier nil)) + (component offset)) + (:copier nil)) ;; This is the component in which the breakpoint lies. component ;; This is the byte offset into the component. @@ -377,14 +377,14 @@ (def!method print-object ((obj breakpoint-data) str) (print-unreadable-object (obj str :type t) (format str "~S at ~S" - (debug-fun-name - (debug-fun-from-pc (breakpoint-data-component obj) - (breakpoint-data-offset obj))) - (breakpoint-data-offset obj)))) + (debug-fun-name + (debug-fun-from-pc (breakpoint-data-component obj) + (breakpoint-data-offset obj))) + (breakpoint-data-offset obj)))) (defstruct (breakpoint (:constructor %make-breakpoint - (hook-fun what kind %info)) - (:copier nil)) + (hook-fun what kind %info)) + (:copier nil)) ;; This is the function invoked when execution encounters the ;; breakpoint. It takes a frame, the breakpoint, and optionally a ;; list of values. Values are supplied for :FUN-END breakpoints as @@ -398,7 +398,7 @@ ;; of breakpoint. :UNKNOWN-RETURN-PARTNER if this is the partner of ;; a :code-location breakpoint at an :UNKNOWN-RETURN code-location. (kind nil :type (member :code-location :fun-start :fun-end - :unknown-return-partner)) + :unknown-return-partner)) ;; Status helps the user and the implementation. (status :inactive :type (member :active :inactive :deleted)) ;; This is a backpointer to a breakpoint-data. @@ -428,18 +428,18 @@ (let ((what (breakpoint-what obj))) (print-unreadable-object (obj str :type t) (format str - "~S~:[~;~:*~S~]" - (etypecase what - (code-location what) - (debug-fun (debug-fun-name what))) - (etypecase what - (code-location nil) - (debug-fun (breakpoint-kind obj))))))) + "~S~:[~;~:*~S~]" + (etypecase what + (code-location what) + (debug-fun (debug-fun-name what))) + (etypecase what + (code-location nil) + (debug-fun (breakpoint-kind obj))))))) ;;;; CODE-LOCATIONs (defstruct (code-location (:constructor nil) - (:copier nil)) + (:copier nil)) ;; the DEBUG-FUN containing this CODE-LOCATION (debug-fun nil :type debug-fun) ;; This is initially :UNSURE. Upon first trying to access an @@ -463,15 +463,15 @@ (def!method print-object ((obj code-location) str) (print-unreadable-object (obj str :type t) (prin1 (debug-fun-name (code-location-debug-fun obj)) - str))) + str))) (defstruct (compiled-code-location - (:include code-location) - (:constructor make-known-code-location - (pc debug-fun %tlf-offset %form-number - %live-set kind &aux (%unknown-p nil))) - (:constructor make-compiled-code-location (pc debug-fun)) - (:copier nil)) + (:include code-location) + (:constructor make-known-code-location + (pc debug-fun %tlf-offset %form-number + %live-set kind &aux (%unknown-p nil))) + (:constructor make-compiled-code-location (pc debug-fun)) + (:copier nil)) ;; an index into DEBUG-FUN's component slot (pc nil :type index) ;; a bit-vector indexed by a variable's position in @@ -517,19 +517,19 @@ (defun control-stack-pointer-valid-p (x) (declare (type system-area-pointer x)) (let* (#!-stack-grows-downward-not-upward - (control-stack-start - (descriptor-sap *control-stack-start*)) - #!+stack-grows-downward-not-upward - (control-stack-end - (descriptor-sap *control-stack-end*))) + (control-stack-start + (descriptor-sap *control-stack-start*)) + #!+stack-grows-downward-not-upward + (control-stack-end + (descriptor-sap *control-stack-end*))) #!-stack-grows-downward-not-upward (and (sap< x (current-sp)) - (sap<= control-stack-start x) - (zerop (logand (sap-int x) #b11))) + (sap<= control-stack-start x) + (zerop (logand (sap-int x) #b11))) #!+stack-grows-downward-not-upward (and (sap>= x (current-sp)) - (sap> control-stack-end x) - (zerop (logand (sap-int x) #b11))))) + (sap> control-stack-end x) + (zerop (logand (sap-int x) #b11))))) (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer) (pc system-area-pointer)) @@ -537,7 +537,7 @@ (defun component-from-component-ptr (component-ptr) (declare (type system-area-pointer component-ptr)) (make-lisp-obj (logior (sap-int component-ptr) - sb!vm:other-pointer-lowtag))) + sb!vm:other-pointer-lowtag))) ;;;; (OR X86 X86-64) support @@ -549,13 +549,13 @@ (let ((component-ptr (component-ptr-from-pc pc))) (unless (sap= component-ptr (int-sap #x0)) (let* ((code (component-from-component-ptr component-ptr)) - (code-header-len (* (get-header-data code) sb!vm:n-word-bytes)) - (pc-offset (- (sap-int pc) - (- (get-lisp-obj-address code) - sb!vm:other-pointer-lowtag) - code-header-len))) -; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset) - (values pc-offset code))))) + (code-header-len (* (get-header-data code) sb!vm:n-word-bytes)) + (pc-offset (- (sap-int pc) + (- (get-lisp-obj-address code) + sb!vm:other-pointer-lowtag) + code-header-len))) +; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset) + (values pc-offset code))))) (defconstant sb!vm::nargs-offset #.sb!vm::ecx-offset) @@ -586,7 +586,7 @@ ;;; it manages to find a fp trail, see linux hack below. (defun x86-call-context (fp &key (depth 0)) (declare (type system-area-pointer fp) - (fixnum depth)) + (fixnum depth)) ;; (format t "*CC ~S ~S~%" fp depth) (cond ((not (control-stack-pointer-valid-p fp)) @@ -595,63 +595,63 @@ (t ;; Check the two possible frame pointers. (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset) - sb!vm::n-word-bytes)))) - (lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset) - sb!vm::n-word-bytes)))) - (c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes))) - (c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes)))) + sb!vm::n-word-bytes)))) + (lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset) + sb!vm::n-word-bytes)))) + (c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes))) + (c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes)))) #+nil (format t " lisp-ocfp=~S~% lisp-ra=~S~% c-ocfp=~S~% c-ra=~S~%" - lisp-ocfp lisp-ra c-ocfp c-ra) + lisp-ocfp lisp-ra c-ocfp c-ra) (cond ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp) - (ra-pointer-valid-p lisp-ra) - (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp) - (ra-pointer-valid-p c-ra)) - #+nil (format t - "*C Both valid ~S ~S ~S ~S~%" - lisp-ocfp lisp-ra c-ocfp c-ra) - ;; Look forward another step to check their validity. - (let ((lisp-path-fp (x86-call-context lisp-ocfp - :depth (1+ depth))) - (c-path-fp (x86-call-context c-ocfp :depth (1+ depth)))) - (cond ((and lisp-path-fp c-path-fp) + (ra-pointer-valid-p lisp-ra) + (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp) + (ra-pointer-valid-p c-ra)) + #+nil (format t + "*C Both valid ~S ~S ~S ~S~%" + lisp-ocfp lisp-ra c-ocfp c-ra) + ;; Look forward another step to check their validity. + (let ((lisp-path-fp (x86-call-context lisp-ocfp + :depth (1+ depth))) + (c-path-fp (x86-call-context c-ocfp :depth (1+ depth)))) + (cond ((and lisp-path-fp c-path-fp) ;; Both still seem valid - choose the lisp frame. #+nil (when (zerop depth) (format t - "debug: both still valid ~S ~S ~S ~S~%" + "debug: both still valid ~S ~S ~S ~S~%" lisp-ocfp lisp-ra c-ocfp c-ra)) - #!+freebsd - (if (sap> lisp-ocfp c-ocfp) + #!+freebsd + (if (sap> lisp-ocfp c-ocfp) (values lisp-ra lisp-ocfp) - (values c-ra c-ocfp)) + (values c-ra c-ocfp)) #!-freebsd (values lisp-ra lisp-ocfp)) - (lisp-path-fp - ;; The lisp convention is looking good. - #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra) - (values lisp-ra lisp-ocfp)) - (c-path-fp - ;; The C convention is looking good. - #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra) - (values c-ra c-ocfp)) - (t - ;; Neither seems right? - #+nil (format t "debug: no valid2 fp found ~S ~S~%" - lisp-ocfp c-ocfp) - nil)))) - ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp) - (ra-pointer-valid-p lisp-ra)) - ;; The lisp convention is looking good. - #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra) - (values lisp-ra lisp-ocfp)) - ((and (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp) - #!-linux (ra-pointer-valid-p c-ra)) - ;; The C convention is looking good. - #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra) - (values c-ra c-ocfp)) - (t - #+nil (format t "debug: no valid fp found ~S ~S~%" - lisp-ocfp c-ocfp) - nil)))))) + (lisp-path-fp + ;; The lisp convention is looking good. + #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra) + (values lisp-ra lisp-ocfp)) + (c-path-fp + ;; The C convention is looking good. + #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra) + (values c-ra c-ocfp)) + (t + ;; Neither seems right? + #+nil (format t "debug: no valid2 fp found ~S ~S~%" + lisp-ocfp c-ocfp) + nil)))) + ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp) + (ra-pointer-valid-p lisp-ra)) + ;; The lisp convention is looking good. + #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra) + (values lisp-ra lisp-ocfp)) + ((and (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp) + #!-linux (ra-pointer-valid-p c-ra)) + ;; The C convention is looking good. + #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra) + (values c-ra c-ocfp)) + (t + #+nil (format t "debug: no valid fp found ~S ~S~%" + lisp-ocfp c-ocfp) + nil)))))) ) ; #+x86 PROGN @@ -685,42 +685,42 @@ ;; them to COMPUTE-CALLING-FRAME. (let ((down (frame-%down frame))) (if (eq down :unparsed) - (let ((debug-fun (frame-debug-fun frame))) - (/noshow0 "in DOWN :UNPARSED case") - (setf (frame-%down frame) - (etypecase debug-fun - (compiled-debug-fun - (let ((c-d-f (compiled-debug-fun-compiler-debug-fun - debug-fun))) - (compute-calling-frame - (descriptor-sap - (get-context-value - frame ocfp-save-offset - (sb!c::compiled-debug-fun-old-fp c-d-f))) - (get-context-value - frame lra-save-offset - (sb!c::compiled-debug-fun-return-pc c-d-f)) - frame))) - (bogus-debug-fun - (let ((fp (frame-pointer frame))) - (when (control-stack-pointer-valid-p fp) - #!+(or x86 x86-64) - (multiple-value-bind (ra ofp) (x86-call-context fp) - (and ra (compute-calling-frame ofp ra frame))) - #!-(or x86 x86-64) - (compute-calling-frame - #!-alpha - (sap-ref-sap fp (* ocfp-save-offset - sb!vm:n-word-bytes)) - #!+alpha - (int-sap - (sap-ref-32 fp (* ocfp-save-offset - sb!vm:n-word-bytes))) - - (stack-ref fp lra-save-offset) - - frame))))))) - down))) + (let ((debug-fun (frame-debug-fun frame))) + (/noshow0 "in DOWN :UNPARSED case") + (setf (frame-%down frame) + (etypecase debug-fun + (compiled-debug-fun + (let ((c-d-f (compiled-debug-fun-compiler-debug-fun + debug-fun))) + (compute-calling-frame + (descriptor-sap + (get-context-value + frame ocfp-save-offset + (sb!c::compiled-debug-fun-old-fp c-d-f))) + (get-context-value + frame lra-save-offset + (sb!c::compiled-debug-fun-return-pc c-d-f)) + frame))) + (bogus-debug-fun + (let ((fp (frame-pointer frame))) + (when (control-stack-pointer-valid-p fp) + #!+(or x86 x86-64) + (multiple-value-bind (ra ofp) (x86-call-context fp) + (and ra (compute-calling-frame ofp ra frame))) + #!-(or x86 x86-64) + (compute-calling-frame + #!-alpha + (sap-ref-sap fp (* ocfp-save-offset + sb!vm:n-word-bytes)) + #!+alpha + (int-sap + (sap-ref-32 fp (* ocfp-save-offset + sb!vm:n-word-bytes))) + + (stack-ref fp lra-save-offset) + + frame))))))) + down))) ;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the ;;; standard save location offset on the stack. LOC is the saved @@ -728,57 +728,57 @@ #!-(or x86 x86-64) (defun get-context-value (frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) - (type sb!c:sc-offset loc)) + (type sb!c:sc-offset loc)) (let ((pointer (frame-pointer frame)) - (escaped (compiled-frame-escaped frame))) + (escaped (compiled-frame-escaped frame))) (if escaped - (sub-access-debug-var-slot pointer loc escaped) - (stack-ref pointer stack-slot)))) + (sub-access-debug-var-slot pointer loc escaped) + (stack-ref pointer stack-slot)))) #!+(or x86 x86-64) (defun get-context-value (frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) - (type sb!c:sc-offset loc)) + (type sb!c:sc-offset loc)) (let ((pointer (frame-pointer frame)) - (escaped (compiled-frame-escaped frame))) + (escaped (compiled-frame-escaped frame))) (if escaped - (sub-access-debug-var-slot pointer loc escaped) - (ecase stack-slot - (#.ocfp-save-offset - (stack-ref pointer stack-slot)) - (#.lra-save-offset - (sap-ref-sap pointer (- (* (1+ stack-slot) - sb!vm::n-word-bytes)))))))) + (sub-access-debug-var-slot pointer loc escaped) + (ecase stack-slot + (#.ocfp-save-offset + (stack-ref pointer stack-slot)) + (#.lra-save-offset + (sap-ref-sap pointer (- (* (1+ stack-slot) + sb!vm::n-word-bytes)))))))) #!-(or x86 x86-64) (defun (setf get-context-value) (value frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) - (type sb!c:sc-offset loc)) + (type sb!c:sc-offset loc)) (let ((pointer (frame-pointer frame)) - (escaped (compiled-frame-escaped frame))) + (escaped (compiled-frame-escaped frame))) (if escaped - (sub-set-debug-var-slot pointer loc value escaped) - (setf (stack-ref pointer stack-slot) value)))) + (sub-set-debug-var-slot pointer loc value escaped) + (setf (stack-ref pointer stack-slot) value)))) #!+(or x86 x86-64) (defun (setf get-context-value) (value frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) - (type sb!c:sc-offset loc)) + (type sb!c:sc-offset loc)) (let ((pointer (frame-pointer frame)) - (escaped (compiled-frame-escaped frame))) + (escaped (compiled-frame-escaped frame))) (if escaped - (sub-set-debug-var-slot pointer loc value escaped) - (ecase stack-slot - (#.ocfp-save-offset - (setf (stack-ref pointer stack-slot) value)) - (#.lra-save-offset - (setf (sap-ref-sap pointer (- (* (1+ stack-slot) - sb!vm::n-word-bytes))) value)))))) + (sub-set-debug-var-slot pointer loc value escaped) + (ecase stack-slot + (#.ocfp-save-offset + (setf (stack-ref pointer stack-slot) value)) + (#.lra-save-offset + (setf (sap-ref-sap pointer (- (* (1+ stack-slot) + sb!vm::n-word-bytes))) value)))))) (defun foreign-function-backtrace-name (sap) (let ((name (sap-foreign-symbol sap))) (if name - (format nil "foreign function: ~A" name) - (format nil "foreign function: #x~X" (sap-int sap))))) + (format nil "foreign function: ~A" name) + (format nil "foreign function: #x~X" (sap-int sap))))) ;;; This returns a frame for the one existing in time immediately ;;; prior to the frame referenced by current-fp. This is current-fp's @@ -799,45 +799,45 @@ (declare (type system-area-pointer caller)) (when (control-stack-pointer-valid-p caller) (multiple-value-bind (code pc-offset escaped) - (if lra - (multiple-value-bind (word-offset code) - (if (fixnump lra) - (let ((fp (frame-pointer up-frame))) - (values lra - (stack-ref fp (1+ lra-save-offset)))) - (values (get-header-data lra) - (lra-code-header lra))) - (if code - (values code - (* (1+ (- word-offset (get-header-data code))) - sb!vm:n-word-bytes) - nil) - (values :foreign-function - 0 - nil))) - (find-escaped-frame caller)) + (if lra + (multiple-value-bind (word-offset code) + (if (fixnump lra) + (let ((fp (frame-pointer up-frame))) + (values lra + (stack-ref fp (1+ lra-save-offset)))) + (values (get-header-data lra) + (lra-code-header lra))) + (if code + (values code + (* (1+ (- word-offset (get-header-data code))) + sb!vm:n-word-bytes) + nil) + (values :foreign-function + 0 + nil))) + (find-escaped-frame caller)) (if (and (code-component-p code) - (eq (%code-debug-info code) :bogus-lra)) - (let ((real-lra (code-header-ref code real-lra-slot))) - (compute-calling-frame caller real-lra up-frame)) - (let ((d-fun (case code - (:undefined-function - (make-bogus-debug-fun - "undefined function")) - (:foreign-function - (make-bogus-debug-fun - (foreign-function-backtrace-name - (int-sap (get-lisp-obj-address lra))))) - ((nil) - (make-bogus-debug-fun - "bogus stack frame")) - (t - (debug-fun-from-pc code pc-offset))))) - (make-compiled-frame caller up-frame d-fun - (code-location-from-pc d-fun pc-offset - escaped) - (if up-frame (1+ (frame-number up-frame)) 0) - escaped)))))) + (eq (%code-debug-info code) :bogus-lra)) + (let ((real-lra (code-header-ref code real-lra-slot))) + (compute-calling-frame caller real-lra up-frame)) + (let ((d-fun (case code + (:undefined-function + (make-bogus-debug-fun + "undefined function")) + (:foreign-function + (make-bogus-debug-fun + (foreign-function-backtrace-name + (int-sap (get-lisp-obj-address lra))))) + ((nil) + (make-bogus-debug-fun + "bogus stack frame")) + (t + (debug-fun-from-pc code pc-offset))))) + (make-compiled-frame caller up-frame d-fun + (code-location-from-pc d-fun pc-offset + escaped) + (if up-frame (1+ (frame-number up-frame)) 0) + escaped)))))) #!+(or x86 x86-64) (defun compute-calling-frame (caller ra up-frame) (declare (type system-area-pointer caller ra)) @@ -848,45 +848,45 @@ (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller) (/noshow0 "at COND") (cond (code - ;; If it's escaped it may be a function end breakpoint trap. - (when (and (code-component-p code) - (eq (%code-debug-info code) :bogus-lra)) - ;; If :bogus-lra grab the real lra. - (setq pc-offset (code-header-ref - code (1+ real-lra-slot))) - (setq code (code-header-ref code real-lra-slot)) - (aver code))) - ((not escaped) - (multiple-value-setq (pc-offset code) - (compute-lra-data-from-pc ra)) - (unless code - (setf code :foreign-function - pc-offset 0)))) + ;; If it's escaped it may be a function end breakpoint trap. + (when (and (code-component-p code) + (eq (%code-debug-info code) :bogus-lra)) + ;; If :bogus-lra grab the real lra. + (setq pc-offset (code-header-ref + code (1+ real-lra-slot))) + (setq code (code-header-ref code real-lra-slot)) + (aver code))) + ((not escaped) + (multiple-value-setq (pc-offset code) + (compute-lra-data-from-pc ra)) + (unless code + (setf code :foreign-function + pc-offset 0)))) (let ((d-fun (case code - (:undefined-function - (make-bogus-debug-fun - "undefined function")) - (:foreign-function - (make-bogus-debug-fun - (foreign-function-backtrace-name ra))) - ((nil) - (make-bogus-debug-fun - "bogus stack frame")) - (t - (debug-fun-from-pc code pc-offset))))) - (/noshow0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME") - (make-compiled-frame caller up-frame d-fun - (code-location-from-pc d-fun pc-offset - escaped) - (if up-frame (1+ (frame-number up-frame)) 0) - escaped))))) + (:undefined-function + (make-bogus-debug-fun + "undefined function")) + (:foreign-function + (make-bogus-debug-fun + (foreign-function-backtrace-name ra))) + ((nil) + (make-bogus-debug-fun + "bogus stack frame")) + (t + (debug-fun-from-pc code pc-offset))))) + (/noshow0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME") + (make-compiled-frame caller up-frame d-fun + (code-location-from-pc d-fun pc-offset + escaped) + (if up-frame (1+ (frame-number up-frame)) 0) + escaped))))) (defun nth-interrupt-context (n) (declare (type (unsigned-byte 32) n) - (optimize (speed 3) (safety 0))) - (sb!alien:sap-alien (sb!vm::current-thread-offset-sap - (+ sb!vm::thread-interrupt-contexts-offset n)) - (* os-context-t))) + (optimize (speed 3) (safety 0))) + (sb!alien:sap-alien (sb!vm::current-thread-offset-sap + (+ sb!vm::thread-interrupt-contexts-offset n)) + (* os-context-t))) #!+(or x86 x86-64) (defun find-escaped-frame (frame-pointer) @@ -895,38 +895,38 @@ (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) (/noshow0 "at head of WITH-ALIEN") (let ((context (nth-interrupt-context index))) - (/noshow0 "got CONTEXT") - (when (= (sap-int frame-pointer) - (sb!vm:context-register context sb!vm::cfp-offset)) - (without-gcing - (/noshow0 "in WITHOUT-GCING") - (let* ((component-ptr (component-ptr-from-pc - (sb!vm:context-pc context))) - (code (unless (sap= component-ptr (int-sap #x0)) - (component-from-component-ptr component-ptr)))) - (/noshow0 "got CODE") - (when (null code) - (return (values code 0 context))) - (let* ((code-header-len (* (get-header-data code) - sb!vm:n-word-bytes)) - (pc-offset - (- (sap-int (sb!vm:context-pc context)) - (- (get-lisp-obj-address code) - sb!vm:other-pointer-lowtag) - code-header-len))) - (/noshow "got PC-OFFSET") - (unless (<= 0 pc-offset - (* (code-header-ref code sb!vm:code-code-size-slot) - sb!vm:n-word-bytes)) - ;; We were in an assembly routine. Therefore, use the - ;; LRA as the pc. - ;; - ;; FIXME: Should this be WARN or ERROR or what? - (format t "** pc-offset ~S not in code obj ~S?~%" - pc-offset code)) - (/noshow0 "returning from FIND-ESCAPED-FRAME") - (return - (values code pc-offset context))))))))) + (/noshow0 "got CONTEXT") + (when (= (sap-int frame-pointer) + (sb!vm:context-register context sb!vm::cfp-offset)) + (without-gcing + (/noshow0 "in WITHOUT-GCING") + (let* ((component-ptr (component-ptr-from-pc + (sb!vm:context-pc context))) + (code (unless (sap= component-ptr (int-sap #x0)) + (component-from-component-ptr component-ptr)))) + (/noshow0 "got CODE") + (when (null code) + (return (values code 0 context))) + (let* ((code-header-len (* (get-header-data code) + sb!vm:n-word-bytes)) + (pc-offset + (- (sap-int (sb!vm:context-pc context)) + (- (get-lisp-obj-address code) + sb!vm:other-pointer-lowtag) + code-header-len))) + (/noshow "got PC-OFFSET") + (unless (<= 0 pc-offset + (* (code-header-ref code sb!vm:code-code-size-slot) + sb!vm:n-word-bytes)) + ;; We were in an assembly routine. Therefore, use the + ;; LRA as the pc. + ;; + ;; FIXME: Should this be WARN or ERROR or what? + (format t "** pc-offset ~S not in code obj ~S?~%" + pc-offset code)) + (/noshow0 "returning from FIND-ESCAPED-FRAME") + (return + (values code pc-offset context))))))))) #!-(or x86 x86-64) (defun find-escaped-frame (frame-pointer) @@ -934,25 +934,25 @@ (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) (let ((scp (nth-interrupt-context index))) (when (= (sap-int frame-pointer) - (sb!vm:context-register scp sb!vm::cfp-offset)) - (without-gcing - (let ((code (code-object-from-bits - (sb!vm:context-register scp sb!vm::code-offset)))) - (when (symbolp code) - (return (values code 0 scp))) - (let* ((code-header-len (* (get-header-data code) - sb!vm:n-word-bytes)) - (pc-offset + (sb!vm:context-register scp sb!vm::cfp-offset)) + (without-gcing + (let ((code (code-object-from-bits + (sb!vm:context-register scp sb!vm::code-offset)))) + (when (symbolp code) + (return (values code 0 scp))) + (let* ((code-header-len (* (get-header-data code) + sb!vm:n-word-bytes)) + (pc-offset (- (sap-int (sb!vm:context-pc scp)) (- (get-lisp-obj-address code) sb!vm:other-pointer-lowtag) code-header-len))) - ;; Check to see whether we were executing in a branch - ;; delay slot. - #!+(or pmax sgi) ; pmax only (and broken anyway) - (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause)) - (incf pc-offset sb!vm:n-word-bytes)) - (let ((code-size (* (code-header-ref code + ;; Check to see whether we were executing in a branch + ;; delay slot. + #!+(or pmax sgi) ; pmax only (and broken anyway) + (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause)) + (incf pc-offset sb!vm:n-word-bytes)) + (let ((code-size (* (code-header-ref code sb!vm:code-code-size-slot) sb!vm:n-word-bytes))) (unless (<= 0 pc-offset code-size) @@ -962,31 +962,31 @@ (setf pc-offset new-pc-offset) (unless (<= 0 pc-offset code-size) (cerror - "Set PC-OFFSET to zero and continue backtrace." - 'bug - :format-control - "~@" - :format-arguments - (list pc-offset - (sap-int (sb!vm:context-pc scp)) - code - (%code-entry-points code) - (sb!vm:context-register scp sb!vm::lra-offset) - computed-return)) + :format-arguments + (list pc-offset + (sap-int (sb!vm:context-pc scp)) + code + (%code-entry-points code) + (sb!vm:context-register scp sb!vm::lra-offset) + computed-return)) ;; We failed to pinpoint where PC is, but set ;; pc-offset to 0 to keep the backtrace from ;; exploding. - (setf pc-offset 0))))) - (return - (if (eq (%code-debug-info code) :bogus-lra) - (let ((real-lra (code-header-ref code - real-lra-slot))) - (values (lra-code-header real-lra) - (get-header-data real-lra) - nil)) - (values code pc-offset scp)))))))))) + (setf pc-offset 0))))) + (return + (if (eq (%code-debug-info code) :bogus-lra) + (let ((real-lra (code-header-ref code + real-lra-slot))) + (values (lra-code-header real-lra) + (get-header-data real-lra) + nil)) + (values code pc-offset scp)))))))))) #!-(or x86 x86-64) (defun find-pc-from-assembly-fun (code scp) @@ -996,10 +996,10 @@ register." (let ((return-machine-address (sb!vm::return-machine-address scp)) (code-header-len (* (get-header-data code) sb!vm:n-word-bytes))) (values (- return-machine-address - (- (get-lisp-obj-address code) - sb!vm:other-pointer-lowtag) - code-header-len) - return-machine-address))) + (- (get-lisp-obj-address code) + sb!vm:other-pointer-lowtag) + code-header-len) + return-machine-address))) ;;; Find the code object corresponding to the object represented by ;;; bits and return it. We assume bogus functions correspond to the @@ -1008,17 +1008,17 @@ register." (declare (type (unsigned-byte 32) bits)) (let ((object (make-lisp-obj bits))) (if (functionp object) - (or (fun-code-header object) - :undefined-function) - (let ((lowtag (lowtag-of object))) - (if (= lowtag sb!vm:other-pointer-lowtag) - (let ((widetag (widetag-of object))) - (cond ((= widetag sb!vm:code-header-widetag) - object) - ((= widetag sb!vm:return-pc-header-widetag) - (lra-code-header object)) - (t - nil)))))))) + (or (fun-code-header object) + :undefined-function) + (let ((lowtag (lowtag-of object))) + (if (= lowtag sb!vm:other-pointer-lowtag) + (let ((widetag (widetag-of object))) + (cond ((= widetag sb!vm:code-header-widetag) + object) + ((= widetag sb!vm:return-pc-header-widetag) + (lra-code-header object)) + (t + nil)))))))) ;;;; frame utilities @@ -1039,25 +1039,25 @@ register." (make-bogus-debug-fun "function end breakpoint")) (t (let* ((fun-map (sb!c::compiled-debug-info-fun-map info)) - (len (length fun-map))) - (declare (type simple-vector fun-map)) - (if (= len 1) - (make-compiled-debug-fun (svref fun-map 0) component) - (let ((i 1) - (elsewhere-p - (>= pc (sb!c::compiled-debug-fun-elsewhere-pc - (svref fun-map 0))))) - (declare (type sb!int:index i)) - (loop - (when (or (= i len) - (< pc (if elsewhere-p - (sb!c::compiled-debug-fun-elsewhere-pc - (svref fun-map (1+ i))) - (svref fun-map i)))) - (return (make-compiled-debug-fun - (svref fun-map (1- i)) - component))) - (incf i 2))))))))) + (len (length fun-map))) + (declare (type simple-vector fun-map)) + (if (= len 1) + (make-compiled-debug-fun (svref fun-map 0) component) + (let ((i 1) + (elsewhere-p + (>= pc (sb!c::compiled-debug-fun-elsewhere-pc + (svref fun-map 0))))) + (declare (type sb!int:index i)) + (loop + (when (or (= i len) + (< pc (if elsewhere-p + (sb!c::compiled-debug-fun-elsewhere-pc + (svref fun-map (1+ i))) + (svref fun-map i)))) + (return (make-compiled-debug-fun + (svref fun-map (1- i)) + component))) + (incf i 2))))))))) ;;; This returns a code-location for the COMPILED-DEBUG-FUN, ;;; DEBUG-FUN, and the pc into its code vector. If we stopped at a @@ -1066,15 +1066,15 @@ register." ;;; figure out what is going on. (defun code-location-from-pc (debug-fun pc escaped) (or (and (compiled-debug-fun-p debug-fun) - escaped - (let ((data (breakpoint-data - (compiled-debug-fun-component debug-fun) - pc nil))) - (when (and data (breakpoint-data-breakpoints data)) - (let ((what (breakpoint-what - (first (breakpoint-data-breakpoints data))))) - (when (compiled-code-location-p what) - what))))) + escaped + (let ((data (breakpoint-data + (compiled-debug-fun-component debug-fun) + pc nil))) + (when (and data (breakpoint-data-breakpoints data)) + (let ((what (breakpoint-what + (first (breakpoint-data-breakpoints data))))) + (when (compiled-code-location-p what) + what))))) (make-compiled-code-location pc debug-fun))) ;;; Return an alist mapping catch tags to CODE-LOCATIONs. These are @@ -1082,62 +1082,62 @@ register." ;;; top frame if someone threw to the corresponding tag. (defun frame-catches (frame) (let ((catch (descriptor-sap sb!vm:*current-catch-block*)) - (reversed-result nil) - (fp (frame-pointer frame))) + (reversed-result nil) + (fp (frame-pointer frame))) (loop until (zerop (sap-int catch)) - finally (return (nreverse reversed-result)) - do - (when (sap= fp - #!-alpha - (sap-ref-sap catch - (* sb!vm:catch-block-current-cont-slot - sb!vm:n-word-bytes)) - #!+alpha - (int-sap - (sap-ref-32 catch - (* sb!vm:catch-block-current-cont-slot - sb!vm:n-word-bytes)))) - (let* (#!-(or x86 x86-64) - (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot)) - #!+(or x86 x86-64) - (ra (sap-ref-sap - catch (* sb!vm:catch-block-entry-pc-slot - sb!vm:n-word-bytes))) - #!-(or x86 x86-64) - (component - (stack-ref catch sb!vm:catch-block-current-code-slot)) - #!+(or x86 x86-64) - (component (component-from-component-ptr - (component-ptr-from-pc ra))) - (offset - #!-(or x86 x86-64) - (* (- (1+ (get-header-data lra)) - (get-header-data component)) - sb!vm:n-word-bytes) - #!+(or x86 x86-64) - (- (sap-int ra) - (- (get-lisp-obj-address component) - sb!vm:other-pointer-lowtag) - (* (get-header-data component) sb!vm:n-word-bytes)))) - (push (cons #!-(or x86 x86-64) - (stack-ref catch sb!vm:catch-block-tag-slot) - #!+(or x86 x86-64) - (make-lisp-obj - (sap-ref-word catch (* sb!vm:catch-block-tag-slot - sb!vm:n-word-bytes))) - (make-compiled-code-location - offset (frame-debug-fun frame))) - reversed-result))) - (setf catch - #!-alpha - (sap-ref-sap catch - (* sb!vm:catch-block-previous-catch-slot - sb!vm:n-word-bytes)) - #!+alpha - (int-sap - (sap-ref-32 catch - (* sb!vm:catch-block-previous-catch-slot - sb!vm:n-word-bytes))))))) + finally (return (nreverse reversed-result)) + do + (when (sap= fp + #!-alpha + (sap-ref-sap catch + (* sb!vm:catch-block-current-cont-slot + sb!vm:n-word-bytes)) + #!+alpha + (int-sap + (sap-ref-32 catch + (* sb!vm:catch-block-current-cont-slot + sb!vm:n-word-bytes)))) + (let* (#!-(or x86 x86-64) + (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot)) + #!+(or x86 x86-64) + (ra (sap-ref-sap + catch (* sb!vm:catch-block-entry-pc-slot + sb!vm:n-word-bytes))) + #!-(or x86 x86-64) + (component + (stack-ref catch sb!vm:catch-block-current-code-slot)) + #!+(or x86 x86-64) + (component (component-from-component-ptr + (component-ptr-from-pc ra))) + (offset + #!-(or x86 x86-64) + (* (- (1+ (get-header-data lra)) + (get-header-data component)) + sb!vm:n-word-bytes) + #!+(or x86 x86-64) + (- (sap-int ra) + (- (get-lisp-obj-address component) + sb!vm:other-pointer-lowtag) + (* (get-header-data component) sb!vm:n-word-bytes)))) + (push (cons #!-(or x86 x86-64) + (stack-ref catch sb!vm:catch-block-tag-slot) + #!+(or x86 x86-64) + (make-lisp-obj + (sap-ref-word catch (* sb!vm:catch-block-tag-slot + sb!vm:n-word-bytes))) + (make-compiled-code-location + offset (frame-debug-fun frame))) + reversed-result))) + (setf catch + #!-alpha + (sap-ref-sap catch + (* sb!vm:catch-block-previous-catch-slot + sb!vm:n-word-bytes)) + #!+alpha + (int-sap + (sap-ref-32 catch + (* sb!vm:catch-block-previous-catch-slot + sb!vm:n-word-bytes))))))) ;;;; operations on DEBUG-FUNs @@ -1148,14 +1148,14 @@ register." ;;; NO-DEBUG-BLOCKS condition when the DEBUG-FUN lacks ;;; DEBUG-BLOCK information. (defmacro do-debug-fun-blocks ((block-var debug-fun &optional result) - &body body) + &body body) (let ((blocks (gensym)) - (i (gensym))) + (i (gensym))) `(let ((,blocks (debug-fun-debug-blocks ,debug-fun))) (declare (simple-vector ,blocks)) (dotimes (,i (length ,blocks) ,result) - (let ((,block-var (svref ,blocks ,i))) - ,@body))))) + (let ((,block-var (svref ,blocks ,i))) + ,@body))))) ;;; Execute body in a context with VAR bound to each DEBUG-VAR in ;;; DEBUG-FUN. This returns the value of executing result (defaults to @@ -1164,14 +1164,14 @@ register." ;;; compilation only preserved argument information. (defmacro do-debug-fun-vars ((var debug-fun &optional result) &body body) (let ((vars (gensym)) - (i (gensym))) + (i (gensym))) `(let ((,vars (debug-fun-debug-vars ,debug-fun))) (declare (type (or null simple-vector) ,vars)) (if ,vars - (dotimes (,i (length ,vars) ,result) - (let ((,var (svref ,vars ,i))) - ,@body)) - ,result)))) + (dotimes (,i (length ,vars) ,result) + (let ((,var (svref ,vars ,i))) + ,@body)) + ,result)))) ;;; Return the object of type FUNCTION associated with the DEBUG-FUN, ;;; or NIL if the function is unavailable or is non-existent as a user @@ -1179,24 +1179,24 @@ register." (defun debug-fun-fun (debug-fun) (let ((cached-value (debug-fun-%function debug-fun))) (if (eq cached-value :unparsed) - (setf (debug-fun-%function debug-fun) - (etypecase debug-fun - (compiled-debug-fun - (let ((component - (compiled-debug-fun-component debug-fun)) - (start-pc - (sb!c::compiled-debug-fun-start-pc - (compiled-debug-fun-compiler-debug-fun debug-fun)))) - (do ((entry (%code-entry-points component) - (%simple-fun-next entry))) - ((null entry) nil) - (when (= start-pc - (sb!c::compiled-debug-fun-start-pc - (compiled-debug-fun-compiler-debug-fun - (fun-debug-fun entry)))) - (return entry))))) - (bogus-debug-fun nil))) - cached-value))) + (setf (debug-fun-%function debug-fun) + (etypecase debug-fun + (compiled-debug-fun + (let ((component + (compiled-debug-fun-component debug-fun)) + (start-pc + (sb!c::compiled-debug-fun-start-pc + (compiled-debug-fun-compiler-debug-fun debug-fun)))) + (do ((entry (%code-entry-points component) + (%simple-fun-next entry))) + ((null entry) nil) + (when (= start-pc + (sb!c::compiled-debug-fun-start-pc + (compiled-debug-fun-compiler-debug-fun + (fun-debug-fun entry)))) + (return entry))))) + (bogus-debug-fun nil))) + cached-value))) ;;; Return the name of the function represented by DEBUG-FUN. This may ;;; be a string or a cons; do not assume it is a symbol. @@ -1219,28 +1219,28 @@ register." (fun-debug-fun (funcallable-instance-fun fun))) (#.sb!vm:simple-fun-header-widetag (let* ((name (%simple-fun-name fun)) - (component (fun-code-header fun)) - (res (find-if - (lambda (x) - (and (sb!c::compiled-debug-fun-p x) - (eq (sb!c::compiled-debug-fun-name x) name) - (eq (sb!c::compiled-debug-fun-kind x) nil))) - (sb!c::compiled-debug-info-fun-map - (%code-debug-info component))))) - (if res - (make-compiled-debug-fun res component) - ;; KLUDGE: comment from CMU CL: - ;; This used to be the non-interpreted branch, but - ;; William wrote it to return the debug-fun of fun's XEP - ;; instead of fun's debug-fun. The above code does this - ;; more correctly, but it doesn't get or eliminate all - ;; appropriate cases. It mostly works, and probably - ;; works for all named functions anyway. - ;; -- WHN 20000120 - (debug-fun-from-pc component - (* (- (fun-word-offset fun) - (get-header-data component)) - sb!vm:n-word-bytes))))))) + (component (fun-code-header fun)) + (res (find-if + (lambda (x) + (and (sb!c::compiled-debug-fun-p x) + (eq (sb!c::compiled-debug-fun-name x) name) + (eq (sb!c::compiled-debug-fun-kind x) nil))) + (sb!c::compiled-debug-info-fun-map + (%code-debug-info component))))) + (if res + (make-compiled-debug-fun res component) + ;; KLUDGE: comment from CMU CL: + ;; This used to be the non-interpreted branch, but + ;; William wrote it to return the debug-fun of fun's XEP + ;; instead of fun's debug-fun. The above code does this + ;; more correctly, but it doesn't get or eliminate all + ;; appropriate cases. It mostly works, and probably + ;; works for all named functions anyway. + ;; -- WHN 20000120 + (debug-fun-from-pc component + (* (- (fun-word-offset fun) + (get-header-data component)) + sb!vm:n-word-bytes))))))) ;;; Return the kind of the function, which is one of :OPTIONAL, ;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL. @@ -1266,16 +1266,16 @@ register." ;;; example, possibly DEBUG-FUN only knows about its arguments. (defun debug-fun-symbol-vars (debug-fun symbol) (let ((vars (ambiguous-debug-vars debug-fun (symbol-name symbol))) - (package (and (symbol-package symbol) - (package-name (symbol-package symbol))))) + (package (and (symbol-package symbol) + (package-name (symbol-package symbol))))) (delete-if (if (stringp package) - (lambda (var) - (let ((p (debug-var-package-name var))) - (or (not (stringp p)) - (string/= p package)))) - (lambda (var) - (stringp (debug-var-package-name var)))) - vars))) + (lambda (var) + (let ((p (debug-var-package-name var))) + (or (not (stringp p)) + (string/= p package)))) + (lambda (var) + (stringp (debug-var-package-name var)))) + vars))) ;;; Return a list of DEBUG-VARs in DEBUG-FUN whose names contain ;;; NAME-PREFIX-STRING as an initial substring. The result of this @@ -1287,41 +1287,41 @@ register." (let ((variables (debug-fun-debug-vars debug-fun))) (declare (type (or null simple-vector) variables)) (if variables - (let* ((len (length variables)) - (prefix-len (length name-prefix-string)) - (pos (find-var name-prefix-string variables len)) - (res nil)) - (when pos - ;; Find names from pos to variable's len that contain prefix. - (do ((i pos (1+ i))) - ((= i len)) - (let* ((var (svref variables i)) - (name (debug-var-symbol-name var)) - (name-len (length name))) - (declare (simple-string name)) - (when (/= (or (string/= name-prefix-string name - :end1 prefix-len :end2 name-len) - prefix-len) - prefix-len) - (return)) - (push var res))) - (setq res (nreverse res))) - res)))) + (let* ((len (length variables)) + (prefix-len (length name-prefix-string)) + (pos (find-var name-prefix-string variables len)) + (res nil)) + (when pos + ;; Find names from pos to variable's len that contain prefix. + (do ((i pos (1+ i))) + ((= i len)) + (let* ((var (svref variables i)) + (name (debug-var-symbol-name var)) + (name-len (length name))) + (declare (simple-string name)) + (when (/= (or (string/= name-prefix-string name + :end1 prefix-len :end2 name-len) + prefix-len) + prefix-len) + (return)) + (push var res))) + (setq res (nreverse res))) + res)))) ;;; This returns a position in VARIABLES for one containing NAME as an ;;; initial substring. END is the length of VARIABLES if supplied. (defun find-var (name variables &optional end) (declare (simple-vector variables) - (simple-string name)) + (simple-string name)) (let ((name-len (length name))) (position name variables - :test (lambda (x y) - (let* ((y (debug-var-symbol-name y)) - (y-len (length y))) - (declare (simple-string y)) - (and (>= y-len name-len) - (string= x y :end1 name-len :end2 name-len)))) - :end (or end (length variables))))) + :test (lambda (x y) + (let* ((y (debug-var-symbol-name y)) + (y-len (length y))) + (declare (simple-string y)) + (and (>= y-len name-len) + (string= x y :end1 name-len :end2 name-len)))) + :end (or end (length variables))))) ;;; Return a list representing the lambda-list for DEBUG-FUN. The ;;; list has the following structure: @@ -1349,26 +1349,26 @@ register." (defun compiled-debug-fun-lambda-list (debug-fun) (let ((lambda-list (debug-fun-%lambda-list debug-fun))) (cond ((eq lambda-list :unparsed) - (multiple-value-bind (args argsp) - (parse-compiled-debug-fun-lambda-list debug-fun) - (setf (debug-fun-%lambda-list debug-fun) args) - (if argsp - args - (debug-signal 'lambda-list-unavailable - :debug-fun debug-fun)))) - (lambda-list) - ((bogus-debug-fun-p debug-fun) - nil) - ((sb!c::compiled-debug-fun-arguments - (compiled-debug-fun-compiler-debug-fun debug-fun)) - ;; If the packed information is there (whether empty or not) as - ;; opposed to being nil, then returned our cached value (nil). - nil) - (t - ;; Our cached value is nil, and the packed lambda-list information - ;; is nil, so we don't have anything available. - (debug-signal 'lambda-list-unavailable - :debug-fun debug-fun))))) + (multiple-value-bind (args argsp) + (parse-compiled-debug-fun-lambda-list debug-fun) + (setf (debug-fun-%lambda-list debug-fun) args) + (if argsp + args + (debug-signal 'lambda-list-unavailable + :debug-fun debug-fun)))) + (lambda-list) + ((bogus-debug-fun-p debug-fun) + nil) + ((sb!c::compiled-debug-fun-arguments + (compiled-debug-fun-compiler-debug-fun debug-fun)) + ;; If the packed information is there (whether empty or not) as + ;; opposed to being nil, then returned our cached value (nil). + nil) + (t + ;; Our cached value is nil, and the packed lambda-list information + ;; is nil, so we don't have anything available. + (debug-signal 'lambda-list-unavailable + :debug-fun debug-fun))))) ;;; COMPILED-DEBUG-FUN-LAMBDA-LIST calls this when a ;;; COMPILED-DEBUG-FUN has no lambda list information cached. It @@ -1378,78 +1378,78 @@ register." ;;; means there was no argument information. (defun parse-compiled-debug-fun-lambda-list (debug-fun) (let ((args (sb!c::compiled-debug-fun-arguments - (compiled-debug-fun-compiler-debug-fun debug-fun)))) + (compiled-debug-fun-compiler-debug-fun debug-fun)))) (cond ((not args) (values nil nil)) ((eq args :minimal) (values (coerce (debug-fun-debug-vars debug-fun) 'list) - t)) + t)) (t (let ((vars (debug-fun-debug-vars debug-fun)) - (i 0) - (len (length args)) - (res nil) - (optionalp nil)) - (declare (type (or null simple-vector) vars)) - (loop - (when (>= i len) (return)) - (let ((ele (aref args i))) - (cond - ((symbolp ele) - (case ele - (sb!c::deleted - ;; Deleted required arg at beginning of args array. - (push :deleted res)) - (sb!c::optional-args - (setf optionalp t)) - (sb!c::supplied-p - ;; SUPPLIED-P var immediately following keyword or - ;; optional. Stick the extra var in the result - ;; element representing the keyword or optional, - ;; which is the previous one. + (i 0) + (len (length args)) + (res nil) + (optionalp nil)) + (declare (type (or null simple-vector) vars)) + (loop + (when (>= i len) (return)) + (let ((ele (aref args i))) + (cond + ((symbolp ele) + (case ele + (sb!c::deleted + ;; Deleted required arg at beginning of args array. + (push :deleted res)) + (sb!c::optional-args + (setf optionalp t)) + (sb!c::supplied-p + ;; SUPPLIED-P var immediately following keyword or + ;; optional. Stick the extra var in the result + ;; element representing the keyword or optional, + ;; which is the previous one. ;; ;; FIXME: NCONC used for side-effect: the effect is defined, ;; but this is bad style no matter what. - (nconc (car res) - (list (compiled-debug-fun-lambda-list-var - args (incf i) vars)))) - (sb!c::rest-arg - (push (list :rest - (compiled-debug-fun-lambda-list-var - args (incf i) vars)) - res)) - (sb!c::more-arg - ;; Just ignore the fact that the next two args are - ;; the &MORE arg context and count, and act like they - ;; are regular arguments. - nil) - (t - ;; &KEY arg - (push (list :keyword - ele - (compiled-debug-fun-lambda-list-var - args (incf i) vars)) - res)))) - (optionalp - ;; We saw an optional marker, so the following - ;; non-symbols are indexes indicating optional - ;; variables. - (push (list :optional (svref vars ele)) res)) - (t - ;; Required arg at beginning of args array. - (push (svref vars ele) res)))) - (incf i)) - (values (nreverse res) t)))))) + (nconc (car res) + (list (compiled-debug-fun-lambda-list-var + args (incf i) vars)))) + (sb!c::rest-arg + (push (list :rest + (compiled-debug-fun-lambda-list-var + args (incf i) vars)) + res)) + (sb!c::more-arg + ;; Just ignore the fact that the next two args are + ;; the &MORE arg context and count, and act like they + ;; are regular arguments. + nil) + (t + ;; &KEY arg + (push (list :keyword + ele + (compiled-debug-fun-lambda-list-var + args (incf i) vars)) + res)))) + (optionalp + ;; We saw an optional marker, so the following + ;; non-symbols are indexes indicating optional + ;; variables. + (push (list :optional (svref vars ele)) res)) + (t + ;; Required arg at beginning of args array. + (push (svref vars ele) res)))) + (incf i)) + (values (nreverse res) t)))))) ;;; This is used in COMPILED-DEBUG-FUN-LAMBDA-LIST. (defun compiled-debug-fun-lambda-list-var (args i vars) (declare (type (simple-array * (*)) args) - (simple-vector vars)) + (simple-vector vars)) (let ((ele (aref args i))) (cond ((not (symbolp ele)) (svref vars ele)) - ((eq ele 'sb!c::deleted) :deleted) - (t (error "malformed arguments description"))))) + ((eq ele 'sb!c::deleted) :deleted) + (t (error "malformed arguments description"))))) (defun compiled-debug-fun-debug-info (debug-fun) (%code-debug-info (compiled-debug-fun-component debug-fun))) @@ -1478,22 +1478,22 @@ register." ;;; simple-vector. (eval-when (:compile-toplevel :execute) (sb!xc:defmacro with-parsing-buffer ((buffer-var &optional other-var) - &body body) + &body body) (let ((len (gensym)) - (res (gensym))) + (res (gensym))) `(unwind-protect - (let ((,buffer-var *parsing-buffer*) - ,@(if other-var `((,other-var *other-parsing-buffer*)))) - (setf (fill-pointer ,buffer-var) 0) - ,@(if other-var `((setf (fill-pointer ,other-var) 0))) - (macrolet ((result (buf) - `(let* ((,',len (length ,buf)) - (,',res (make-array ,',len))) - (replace ,',res ,buf :end1 ,',len :end2 ,',len) - (fill ,buf nil :end ,',len) - (setf (fill-pointer ,buf) 0) - ,',res))) - ,@body)) + (let ((,buffer-var *parsing-buffer*) + ,@(if other-var `((,other-var *other-parsing-buffer*)))) + (setf (fill-pointer ,buffer-var) 0) + ,@(if other-var `((setf (fill-pointer ,other-var) 0))) + (macrolet ((result (buf) + `(let* ((,',len (length ,buf)) + (,',res (make-array ,',len))) + (replace ,',res ,buf :end1 ,',len :end2 ,',len) + (fill ,buf nil :end ,',len) + (setf (fill-pointer ,buf) 0) + ,',res))) + ,@body)) (fill *parsing-buffer* nil) ,@(if other-var `((fill *other-parsing-buffer* nil)))))) ) ; EVAL-WHEN @@ -1505,16 +1505,16 @@ register." (defun debug-fun-debug-blocks (debug-fun) (let ((blocks (debug-fun-blocks debug-fun))) (cond ((eq blocks :unparsed) - (setf (debug-fun-blocks debug-fun) - (parse-debug-blocks debug-fun)) - (unless (debug-fun-blocks debug-fun) - (debug-signal 'no-debug-blocks - :debug-fun debug-fun)) - (debug-fun-blocks debug-fun)) - (blocks) - (t - (debug-signal 'no-debug-blocks - :debug-fun debug-fun))))) + (setf (debug-fun-blocks debug-fun) + (parse-debug-blocks debug-fun)) + (unless (debug-fun-blocks debug-fun) + (debug-signal 'no-debug-blocks + :debug-fun debug-fun)) + (debug-fun-blocks debug-fun)) + (blocks) + (t + (debug-signal 'no-debug-blocks + :debug-fun debug-fun))))) ;;; Return a SIMPLE-VECTOR of DEBUG-BLOCKs or NIL. NIL indicates there ;;; was no basic block information. @@ -1528,65 +1528,65 @@ register." ;;; This does some of the work of PARSE-DEBUG-BLOCKS. (defun parse-compiled-debug-blocks (debug-fun) (let* ((var-count (length (debug-fun-debug-vars debug-fun))) - (compiler-debug-fun (compiled-debug-fun-compiler-debug-fun - debug-fun)) - (blocks (sb!c::compiled-debug-fun-blocks compiler-debug-fun)) - ;; KLUDGE: 8 is a hard-wired constant in the compiler for the - ;; element size of the packed binary representation of the - ;; blocks data. - (live-set-len (ceiling var-count 8)) - (tlf-number (sb!c::compiled-debug-fun-tlf-number compiler-debug-fun))) + (compiler-debug-fun (compiled-debug-fun-compiler-debug-fun + debug-fun)) + (blocks (sb!c::compiled-debug-fun-blocks compiler-debug-fun)) + ;; KLUDGE: 8 is a hard-wired constant in the compiler for the + ;; element size of the packed binary representation of the + ;; blocks data. + (live-set-len (ceiling var-count 8)) + (tlf-number (sb!c::compiled-debug-fun-tlf-number compiler-debug-fun))) (unless blocks (return-from parse-compiled-debug-blocks nil)) (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i)))) (with-parsing-buffer (blocks-buffer locations-buffer) - (let ((i 0) - (len (length blocks)) - (last-pc 0)) - (loop - (when (>= i len) (return)) - (let ((succ-and-flags (aref+ blocks i)) - (successors nil)) - (declare (type (unsigned-byte 8) succ-and-flags) - (list successors)) - (dotimes (k (ldb sb!c::compiled-debug-block-nsucc-byte - succ-and-flags)) - (push (sb!c:read-var-integer blocks i) successors)) - (let* ((locations - (dotimes (k (sb!c:read-var-integer blocks i) - (result locations-buffer)) - (let ((kind (svref sb!c::*compiled-code-location-kinds* - (aref+ blocks i))) - (pc (+ last-pc - (sb!c:read-var-integer blocks i))) - (tlf-offset (or tlf-number - (sb!c:read-var-integer blocks i))) - (form-number (sb!c:read-var-integer blocks i)) - (live-set (sb!c:read-packed-bit-vector - live-set-len blocks i))) - (vector-push-extend (make-known-code-location - pc debug-fun tlf-offset - form-number live-set kind) - locations-buffer) - (setf last-pc pc)))) - (block (make-compiled-debug-block - locations successors - (not (zerop (logand - sb!c::compiled-debug-block-elsewhere-p - succ-and-flags)))))) - (vector-push-extend block blocks-buffer) - (dotimes (k (length locations)) - (setf (code-location-%debug-block (svref locations k)) - block)))))) - (let ((res (result blocks-buffer))) - (declare (simple-vector res)) - (dotimes (i (length res)) - (let* ((block (svref res i)) - (succs nil)) - (dolist (ele (debug-block-successors block)) - (push (svref res ele) succs)) - (setf (debug-block-successors block) succs))) - res))))) + (let ((i 0) + (len (length blocks)) + (last-pc 0)) + (loop + (when (>= i len) (return)) + (let ((succ-and-flags (aref+ blocks i)) + (successors nil)) + (declare (type (unsigned-byte 8) succ-and-flags) + (list successors)) + (dotimes (k (ldb sb!c::compiled-debug-block-nsucc-byte + succ-and-flags)) + (push (sb!c:read-var-integer blocks i) successors)) + (let* ((locations + (dotimes (k (sb!c:read-var-integer blocks i) + (result locations-buffer)) + (let ((kind (svref sb!c::*compiled-code-location-kinds* + (aref+ blocks i))) + (pc (+ last-pc + (sb!c:read-var-integer blocks i))) + (tlf-offset (or tlf-number + (sb!c:read-var-integer blocks i))) + (form-number (sb!c:read-var-integer blocks i)) + (live-set (sb!c:read-packed-bit-vector + live-set-len blocks i))) + (vector-push-extend (make-known-code-location + pc debug-fun tlf-offset + form-number live-set kind) + locations-buffer) + (setf last-pc pc)))) + (block (make-compiled-debug-block + locations successors + (not (zerop (logand + sb!c::compiled-debug-block-elsewhere-p + succ-and-flags)))))) + (vector-push-extend block blocks-buffer) + (dotimes (k (length locations)) + (setf (code-location-%debug-block (svref locations k)) + block)))))) + (let ((res (result blocks-buffer))) + (declare (simple-vector res)) + (dotimes (i (length res)) + (let* ((block (svref res i)) + (succs nil)) + (dolist (ele (debug-block-successors block)) + (push (svref res ele) succs)) + (setf (debug-block-successors block) succs))) + res))))) ;;; The argument is a debug internals structure. This returns NIL if ;;; there is no variable information. It returns an empty @@ -1595,12 +1595,12 @@ register." (defun debug-fun-debug-vars (debug-fun) (let ((vars (debug-fun-%debug-vars debug-fun))) (if (eq vars :unparsed) - (setf (debug-fun-%debug-vars debug-fun) - (etypecase debug-fun - (compiled-debug-fun - (parse-compiled-debug-vars debug-fun)) - (bogus-debug-fun nil))) - vars))) + (setf (debug-fun-%debug-vars debug-fun) + (etypecase debug-fun + (compiled-debug-fun + (parse-compiled-debug-vars debug-fun)) + (bogus-debug-fun nil))) + vars))) ;;; VARS is the parsed variables for a minimal debug function. We need ;;; to assign names of the form ARG-NNN. We must pad with leading @@ -1608,7 +1608,7 @@ register." (defun assign-minimal-var-names (vars) (declare (simple-vector vars)) (let* ((len (length vars)) - (width (length (format nil "~W" (1- len))))) + (width (length (format nil "~W" (1- len))))) (dotimes (i len) (without-package-locks (setf (compiled-debug-var-symbol (svref vars i)) @@ -1635,38 +1635,38 @@ register." ;;; of DEBUG-VARs, or NIL if there was no information to parse. (defun parse-compiled-debug-vars (debug-fun) (let* ((cdebug-fun (compiled-debug-fun-compiler-debug-fun - debug-fun)) - (packed-vars (sb!c::compiled-debug-fun-vars cdebug-fun)) - (args-minimal (eq (sb!c::compiled-debug-fun-arguments cdebug-fun) - :minimal))) + debug-fun)) + (packed-vars (sb!c::compiled-debug-fun-vars cdebug-fun)) + (args-minimal (eq (sb!c::compiled-debug-fun-arguments cdebug-fun) + :minimal))) (when packed-vars (do ((i 0) - (buffer (make-array 0 :fill-pointer 0 :adjustable t))) - ((>= i (length packed-vars)) - (let ((result (coerce buffer 'simple-vector))) - (when args-minimal - (assign-minimal-var-names result)) - result)) - (flet ((geti () (prog1 (aref packed-vars i) (incf i)))) - (let* ((flags (geti)) - (minimal (logtest sb!c::compiled-debug-var-minimal-p flags)) - (deleted (logtest sb!c::compiled-debug-var-deleted-p flags)) - (live (logtest sb!c::compiled-debug-var-environment-live - flags)) - (save (logtest sb!c::compiled-debug-var-save-loc-p flags)) - (symbol (if minimal nil (geti))) - (id (if (logtest sb!c::compiled-debug-var-id-p flags) - (geti) - 0)) - (sc-offset (if deleted 0 (geti))) - (save-sc-offset (if save (geti) nil))) - (aver (not (and args-minimal (not minimal)))) - (vector-push-extend (make-compiled-debug-var symbol - id - live - sc-offset - save-sc-offset) - buffer))))))) + (buffer (make-array 0 :fill-pointer 0 :adjustable t))) + ((>= i (length packed-vars)) + (let ((result (coerce buffer 'simple-vector))) + (when args-minimal + (assign-minimal-var-names result)) + result)) + (flet ((geti () (prog1 (aref packed-vars i) (incf i)))) + (let* ((flags (geti)) + (minimal (logtest sb!c::compiled-debug-var-minimal-p flags)) + (deleted (logtest sb!c::compiled-debug-var-deleted-p flags)) + (live (logtest sb!c::compiled-debug-var-environment-live + flags)) + (save (logtest sb!c::compiled-debug-var-save-loc-p flags)) + (symbol (if minimal nil (geti))) + (id (if (logtest sb!c::compiled-debug-var-id-p flags) + (geti) + 0)) + (sc-offset (if deleted 0 (geti))) + (save-sc-offset (if save (geti) nil))) + (aver (not (and args-minimal (not minimal)))) + (vector-push-extend (make-compiled-debug-var symbol + id + live + sc-offset + save-sc-offset) + buffer))))))) ;;;; CODE-LOCATIONs @@ -1683,8 +1683,8 @@ register." ((nil) nil) (:unsure (setf (code-location-%unknown-p basic-code-location) - (handler-case (not (fill-in-code-location basic-code-location)) - (no-debug-blocks () t)))))) + (handler-case (not (fill-in-code-location basic-code-location)) + (no-debug-blocks () t)))))) ;;; Return the DEBUG-BLOCK containing code-location if it is available. ;;; Some debug policies inhibit debug-block information, and if none @@ -1692,13 +1692,13 @@ register." (defun code-location-debug-block (basic-code-location) (let ((block (code-location-%debug-block basic-code-location))) (if (eq block :unparsed) - (etypecase basic-code-location - (compiled-code-location - (compute-compiled-code-location-debug-block basic-code-location)) - ;; (There used to be more cases back before sbcl-0.7.0, when - ;; we did special tricks to debug the IR1 interpreter.) - ) - block))) + (etypecase basic-code-location + (compiled-code-location + (compute-compiled-code-location-debug-block basic-code-location)) + ;; (There used to be more cases back before sbcl-0.7.0, when + ;; we did special tricks to debug the IR1 interpreter.) + ) + block))) ;;; Store and return BASIC-CODE-LOCATION's debug-block. We determines ;;; the correct one using the code-location's pc. We use @@ -1714,47 +1714,47 @@ register." ;;; code first in order to see how to compare the code-location's pc. (defun compute-compiled-code-location-debug-block (basic-code-location) (let* ((pc (compiled-code-location-pc basic-code-location)) - (debug-fun (code-location-debug-fun - basic-code-location)) - (blocks (debug-fun-debug-blocks debug-fun)) - (len (length blocks))) + (debug-fun (code-location-debug-fun + basic-code-location)) + (blocks (debug-fun-debug-blocks debug-fun)) + (len (length blocks))) (declare (simple-vector blocks)) (setf (code-location-%debug-block basic-code-location) - (if (= len 1) - (svref blocks 0) - (do ((i 1 (1+ i)) - (end (1- len))) - ((= i end) - (let ((last (svref blocks end))) - (cond - ((debug-block-elsewhere-p last) - (if (< pc - (sb!c::compiled-debug-fun-elsewhere-pc - (compiled-debug-fun-compiler-debug-fun - debug-fun))) - (svref blocks (1- end)) - last)) - ((< pc - (compiled-code-location-pc - (svref (compiled-debug-block-code-locations last) - 0))) - (svref blocks (1- end))) - (t last)))) - (declare (type index i end)) - (when (< pc - (compiled-code-location-pc - (svref (compiled-debug-block-code-locations - (svref blocks i)) - 0))) - (return (svref blocks (1- i))))))))) + (if (= len 1) + (svref blocks 0) + (do ((i 1 (1+ i)) + (end (1- len))) + ((= i end) + (let ((last (svref blocks end))) + (cond + ((debug-block-elsewhere-p last) + (if (< pc + (sb!c::compiled-debug-fun-elsewhere-pc + (compiled-debug-fun-compiler-debug-fun + debug-fun))) + (svref blocks (1- end)) + last)) + ((< pc + (compiled-code-location-pc + (svref (compiled-debug-block-code-locations last) + 0))) + (svref blocks (1- end))) + (t last)))) + (declare (type index i end)) + (when (< pc + (compiled-code-location-pc + (svref (compiled-debug-block-code-locations + (svref blocks i)) + 0))) + (return (svref blocks (1- i))))))))) ;;; Return the CODE-LOCATION's DEBUG-SOURCE. (defun code-location-debug-source (code-location) (let ((info (compiled-debug-fun-debug-info - (code-location-debug-fun code-location)))) + (code-location-debug-fun code-location)))) (or (sb!c::debug-info-source info) - (debug-signal 'no-debug-blocks :debug-fun - (code-location-debug-fun code-location))))) + (debug-signal 'no-debug-blocks :debug-fun + (code-location-debug-fun code-location))))) ;;; Returns the number of top level forms before the one containing ;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A @@ -1765,18 +1765,18 @@ register." (error 'unknown-code-location :code-location code-location)) (let ((tlf-offset (code-location-%tlf-offset code-location))) (cond ((eq tlf-offset :unparsed) - (etypecase code-location - (compiled-code-location - (unless (fill-in-code-location code-location) - ;; This check should be unnecessary. We're missing - ;; debug info the compiler should have dumped. - (bug "unknown code location")) - (code-location-%tlf-offset code-location)) - ;; (There used to be more cases back before sbcl-0.7.0,, - ;; when we did special tricks to debug the IR1 - ;; interpreter.) - )) - (t tlf-offset)))) + (etypecase code-location + (compiled-code-location + (unless (fill-in-code-location code-location) + ;; This check should be unnecessary. We're missing + ;; debug info the compiler should have dumped. + (bug "unknown code location")) + (code-location-%tlf-offset code-location)) + ;; (There used to be more cases back before sbcl-0.7.0,, + ;; when we did special tricks to debug the IR1 + ;; interpreter.) + )) + (t tlf-offset)))) ;;; Return the number of the form corresponding to CODE-LOCATION. The ;;; form number is derived by a walking the subforms of a top level @@ -1786,18 +1786,18 @@ register." (error 'unknown-code-location :code-location code-location)) (let ((form-num (code-location-%form-number code-location))) (cond ((eq form-num :unparsed) - (etypecase code-location - (compiled-code-location - (unless (fill-in-code-location code-location) - ;; This check should be unnecessary. We're missing - ;; debug info the compiler should have dumped. - (bug "unknown code location")) - (code-location-%form-number code-location)) - ;; (There used to be more cases back before sbcl-0.7.0,, - ;; when we did special tricks to debug the IR1 - ;; interpreter.) - )) - (t form-num)))) + (etypecase code-location + (compiled-code-location + (unless (fill-in-code-location code-location) + ;; This check should be unnecessary. We're missing + ;; debug info the compiler should have dumped. + (bug "unknown code location")) + (code-location-%form-number code-location)) + ;; (There used to be more cases back before sbcl-0.7.0,, + ;; when we did special tricks to debug the IR1 + ;; interpreter.) + )) + (t form-num)))) ;;; Return the kind of CODE-LOCATION, one of: ;;; :INTERPRETED, :UNKNOWN-RETURN, :KNOWN-RETURN, :INTERNAL-ERROR, @@ -1810,12 +1810,12 @@ register." (compiled-code-location (let ((kind (compiled-code-location-kind code-location))) (cond ((not (eq kind :unparsed)) kind) - ((not (fill-in-code-location code-location)) - ;; This check should be unnecessary. We're missing - ;; debug info the compiler should have dumped. - (bug "unknown code location")) - (t - (compiled-code-location-kind code-location))))) + ((not (fill-in-code-location code-location)) + ;; This check should be unnecessary. We're missing + ;; debug info the compiler should have dumped. + (bug "unknown code location")) + (t + (compiled-code-location-kind code-location))))) ;; (There used to be more cases back before sbcl-0.7.0,, ;; when we did special tricks to debug the IR1 ;; interpreter.) @@ -1827,16 +1827,16 @@ register." (if (code-location-unknown-p code-location) nil (let ((live-set (compiled-code-location-%live-set code-location))) - (cond ((eq live-set :unparsed) - (unless (fill-in-code-location code-location) - ;; This check should be unnecessary. We're missing - ;; debug info the compiler should have dumped. - ;; - ;; FIXME: This error and comment happen over and over again. - ;; Make them a shared function. - (bug "unknown code location")) - (compiled-code-location-%live-set code-location)) - (t live-set))))) + (cond ((eq live-set :unparsed) + (unless (fill-in-code-location code-location) + ;; This check should be unnecessary. We're missing + ;; debug info the compiler should have dumped. + ;; + ;; FIXME: This error and comment happen over and over again. + ;; Make them a shared function. + (bug "unknown code location")) + (compiled-code-location-%live-set code-location)) + (t live-set))))) ;;; true if OBJ1 and OBJ2 are the same place in the code (defun code-location= (obj1 obj2) @@ -1844,9 +1844,9 @@ register." (compiled-code-location (etypecase obj2 (compiled-code-location - (and (eq (code-location-debug-fun obj1) - (code-location-debug-fun obj2)) - (sub-compiled-code-location= obj1 obj2))) + (and (eq (code-location-debug-fun obj1) + (code-location-debug-fun obj2)) + (sub-compiled-code-location= obj1 obj2))) ;; (There used to be more cases back before sbcl-0.7.0,, ;; when we did special tricks to debug the IR1 ;; interpreter.) @@ -1866,39 +1866,39 @@ register." (defun fill-in-code-location (code-location) (declare (type compiled-code-location code-location)) (let* ((debug-fun (code-location-debug-fun code-location)) - (blocks (debug-fun-debug-blocks debug-fun))) + (blocks (debug-fun-debug-blocks debug-fun))) (declare (simple-vector blocks)) (dotimes (i (length blocks) nil) (let* ((block (svref blocks i)) - (locations (compiled-debug-block-code-locations block))) - (declare (simple-vector locations)) - (dotimes (j (length locations)) - (let ((loc (svref locations j))) - (when (sub-compiled-code-location= code-location loc) - (setf (code-location-%debug-block code-location) block) - (setf (code-location-%tlf-offset code-location) - (code-location-%tlf-offset loc)) - (setf (code-location-%form-number code-location) - (code-location-%form-number loc)) - (setf (compiled-code-location-%live-set code-location) - (compiled-code-location-%live-set loc)) - (setf (compiled-code-location-kind code-location) - (compiled-code-location-kind loc)) - (return-from fill-in-code-location t)))))))) + (locations (compiled-debug-block-code-locations block))) + (declare (simple-vector locations)) + (dotimes (j (length locations)) + (let ((loc (svref locations j))) + (when (sub-compiled-code-location= code-location loc) + (setf (code-location-%debug-block code-location) block) + (setf (code-location-%tlf-offset code-location) + (code-location-%tlf-offset loc)) + (setf (code-location-%form-number code-location) + (code-location-%form-number loc)) + (setf (compiled-code-location-%live-set code-location) + (compiled-code-location-%live-set loc)) + (setf (compiled-code-location-kind code-location) + (compiled-code-location-kind loc)) + (return-from fill-in-code-location t)))))))) ;;;; operations on DEBUG-BLOCKs ;;; Execute FORMS in a context with CODE-VAR bound to each ;;; CODE-LOCATION in DEBUG-BLOCK, and return the value of RESULT. (defmacro do-debug-block-locations ((code-var debug-block &optional result) - &body body) + &body body) (let ((code-locations (gensym)) - (i (gensym))) + (i (gensym))) `(let ((,code-locations (debug-block-code-locations ,debug-block))) (declare (simple-vector ,code-locations)) (dotimes (,i (length ,code-locations) ,result) - (let ((,code-var (svref ,code-locations ,i))) - ,@body))))) + (let ((,code-var (svref ,code-locations ,i))) + ,@body))))) ;;; Return the name of the function represented by DEBUG-FUN. ;;; This may be a string or a cons; do not assume it is a symbol. @@ -1908,9 +1908,9 @@ register." (let ((code-locs (compiled-debug-block-code-locations debug-block))) (declare (simple-vector code-locs)) (if (zerop (length code-locs)) - "??? Can't get name of debug-block's function." - (debug-fun-name - (code-location-debug-fun (svref code-locs 0)))))) + "??? Can't get name of debug-block's function." + (debug-fun-name + (code-location-debug-fun (svref code-locs 0)))))) ;; (There used to be more cases back before sbcl-0.7.0, when we ;; did special tricks to debug the IR1 interpreter.) )) @@ -1938,7 +1938,7 @@ register." ;;; not :VALID, then signal an INVALID-VALUE error. (defun debug-var-valid-value (debug-var frame) (unless (eq (debug-var-validity debug-var (frame-code-location frame)) - :valid) + :valid) (error 'invalid-value :debug-var debug-var :frame frame)) (debug-var-value debug-var frame)) @@ -1948,8 +1948,8 @@ register." (aver (typep frame 'compiled-frame)) (let ((res (access-compiled-debug-var-slot debug-var frame))) (if (indirect-value-cell-p res) - (value-cell-ref res) - res))) + (value-cell-ref res) + res))) ;;; This returns what is stored for the variable represented by ;;; DEBUG-VAR relative to the FRAME. This may be an indirect value @@ -1982,22 +1982,22 @@ register." (= (logand val #xff) sb!vm:single-float-widetag) ;; character (and (zerop (logandc2 val #x1fffffff)) ; Top bits zero - (= (logand val #xff) sb!vm:character-widetag)) ; char tag + (= (logand val #xff) sb!vm:character-widetag)) ; char tag ;; unbound marker (= val sb!vm:unbound-marker-widetag) ;; pointer (and (logbitp 0 val) - ;; Check that the pointer is valid. XXX Could do a better - ;; job. FIXME: e.g. by calling out to an is_valid_pointer - ;; routine in the C runtime support code - (or (< sb!vm:read-only-space-start val - (* sb!vm:*read-only-space-free-pointer* - sb!vm:n-word-bytes)) - (< sb!vm:static-space-start val - (* sb!vm:*static-space-free-pointer* - sb!vm:n-word-bytes)) - (< (current-dynamic-space-start) val - (sap-int (dynamic-space-free-pointer)))))) + ;; Check that the pointer is valid. XXX Could do a better + ;; job. FIXME: e.g. by calling out to an is_valid_pointer + ;; routine in the C runtime support code + (or (< sb!vm:read-only-space-start val + (* sb!vm:*read-only-space-free-pointer* + sb!vm:n-word-bytes)) + (< sb!vm:static-space-start val + (* sb!vm:*static-space-free-pointer* + sb!vm:n-word-bytes)) + (< (current-dynamic-space-start) val + (sap-int (dynamic-space-free-pointer)))))) (make-lisp-obj val) :invalid-object)) @@ -2036,7 +2036,7 @@ register." #!+rt #.sb!vm:word-pointer-reg-sc-number) (sb!sys:without-gcing (with-escaped-value (val) (sb!kernel:make-lisp-obj val)))) - + (#.sb!vm:character-reg-sc-number (with-escaped-value (val) (code-char val))) @@ -2148,44 +2148,44 @@ register." (defun sub-access-debug-var-slot (fp sc-offset &optional escaped) (declare (type system-area-pointer fp)) (macrolet ((with-escaped-value ((var) &body forms) - `(if escaped - (let ((,var (sb!vm:context-register - escaped - (sb!c:sc-offset-offset sc-offset)))) - ,@forms) - :invalid-value-for-unescaped-register-storage)) - (escaped-float-value (format) - `(if escaped - (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) ',format) - :invalid-value-for-unescaped-register-storage)) - (escaped-complex-float-value (format) - `(if escaped - (complex - (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) ',format) - (sb!vm:context-float-register - escaped (1+ (sb!c:sc-offset-offset sc-offset)) ',format)) - :invalid-value-for-unescaped-register-storage))) + `(if escaped + (let ((,var (sb!vm:context-register + escaped + (sb!c:sc-offset-offset sc-offset)))) + ,@forms) + :invalid-value-for-unescaped-register-storage)) + (escaped-float-value (format) + `(if escaped + (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) ',format) + :invalid-value-for-unescaped-register-storage)) + (escaped-complex-float-value (format) + `(if escaped + (complex + (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) ',format) + (sb!vm:context-float-register + escaped (1+ (sb!c:sc-offset-offset sc-offset)) ',format)) + :invalid-value-for-unescaped-register-storage))) (ecase (sb!c:sc-offset-scn sc-offset) ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number) (without-gcing - (with-escaped-value (val) - (make-valid-lisp-obj val)))) + (with-escaped-value (val) + (make-valid-lisp-obj val)))) (#.sb!vm:character-reg-sc-number (with-escaped-value (val) - (code-char val))) + (code-char val))) (#.sb!vm:sap-reg-sc-number (with-escaped-value (val) - (int-sap val))) + (int-sap val))) (#.sb!vm:signed-reg-sc-number (with-escaped-value (val) - (if (logbitp (1- sb!vm:n-word-bits) val) - (logior val (ash -1 sb!vm:n-word-bits)) - val))) + (if (logbitp (1- sb!vm:n-word-bits) val) + (logior val (ash -1 sb!vm:n-word-bits)) + val))) (#.sb!vm:unsigned-reg-sc-number (with-escaped-value (val) - val)) + val)) (#.sb!vm:single-reg-sc-number (escaped-float-value single-float)) (#.sb!vm:double-reg-sc-number @@ -2202,48 +2202,48 @@ register." (escaped-complex-float-value long-float)) (#.sb!vm:single-stack-sc-number (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes)))) + sb!vm:n-word-bytes)))) (#.sb!vm:double-stack-sc-number (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes)))) + sb!vm:n-word-bytes)))) #!+long-float (#.sb!vm:long-stack-sc-number (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) - sb!vm:n-word-bytes)))) + sb!vm:n-word-bytes)))) (#.sb!vm:complex-single-stack-sc-number (complex - (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes))))) + (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:n-word-bytes))) + (sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) + sb!vm:n-word-bytes))))) (#.sb!vm:complex-double-stack-sc-number (complex - (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes))) - (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4) - sb!vm:n-word-bytes))))) + (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) + sb!vm:n-word-bytes))) + (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4) + sb!vm:n-word-bytes))))) #!+long-float (#.sb!vm:complex-long-stack-sc-number (complex - (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) - sb!vm:n-word-bytes))) - (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6) - sb!vm:n-word-bytes))))) + (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) + sb!vm:n-word-bytes))) + (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6) + sb!vm:n-word-bytes))))) (#.sb!vm:control-stack-sc-number (stack-ref fp (sb!c:sc-offset-offset sc-offset))) (#.sb!vm:character-stack-sc-number (code-char - (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))))) + (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:n-word-bytes))))) (#.sb!vm:unsigned-stack-sc-number (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes)))) + sb!vm:n-word-bytes)))) (#.sb!vm:signed-stack-sc-number (signed-sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes)))) + sb!vm:n-word-bytes)))) (#.sb!vm:sap-stack-sc-number (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))))))) + sb!vm:n-word-bytes))))))) ;;; This stores value as the value of DEBUG-VAR in FRAME. In the ;;; COMPILED-DEBUG-VAR case, access the current value to determine if @@ -2253,8 +2253,8 @@ register." (aver (typep frame 'compiled-frame)) (let ((old-value (access-compiled-debug-var-slot debug-var frame))) (if (indirect-value-cell-p old-value) - (value-cell-set old-value new-value) - (set-compiled-debug-var-slot debug-var frame new-value))) + (value-cell-set old-value new-value) + (set-compiled-debug-var-slot debug-var frame new-value))) new-value) ;;; This stores VALUE for the variable represented by debug-var @@ -2264,54 +2264,54 @@ register." (defun set-compiled-debug-var-slot (debug-var frame value) (let ((escaped (compiled-frame-escaped frame))) (if escaped - (sub-set-debug-var-slot (frame-pointer frame) - (compiled-debug-var-sc-offset debug-var) - value escaped) - (sub-set-debug-var-slot - (frame-pointer frame) - (or (compiled-debug-var-save-sc-offset debug-var) - (compiled-debug-var-sc-offset debug-var)) - value)))) + (sub-set-debug-var-slot (frame-pointer frame) + (compiled-debug-var-sc-offset debug-var) + value escaped) + (sub-set-debug-var-slot + (frame-pointer frame) + (or (compiled-debug-var-save-sc-offset debug-var) + (compiled-debug-var-sc-offset debug-var)) + value)))) #!-(or x86 x86-64) (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) (macrolet ((set-escaped-value (val) - `(if escaped - (setf (sb!vm:context-register - escaped - (sb!c:sc-offset-offset sc-offset)) - ,val) - value)) - (set-escaped-float-value (format val) - `(if escaped - (setf (sb!vm:context-float-register - escaped - (sb!c:sc-offset-offset sc-offset) - ',format) - ,val) - value)) - (with-nfp ((var) &body body) - `(let ((,var (if escaped - (int-sap - (sb!vm:context-register escaped - sb!vm::nfp-offset)) - #!-alpha - (sap-ref-sap fp - (* nfp-save-offset - sb!vm:n-word-bytes)) - #!+alpha - (sb!vm::make-number-stack-pointer - (sap-ref-32 fp - (* nfp-save-offset - sb!vm:n-word-bytes)))))) - ,@body))) + `(if escaped + (setf (sb!vm:context-register + escaped + (sb!c:sc-offset-offset sc-offset)) + ,val) + value)) + (set-escaped-float-value (format val) + `(if escaped + (setf (sb!vm:context-float-register + escaped + (sb!c:sc-offset-offset sc-offset) + ',format) + ,val) + value)) + (with-nfp ((var) &body body) + `(let ((,var (if escaped + (int-sap + (sb!vm:context-register escaped + sb!vm::nfp-offset)) + #!-alpha + (sap-ref-sap fp + (* nfp-save-offset + sb!vm:n-word-bytes)) + #!+alpha + (sb!vm::make-number-stack-pointer + (sap-ref-32 fp + (* nfp-save-offset + sb!vm:n-word-bytes)))))) + ,@body))) (ecase (sb!c:sc-offset-scn sc-offset) ((#.sb!vm:any-reg-sc-number - #.sb!vm:descriptor-reg-sc-number - #!+rt #.sb!vm:word-pointer-reg-sc-number) + #.sb!vm:descriptor-reg-sc-number + #!+rt #.sb!vm:word-pointer-reg-sc-number) (without-gcing - (set-escaped-value - (get-lisp-obj-address value)))) + (set-escaped-value + (get-lisp-obj-address value)))) (#.sb!vm:character-reg-sc-number (set-escaped-value (char-code value))) (#.sb!vm:sap-reg-sc-number @@ -2333,119 +2333,119 @@ register." (set-escaped-float-value long-float value)) (#.sb!vm:complex-single-reg-sc-number (when escaped - (setf (sb!vm:context-float-register escaped - (sb!c:sc-offset-offset sc-offset) - 'single-float) - (realpart value)) - (setf (sb!vm:context-float-register - escaped (1+ (sb!c:sc-offset-offset sc-offset)) - 'single-float) - (imagpart value))) + (setf (sb!vm:context-float-register escaped + (sb!c:sc-offset-offset sc-offset) + 'single-float) + (realpart value)) + (setf (sb!vm:context-float-register + escaped (1+ (sb!c:sc-offset-offset sc-offset)) + 'single-float) + (imagpart value))) value) (#.sb!vm:complex-double-reg-sc-number (when escaped - (setf (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) 'double-float) - (realpart value)) - (setf (sb!vm:context-float-register - escaped - (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1) - 'double-float) - (imagpart value))) + (setf (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) 'double-float) + (realpart value)) + (setf (sb!vm:context-float-register + escaped + (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1) + 'double-float) + (imagpart value))) value) #!+long-float (#.sb!vm:complex-long-reg-sc-number (when escaped - (setf (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) 'long-float) - (realpart value)) - (setf (sb!vm:context-float-register - escaped - (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4) - 'long-float) - (imagpart value))) + (setf (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) 'long-float) + (realpart value)) + (setf (sb!vm:context-float-register + escaped + (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4) + 'long-float) + (imagpart value))) value) (#.sb!vm:single-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) - (the single-float value)))) + (setf (sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:n-word-bytes)) + (the single-float value)))) (#.sb!vm:double-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) - (the double-float value)))) + (setf (sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:n-word-bytes)) + (the double-float value)))) #!+long-float (#.sb!vm:long-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) - (the long-float value)))) + (setf (sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:n-word-bytes)) + (the long-float value)))) (#.sb!vm:complex-single-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-single - nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)) - (the single-float (realpart value))) - (setf (sap-ref-single - nfp (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes)) - (the single-float (realpart value))))) + (setf (sap-ref-single + nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)) + (the single-float (realpart value))) + (setf (sap-ref-single + nfp (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:n-word-bytes)) + (the single-float (realpart value))))) (#.sb!vm:complex-double-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-double - nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)) - (the double-float (realpart value))) - (setf (sap-ref-double - nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes)) - (the double-float (realpart value))))) + (setf (sap-ref-double + nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)) + (the double-float (realpart value))) + (setf (sap-ref-double + nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2) + sb!vm:n-word-bytes)) + (the double-float (realpart value))))) #!+long-float (#.sb!vm:complex-long-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-long - nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)) - (the long-float (realpart value))) - (setf (sap-ref-long - nfp (* (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4) - sb!vm:n-word-bytes)) - (the long-float (realpart value))))) + (setf (sap-ref-long + nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)) + (the long-float (realpart value))) + (setf (sap-ref-long + nfp (* (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4) + sb!vm:n-word-bytes)) + (the long-float (realpart value))))) (#.sb!vm:control-stack-sc-number (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value)) (#.sb!vm:character-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) - (char-code (the character value))))) + (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:n-word-bytes)) + (char-code (the character value))))) (#.sb!vm:unsigned-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) - (the (unsigned-byte 32) value)))) + (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:n-word-bytes)) + (the (unsigned-byte 32) value)))) (#.sb!vm:signed-stack-sc-number (with-nfp (nfp) - (setf (signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) - (the (signed-byte 32) value)))) + (setf (signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:n-word-bytes)) + (the (signed-byte 32) value)))) (#.sb!vm:sap-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) - (the system-area-pointer value))))))) + (setf (sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset) + sb!vm:n-word-bytes)) + (the system-area-pointer value))))))) #!+(or x86 x86-64) (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) (macrolet ((set-escaped-value (val) - `(if escaped - (setf (sb!vm:context-register - escaped - (sb!c:sc-offset-offset sc-offset)) - ,val) - value))) + `(if escaped + (setf (sb!vm:context-register + escaped + (sb!c:sc-offset-offset sc-offset)) + ,val) + value))) (ecase (sb!c:sc-offset-scn sc-offset) ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number) (without-gcing - (set-escaped-value - (get-lisp-obj-address value)))) + (set-escaped-value + (get-lisp-obj-address value)))) (#.sb!vm:character-reg-sc-number (set-escaped-value (char-code value))) (#.sb!vm:sap-reg-sc-number @@ -2455,78 +2455,78 @@ register." (#.sb!vm:unsigned-reg-sc-number (set-escaped-value value)) (#.sb!vm:single-reg-sc-number - #+nil ;; don't have escaped floats. + #+nil ;; don't have escaped floats. (set-escaped-float-value single-float value)) (#.sb!vm:double-reg-sc-number - #+nil ;; don't have escaped floats -- still in npx? + #+nil ;; don't have escaped floats -- still in npx? (set-escaped-float-value double-float value)) #!+long-float (#.sb!vm:long-reg-sc-number - #+nil ;; don't have escaped floats -- still in npx? + #+nil ;; don't have escaped floats -- still in npx? (set-escaped-float-value long-float value)) (#.sb!vm:single-stack-sc-number (setf (sap-ref-single - fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (the single-float value))) + fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:n-word-bytes))) + (the single-float value))) (#.sb!vm:double-stack-sc-number (setf (sap-ref-double - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes))) - (the double-float value))) + fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) + sb!vm:n-word-bytes))) + (the double-float value))) #!+long-float (#.sb!vm:long-stack-sc-number (setf (sap-ref-long - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) - sb!vm:n-word-bytes))) - (the long-float value))) + fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) + sb!vm:n-word-bytes))) + (the long-float value))) (#.sb!vm:complex-single-stack-sc-number (setf (sap-ref-single - fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (realpart (the (complex single-float) value))) + fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:n-word-bytes))) + (realpart (the (complex single-float) value))) (setf (sap-ref-single - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes))) - (imagpart (the (complex single-float) value)))) + fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) + sb!vm:n-word-bytes))) + (imagpart (the (complex single-float) value)))) (#.sb!vm:complex-double-stack-sc-number (setf (sap-ref-double - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes))) - (realpart (the (complex double-float) value))) + fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) + sb!vm:n-word-bytes))) + (realpart (the (complex double-float) value))) (setf (sap-ref-double - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4) - sb!vm:n-word-bytes))) - (imagpart (the (complex double-float) value)))) + fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4) + sb!vm:n-word-bytes))) + (imagpart (the (complex double-float) value)))) #!+long-float (#.sb!vm:complex-long-stack-sc-number (setf (sap-ref-long - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) - sb!vm:n-word-bytes))) - (realpart (the (complex long-float) value))) + fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) + sb!vm:n-word-bytes))) + (realpart (the (complex long-float) value))) (setf (sap-ref-long - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6) - sb!vm:n-word-bytes))) - (imagpart (the (complex long-float) value)))) + fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6) + sb!vm:n-word-bytes))) + (imagpart (the (complex long-float) value)))) (#.sb!vm:control-stack-sc-number (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value)) (#.sb!vm:character-stack-sc-number (setf (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (char-code (the character value)))) + sb!vm:n-word-bytes))) + (char-code (the character value)))) (#.sb!vm:unsigned-stack-sc-number (setf (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (the sb!vm:word value))) + sb!vm:n-word-bytes))) + (the sb!vm:word value))) (#.sb!vm:signed-stack-sc-number (setf (signed-sap-ref-word - fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (the (signed-byte #.sb!vm:n-word-bits) value))) + fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:n-word-bytes))) + (the (signed-byte #.sb!vm:n-word-bits) value))) (#.sb!vm:sap-stack-sc-number (setf (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (the system-area-pointer value)))))) + sb!vm:n-word-bytes))) + (the system-area-pointer value)))))) ;;; The method for setting and accessing COMPILED-DEBUG-VAR values use ;;; this to determine if the value stored is the actual value or an @@ -2558,29 +2558,29 @@ register." (defun compiled-debug-var-validity (debug-var basic-code-location) (declare (type compiled-code-location basic-code-location)) (cond ((debug-var-alive-p debug-var) - (let ((debug-fun (code-location-debug-fun basic-code-location))) - (if (>= (compiled-code-location-pc basic-code-location) - (sb!c::compiled-debug-fun-start-pc - (compiled-debug-fun-compiler-debug-fun debug-fun))) - :valid - :invalid))) - ((code-location-unknown-p basic-code-location) :unknown) - (t - (let ((pos (position debug-var - (debug-fun-debug-vars - (code-location-debug-fun - basic-code-location))))) - (unless pos - (error 'unknown-debug-var - :debug-var debug-var - :debug-fun - (code-location-debug-fun basic-code-location))) - ;; There must be live-set info since basic-code-location is known. - (if (zerop (sbit (compiled-code-location-live-set - basic-code-location) - pos)) - :invalid - :valid))))) + (let ((debug-fun (code-location-debug-fun basic-code-location))) + (if (>= (compiled-code-location-pc basic-code-location) + (sb!c::compiled-debug-fun-start-pc + (compiled-debug-fun-compiler-debug-fun debug-fun))) + :valid + :invalid))) + ((code-location-unknown-p basic-code-location) :unknown) + (t + (let ((pos (position debug-var + (debug-fun-debug-vars + (code-location-debug-fun + basic-code-location))))) + (unless pos + (error 'unknown-debug-var + :debug-var debug-var + :debug-fun + (code-location-debug-fun basic-code-location))) + ;; There must be live-set info since basic-code-location is known. + (if (zerop (sbit (compiled-code-location-live-set + basic-code-location) + pos)) + :invalid + :valid))))) ;;;; sources @@ -2593,7 +2593,7 @@ register." ;;; descend. For example: ;;; (defun foo (x) ;;; (let ((a (aref x 3))) -;;; (cons a 3))) +;;; (cons a 3))) ;;; The call to AREF in this example is form number 5. Assuming this ;;; DEFUN is the 11'th top level form, the source-path for the AREF ;;; call is as follows: @@ -2624,24 +2624,24 @@ register." (unless (gethash form *form-number-circularity-table*) (setf (gethash form *form-number-circularity-table*) t) (vector-push-extend (cons (fill-pointer *form-number-temp*) path) - *form-number-temp*) + *form-number-temp*) (let ((pos 0) - (subform form) - (trail form)) + (subform form) + (trail form)) (declare (fixnum pos)) (macrolet ((frob () - '(progn - (when (atom subform) (return)) - (let ((fm (car subform))) - (when (consp fm) - (sub-translate-form-numbers fm (cons pos path))) - (incf pos)) - (setq subform (cdr subform)) - (when (eq subform trail) (return))))) - (loop - (frob) - (frob) - (setq trail (cdr trail))))))) + '(progn + (when (atom subform) (return)) + (let ((fm (car subform))) + (when (consp fm) + (sub-translate-form-numbers fm (cons pos path))) + (incf pos)) + (setq subform (cdr subform)) + (when (eq subform trail) (return))))) + (loop + (frob) + (frob) + (setq trail (cdr trail))))))) ;;; FORM is a top level form, and path is a source-path into it. This ;;; returns the form indicated by the source-path. Context is the @@ -2656,10 +2656,10 @@ register." (let ((path (reverse (butlast (cdr path))))) (dotimes (i (- (length path) context)) (let ((index (first path))) - (unless (and (listp form) (< index (length form))) - (error "Source path no longer exists.")) - (setq form (elt form index)) - (setq path (rest path)))) + (unless (and (listp form) (< index (length form))) + (error "Source path no longer exists.")) + (setq form (elt form index)) + (setq path (rest path)))) ;; Recursively rebuild the source form resulting from the above ;; descent, copying the beginning of each subform up to the next ;; subform we descend into according to path. At the bottom of the @@ -2667,16 +2667,16 @@ register." ;; marker, and this gets spliced into the resulting list structure ;; on the way back up. (labels ((frob (form path level) - (if (or (zerop level) (null path)) - (if (zerop context) - form - `(#:***here*** ,form)) - (let ((n (first path))) - (unless (and (listp form) (< n (length form))) - (error "Source path no longer exists.")) - (let ((res (frob (elt form n) (rest path) (1- level)))) - (nconc (subseq form 0 n) - (cons res (nthcdr (1+ n) form)))))))) + (if (or (zerop level) (null path)) + (if (zerop context) + form + `(#:***here*** ,form)) + (let ((n (first path))) + (unless (and (listp form) (< n (length form))) + (error "Source path no longer exists.")) + (let ((res (frob (elt form n) (rest path) (1- level)))) + (nconc (subseq form 0 n) + (cons res (nthcdr (1+ n) form)))))))) (frob form path context)))) ;;;; PREPROCESS-FOR-EVAL @@ -2693,46 +2693,46 @@ register." (defun preprocess-for-eval (form loc) (declare (type code-location loc)) (let ((n-frame (gensym)) - (fun (code-location-debug-fun loc))) + (fun (code-location-debug-fun loc))) (unless (debug-var-info-available fun) (debug-signal 'no-debug-vars :debug-fun fun)) (sb!int:collect ((binds) - (specs)) + (specs)) (do-debug-fun-vars (var fun) - (let ((validity (debug-var-validity var loc))) - (unless (eq validity :invalid) - (let* ((sym (debug-var-symbol var)) - (found (assoc sym (binds)))) - (if found - (setf (second found) :ambiguous) - (binds (list sym validity var))))))) + (let ((validity (debug-var-validity var loc))) + (unless (eq validity :invalid) + (let* ((sym (debug-var-symbol var)) + (found (assoc sym (binds)))) + (if found + (setf (second found) :ambiguous) + (binds (list sym validity var))))))) (dolist (bind (binds)) - (let ((name (first bind)) - (var (third bind))) - (ecase (second bind) - (:valid - (specs `(,name (debug-var-value ',var ,n-frame)))) - (:unknown - (specs `(,name (debug-signal 'invalid-value - :debug-var ',var - :frame ,n-frame)))) - (:ambiguous - (specs `(,name (debug-signal 'ambiguous-var-name - :name ',name - :frame ,n-frame))))))) + (let ((name (first bind)) + (var (third bind))) + (ecase (second bind) + (:valid + (specs `(,name (debug-var-value ',var ,n-frame)))) + (:unknown + (specs `(,name (debug-signal 'invalid-value + :debug-var ',var + :frame ,n-frame)))) + (:ambiguous + (specs `(,name (debug-signal 'ambiguous-var-name + :name ',name + :frame ,n-frame))))))) (let ((res (coerce `(lambda (,n-frame) - (declare (ignorable ,n-frame)) - (symbol-macrolet ,(specs) ,form)) - 'function))) - (lambda (frame) - ;; This prevents these functions from being used in any - ;; location other than a function return location, so maybe - ;; this should only check whether FRAME's DEBUG-FUN is the - ;; same as LOC's. - (unless (code-location= (frame-code-location frame) loc) - (debug-signal 'frame-fun-mismatch - :code-location loc :form form :frame frame)) - (funcall res frame)))))) + (declare (ignorable ,n-frame)) + (symbol-macrolet ,(specs) ,form)) + 'function))) + (lambda (frame) + ;; This prevents these functions from being used in any + ;; location other than a function return location, so maybe + ;; this should only check whether FRAME's DEBUG-FUN is the + ;; same as LOC's. + (unless (code-location= (frame-code-location frame) loc) + (debug-signal 'frame-fun-mismatch + :code-location loc :form form :frame frame)) + (funcall res frame)))))) ;;;; breakpoints @@ -2767,50 +2767,50 @@ register." ;;; ;;; Signal an error if WHAT is an unknown code-location. (defun make-breakpoint (hook-fun what - &key (kind :code-location) info fun-end-cookie) + &key (kind :code-location) info fun-end-cookie) (etypecase what (code-location (when (code-location-unknown-p what) (error "cannot make a breakpoint at an unknown code location: ~S" - what)) + what)) (aver (eq kind :code-location)) (let ((bpt (%make-breakpoint hook-fun what kind info))) (etypecase what - (compiled-code-location - ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P. - (when (eq (compiled-code-location-kind what) :unknown-return) - (let ((other-bpt (%make-breakpoint hook-fun what - :unknown-return-partner - info))) - (setf (breakpoint-unknown-return-partner bpt) other-bpt) - (setf (breakpoint-unknown-return-partner other-bpt) bpt)))) - ;; (There used to be more cases back before sbcl-0.7.0,, - ;; when we did special tricks to debug the IR1 - ;; interpreter.) - ) + (compiled-code-location + ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P. + (when (eq (compiled-code-location-kind what) :unknown-return) + (let ((other-bpt (%make-breakpoint hook-fun what + :unknown-return-partner + info))) + (setf (breakpoint-unknown-return-partner bpt) other-bpt) + (setf (breakpoint-unknown-return-partner other-bpt) bpt)))) + ;; (There used to be more cases back before sbcl-0.7.0,, + ;; when we did special tricks to debug the IR1 + ;; interpreter.) + ) bpt)) (compiled-debug-fun (ecase kind (:fun-start - (%make-breakpoint hook-fun what kind info)) + (%make-breakpoint hook-fun what kind info)) (:fun-end - (unless (eq (sb!c::compiled-debug-fun-returns - (compiled-debug-fun-compiler-debug-fun what)) - :standard) - (error ":FUN-END breakpoints are currently unsupported ~ + (unless (eq (sb!c::compiled-debug-fun-returns + (compiled-debug-fun-compiler-debug-fun what)) + :standard) + (error ":FUN-END breakpoints are currently unsupported ~ for the known return convention.")) - (let* ((bpt (%make-breakpoint hook-fun what kind info)) - (starter (compiled-debug-fun-end-starter what))) - (unless starter - (setf starter (%make-breakpoint #'list what :fun-start nil)) - (setf (breakpoint-hook-fun starter) - (fun-end-starter-hook starter what)) - (setf (compiled-debug-fun-end-starter what) starter)) - (setf (breakpoint-start-helper bpt) starter) - (push bpt (breakpoint-%info starter)) - (setf (breakpoint-cookie-fun bpt) fun-end-cookie) - bpt)))))) + (let* ((bpt (%make-breakpoint hook-fun what kind info)) + (starter (compiled-debug-fun-end-starter what))) + (unless starter + (setf starter (%make-breakpoint #'list what :fun-start nil)) + (setf (breakpoint-hook-fun starter) + (fun-end-starter-hook starter what)) + (setf (compiled-debug-fun-end-starter what) starter)) + (setf (breakpoint-start-helper bpt) starter) + (push bpt (breakpoint-%info starter)) + (setf (breakpoint-cookie-fun bpt) fun-end-cookie) + bpt)))))) ;;; These are unique objects created upon entry into a function by a ;;; :FUN-END breakpoint's starter hook. These are only created @@ -2818,10 +2818,10 @@ register." ;;; the :FUN-END breakpoint's hook is called on the same cookie ;;; when it is created. (defstruct (fun-end-cookie - (:print-object (lambda (obj str) - (print-unreadable-object (obj str :type t)))) - (:constructor make-fun-end-cookie (bogus-lra debug-fun)) - (:copier nil)) + (:print-object (lambda (obj str) + (print-unreadable-object (obj str :type t)))) + (:constructor make-fun-end-cookie (bogus-lra debug-fun)) + (:copier nil)) ;; a pointer to the bogus-lra created for :FUN-END breakpoints bogus-lra ;; the DEBUG-FUN associated with this cookie @@ -2841,32 +2841,32 @@ register." ;;; function, we must establish breakpoint-data about FUN-END-BPT. (defun fun-end-starter-hook (starter-bpt debug-fun) (declare (type breakpoint starter-bpt) - (type compiled-debug-fun debug-fun)) + (type compiled-debug-fun debug-fun)) (lambda (frame breakpoint) (declare (ignore breakpoint) - (type frame frame)) + (type frame frame)) (let ((lra-sc-offset - (sb!c::compiled-debug-fun-return-pc - (compiled-debug-fun-compiler-debug-fun debug-fun)))) + (sb!c::compiled-debug-fun-return-pc + (compiled-debug-fun-compiler-debug-fun debug-fun)))) (multiple-value-bind (lra component offset) - (make-bogus-lra - (get-context-value frame - lra-save-offset - lra-sc-offset)) - (setf (get-context-value frame - lra-save-offset - lra-sc-offset) - lra) - (let ((end-bpts (breakpoint-%info starter-bpt))) - (let ((data (breakpoint-data component offset))) - (setf (breakpoint-data-breakpoints data) end-bpts) - (dolist (bpt end-bpts) - (setf (breakpoint-internal-data bpt) data))) - (let ((cookie (make-fun-end-cookie lra debug-fun))) - (setf (gethash component *fun-end-cookies*) cookie) - (dolist (bpt end-bpts) - (let ((fun (breakpoint-cookie-fun bpt))) - (when fun (funcall fun frame cookie)))))))))) + (make-bogus-lra + (get-context-value frame + lra-save-offset + lra-sc-offset)) + (setf (get-context-value frame + lra-save-offset + lra-sc-offset) + lra) + (let ((end-bpts (breakpoint-%info starter-bpt))) + (let ((data (breakpoint-data component offset))) + (setf (breakpoint-data-breakpoints data) end-bpts) + (dolist (bpt end-bpts) + (setf (breakpoint-internal-data bpt) data))) + (let ((cookie (make-fun-end-cookie lra debug-fun))) + (setf (gethash component *fun-end-cookies*) cookie) + (dolist (bpt end-bpts) + (let ((fun (breakpoint-cookie-fun bpt))) + (when fun (funcall fun frame cookie)))))))))) ;;; This takes a FUN-END-COOKIE and a frame, and it returns ;;; whether the cookie is still valid. A cookie becomes invalid when @@ -2880,16 +2880,16 @@ register." ;;; series of cookies is valid. (defun fun-end-cookie-valid-p (frame cookie) (let ((lra (fun-end-cookie-bogus-lra cookie)) - (lra-sc-offset (sb!c::compiled-debug-fun-return-pc - (compiled-debug-fun-compiler-debug-fun - (fun-end-cookie-debug-fun cookie))))) + (lra-sc-offset (sb!c::compiled-debug-fun-return-pc + (compiled-debug-fun-compiler-debug-fun + (fun-end-cookie-debug-fun cookie))))) (do ((frame frame (frame-down frame))) - ((not frame) nil) + ((not frame) nil) (when (and (compiled-frame-p frame) (#!-(or x86 x86-64) eq #!+(or x86 x86-64) sap= - lra - (get-context-value frame lra-save-offset lra-sc-offset))) - (return t))))) + lra + (get-context-value frame lra-save-offset lra-sc-offset))) + (return t))))) ;;;; ACTIVATE-BREAKPOINT @@ -2904,33 +2904,33 @@ register." (ecase (breakpoint-kind breakpoint) (:code-location (let ((loc (breakpoint-what breakpoint))) - (etypecase loc - (compiled-code-location - (activate-compiled-code-location-breakpoint breakpoint) - (let ((other (breakpoint-unknown-return-partner breakpoint))) - (when other - (activate-compiled-code-location-breakpoint other)))) - ;; (There used to be more cases back before sbcl-0.7.0, when - ;; we did special tricks to debug the IR1 interpreter.) - ))) + (etypecase loc + (compiled-code-location + (activate-compiled-code-location-breakpoint breakpoint) + (let ((other (breakpoint-unknown-return-partner breakpoint))) + (when other + (activate-compiled-code-location-breakpoint other)))) + ;; (There used to be more cases back before sbcl-0.7.0, when + ;; we did special tricks to debug the IR1 interpreter.) + ))) (:fun-start (etypecase (breakpoint-what breakpoint) - (compiled-debug-fun - (activate-compiled-fun-start-breakpoint breakpoint)) - ;; (There used to be more cases back before sbcl-0.7.0, when - ;; we did special tricks to debug the IR1 interpreter.) - )) + (compiled-debug-fun + (activate-compiled-fun-start-breakpoint breakpoint)) + ;; (There used to be more cases back before sbcl-0.7.0, when + ;; we did special tricks to debug the IR1 interpreter.) + )) (:fun-end (etypecase (breakpoint-what breakpoint) - (compiled-debug-fun - (let ((starter (breakpoint-start-helper breakpoint))) - (unless (eq (breakpoint-status starter) :active) - ;; may already be active by some other :FUN-END breakpoint - (activate-compiled-fun-start-breakpoint starter))) - (setf (breakpoint-status breakpoint) :active)) - ;; (There used to be more cases back before sbcl-0.7.0, when - ;; we did special tricks to debug the IR1 interpreter.) - )))) + (compiled-debug-fun + (let ((starter (breakpoint-start-helper breakpoint))) + (unless (eq (breakpoint-status starter) :active) + ;; may already be active by some other :FUN-END breakpoint + (activate-compiled-fun-start-breakpoint starter))) + (setf (breakpoint-status breakpoint) :active)) + ;; (There used to be more cases back before sbcl-0.7.0, when + ;; we did special tricks to debug the IR1 interpreter.) + )))) breakpoint) (defun activate-compiled-code-location-breakpoint (breakpoint) @@ -2940,14 +2940,14 @@ register." (sub-activate-breakpoint breakpoint (breakpoint-data (compiled-debug-fun-component - (code-location-debug-fun loc)) - (+ (compiled-code-location-pc loc) - (if (or (eq (breakpoint-kind breakpoint) - :unknown-return-partner) - (eq (compiled-code-location-kind loc) - :single-value-return)) - sb!vm:single-value-return-byte-offset - 0)))))) + (code-location-debug-fun loc)) + (+ (compiled-code-location-pc loc) + (if (or (eq (breakpoint-kind breakpoint) + :unknown-return-partner) + (eq (compiled-code-location-kind loc) + :single-value-return)) + sb!vm:single-value-return-byte-offset + 0)))))) (defun activate-compiled-fun-start-breakpoint (breakpoint) (declare (type breakpoint breakpoint)) @@ -2955,23 +2955,23 @@ register." (sub-activate-breakpoint breakpoint (breakpoint-data (compiled-debug-fun-component debug-fun) - (sb!c::compiled-debug-fun-start-pc - (compiled-debug-fun-compiler-debug-fun - debug-fun)))))) + (sb!c::compiled-debug-fun-start-pc + (compiled-debug-fun-compiler-debug-fun + debug-fun)))))) (defun sub-activate-breakpoint (breakpoint data) (declare (type breakpoint breakpoint) - (type breakpoint-data data)) + (type breakpoint-data data)) (setf (breakpoint-status breakpoint) :active) (without-interrupts (unless (breakpoint-data-breakpoints data) (setf (breakpoint-data-instruction data) - (without-gcing - (breakpoint-install (get-lisp-obj-address - (breakpoint-data-component data)) - (breakpoint-data-offset data))))) + (without-gcing + (breakpoint-install (get-lisp-obj-address + (breakpoint-data-component data)) + (breakpoint-data-offset data))))) (setf (breakpoint-data-breakpoints data) - (append (breakpoint-data-breakpoints data) (list breakpoint))) + (append (breakpoint-data-breakpoints data) (list breakpoint))) (setf (breakpoint-internal-data breakpoint) data))) ;;;; DEACTIVATE-BREAKPOINT @@ -2982,35 +2982,35 @@ register." (without-interrupts (let ((loc (breakpoint-what breakpoint))) (etypecase loc - ((or compiled-code-location compiled-debug-fun) - (deactivate-compiled-breakpoint breakpoint) - (let ((other (breakpoint-unknown-return-partner breakpoint))) - (when other - (deactivate-compiled-breakpoint other)))) - ;; (There used to be more cases back before sbcl-0.7.0, when - ;; we did special tricks to debug the IR1 interpreter.) - )))) + ((or compiled-code-location compiled-debug-fun) + (deactivate-compiled-breakpoint breakpoint) + (let ((other (breakpoint-unknown-return-partner breakpoint))) + (when other + (deactivate-compiled-breakpoint other)))) + ;; (There used to be more cases back before sbcl-0.7.0, when + ;; we did special tricks to debug the IR1 interpreter.) + )))) breakpoint) (defun deactivate-compiled-breakpoint (breakpoint) (if (eq (breakpoint-kind breakpoint) :fun-end) (let ((starter (breakpoint-start-helper breakpoint))) - (unless (find-if (lambda (bpt) - (and (not (eq bpt breakpoint)) - (eq (breakpoint-status bpt) :active))) - (breakpoint-%info starter)) - (deactivate-compiled-breakpoint starter))) + (unless (find-if (lambda (bpt) + (and (not (eq bpt breakpoint)) + (eq (breakpoint-status bpt) :active))) + (breakpoint-%info starter)) + (deactivate-compiled-breakpoint starter))) (let* ((data (breakpoint-internal-data breakpoint)) - (bpts (delete breakpoint (breakpoint-data-breakpoints data)))) - (setf (breakpoint-internal-data breakpoint) nil) - (setf (breakpoint-data-breakpoints data) bpts) - (unless bpts - (without-gcing - (breakpoint-remove (get-lisp-obj-address - (breakpoint-data-component data)) - (breakpoint-data-offset data) - (breakpoint-data-instruction data))) - (delete-breakpoint-data data)))) + (bpts (delete breakpoint (breakpoint-data-breakpoints data)))) + (setf (breakpoint-internal-data breakpoint) nil) + (setf (breakpoint-data-breakpoints data) bpts) + (unless bpts + (without-gcing + (breakpoint-remove (get-lisp-obj-address + (breakpoint-data-component data)) + (breakpoint-data-offset data) + (breakpoint-data-instruction data))) + (delete-breakpoint-data data)))) (setf (breakpoint-status breakpoint) :inactive) breakpoint) @@ -3040,21 +3040,21 @@ register." (let ((status (breakpoint-status breakpoint))) (unless (eq status :deleted) (when (eq status :active) - (deactivate-breakpoint breakpoint)) + (deactivate-breakpoint breakpoint)) (setf (breakpoint-status breakpoint) :deleted) (let ((other (breakpoint-unknown-return-partner breakpoint))) - (when other - (setf (breakpoint-status other) :deleted))) + (when other + (setf (breakpoint-status other) :deleted))) (when (eq (breakpoint-kind breakpoint) :fun-end) - (let* ((starter (breakpoint-start-helper breakpoint)) - (breakpoints (delete breakpoint - (the list (breakpoint-info starter))))) - (setf (breakpoint-info starter) breakpoints) - (unless breakpoints - (delete-breakpoint starter) - (setf (compiled-debug-fun-end-starter - (breakpoint-what breakpoint)) - nil)))))) + (let* ((starter (breakpoint-start-helper breakpoint)) + (breakpoints (delete breakpoint + (the list (breakpoint-info starter))))) + (setf (breakpoint-info starter) breakpoints) + (unless breakpoints + (delete-breakpoint starter) + (setf (compiled-debug-fun-end-starter + (breakpoint-what breakpoint)) + nil)))))) breakpoint) ;;;; C call out stubs @@ -3088,29 +3088,29 @@ register." ;;; offset. If none exists, this makes one, installs it, and returns it. (defun breakpoint-data (component offset &optional (create t)) (flet ((install-breakpoint-data () - (when create - (let ((data (make-breakpoint-data component offset))) - (push (cons offset data) - (gethash component *component-breakpoint-offsets*)) - data)))) + (when create + (let ((data (make-breakpoint-data component offset))) + (push (cons offset data) + (gethash component *component-breakpoint-offsets*)) + data)))) (let ((offsets (gethash component *component-breakpoint-offsets*))) (if offsets - (let ((data (assoc offset offsets))) - (if data - (cdr data) - (install-breakpoint-data))) - (install-breakpoint-data))))) + (let ((data (assoc offset offsets))) + (if data + (cdr data) + (install-breakpoint-data))) + (install-breakpoint-data))))) ;;; We use this when there are no longer any active breakpoints ;;; corresponding to DATA. (defun delete-breakpoint-data (data) (let* ((component (breakpoint-data-component data)) - (offsets (delete (breakpoint-data-offset data) - (gethash component *component-breakpoint-offsets*) - :key #'car))) + (offsets (delete (breakpoint-data-offset data) + (gethash component *component-breakpoint-offsets*) + :key #'car))) (if offsets - (setf (gethash component *component-breakpoint-offsets*) offsets) - (remhash component *component-breakpoint-offsets*))) + (setf (gethash component *component-breakpoint-offsets*) offsets) + (remhash component *component-breakpoint-offsets*))) (values)) ;;; The C handler for interrupts calls this when it has a @@ -3121,14 +3121,14 @@ register." (let ((data (breakpoint-data component offset nil))) (unless data (error "unknown breakpoint in ~S at offset ~S" - (debug-fun-name (debug-fun-from-pc component offset)) - offset)) + (debug-fun-name (debug-fun-from-pc component offset)) + offset)) (let ((breakpoints (breakpoint-data-breakpoints data))) (if (or (null breakpoints) - (eq (breakpoint-kind (car breakpoints)) :fun-end)) - (handle-fun-end-breakpoint-aux breakpoints data signal-context) - (handle-breakpoint-aux breakpoints data - offset component signal-context))))) + (eq (breakpoint-kind (car breakpoints)) :fun-end)) + (handle-fun-end-breakpoint-aux breakpoints data signal-context) + (handle-breakpoint-aux breakpoints data + offset component signal-context))))) ;;; This holds breakpoint-datas while invoking the breakpoint hooks ;;; associated with that particular component and location. While they @@ -3145,7 +3145,7 @@ register." (bug "breakpoint that nobody wants")) (unless (member data *executing-breakpoint-hooks*) (let ((*executing-breakpoint-hooks* (cons data - *executing-breakpoint-hooks*))) + *executing-breakpoint-hooks*))) (invoke-breakpoint-hooks breakpoints component offset))) ;; At this point breakpoints may not hold the same list as ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed @@ -3162,7 +3162,7 @@ register." ;; behind. The best way to do this is different on each machine, ;; so we just leave it up to the C code. (breakpoint-do-displaced-inst signal-context - (breakpoint-data-instruction data)) + (breakpoint-data-instruction data)) ;; Some platforms have no usable sigreturn() call. If your ;; implementation of arch_do_displaced_inst() _does_ sigreturn(), ;; it's polite to warn here @@ -3171,29 +3171,29 @@ register." (defun invoke-breakpoint-hooks (breakpoints component offset) (let* ((debug-fun (debug-fun-from-pc component offset)) - (frame (do ((f (top-frame) (frame-down f))) - ((eq debug-fun (frame-debug-fun f)) f)))) + (frame (do ((f (top-frame) (frame-down f))) + ((eq debug-fun (frame-debug-fun f)) f)))) (dolist (bpt breakpoints) (funcall (breakpoint-hook-fun bpt) - frame - ;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the - ;; hook function the original breakpoint, so that users - ;; aren't forced to confront the fact that some - ;; breakpoints really are two. - (if (eq (breakpoint-kind bpt) :unknown-return-partner) - (breakpoint-unknown-return-partner bpt) - bpt))))) + frame + ;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the + ;; hook function the original breakpoint, so that users + ;; aren't forced to confront the fact that some + ;; breakpoints really are two. + (if (eq (breakpoint-kind bpt) :unknown-return-partner) + (breakpoint-unknown-return-partner bpt) + bpt))))) (defun handle-fun-end-breakpoint (offset component context) (let ((data (breakpoint-data component offset nil))) (unless data (error "unknown breakpoint in ~S at offset ~S" - (debug-fun-name (debug-fun-from-pc component offset)) - offset)) + (debug-fun-name (debug-fun-from-pc component offset)) + offset)) (let ((breakpoints (breakpoint-data-breakpoints data))) (when breakpoints - (aver (eq (breakpoint-kind (car breakpoints)) :fun-end)) - (handle-fun-end-breakpoint-aux breakpoints data context))))) + (aver (eq (breakpoint-kind (car breakpoints)) :fun-end)) + (handle-fun-end-breakpoint-aux breakpoints data context))))) ;;; Either HANDLE-BREAKPOINT calls this for :FUN-END breakpoints ;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly @@ -3201,38 +3201,38 @@ register." (defun handle-fun-end-breakpoint-aux (breakpoints data signal-context) (delete-breakpoint-data data) (let* ((scp - (locally - (declare (optimize (inhibit-warnings 3))) - (sb!alien:sap-alien signal-context (* os-context-t)))) - (frame (do ((cfp (sb!vm:context-register scp sb!vm::cfp-offset)) - (f (top-frame) (frame-down f))) - ((= cfp (sap-int (frame-pointer f))) f) - (declare (type (unsigned-byte #.sb!vm:n-word-bits) cfp)))) - (component (breakpoint-data-component data)) - (cookie (gethash component *fun-end-cookies*))) + (locally + (declare (optimize (inhibit-warnings 3))) + (sb!alien:sap-alien signal-context (* os-context-t)))) + (frame (do ((cfp (sb!vm:context-register scp sb!vm::cfp-offset)) + (f (top-frame) (frame-down f))) + ((= cfp (sap-int (frame-pointer f))) f) + (declare (type (unsigned-byte #.sb!vm:n-word-bits) cfp)))) + (component (breakpoint-data-component data)) + (cookie (gethash component *fun-end-cookies*))) (remhash component *fun-end-cookies*) (dolist (bpt breakpoints) (funcall (breakpoint-hook-fun bpt) - frame bpt - (get-fun-end-breakpoint-values scp) - cookie)))) + frame bpt + (get-fun-end-breakpoint-values scp) + cookie)))) (defun get-fun-end-breakpoint-values (scp) (let ((ocfp (int-sap (sb!vm:context-register - scp - #!-(or x86 x86-64) sb!vm::ocfp-offset - #!+(or x86 x86-64) sb!vm::ebx-offset))) - (nargs (make-lisp-obj - (sb!vm:context-register scp sb!vm::nargs-offset))) - (reg-arg-offsets '#.sb!vm::*register-arg-offsets*) - (results nil)) + scp + #!-(or x86 x86-64) sb!vm::ocfp-offset + #!+(or x86 x86-64) sb!vm::ebx-offset))) + (nargs (make-lisp-obj + (sb!vm:context-register scp sb!vm::nargs-offset))) + (reg-arg-offsets '#.sb!vm::*register-arg-offsets*) + (results nil)) (without-gcing (dotimes (arg-num nargs) (push (if reg-arg-offsets - (make-lisp-obj - (sb!vm:context-register scp (pop reg-arg-offsets))) - (stack-ref ocfp arg-num)) - results))) + (make-lisp-obj + (sb!vm:context-register scp (pop reg-arg-offsets))) + (stack-ref ocfp arg-num)) + results))) (nreverse results))) ;;;; MAKE-BOGUS-LRA (used for :FUN-END breakpoints) @@ -3252,19 +3252,19 @@ register." ;; These are really code labels, not variables: but this way we get ;; their addresses. (let* ((src-start (foreign-symbol-sap "fun_end_breakpoint_guts")) - (src-end (foreign-symbol-sap "fun_end_breakpoint_end")) - (trap-loc (foreign-symbol-sap "fun_end_breakpoint_trap")) - (length (sap- src-end src-start)) - (code-object - (%primitive sb!c:allocate-code-object (1+ bogus-lra-constants) - length)) - (dst-start (code-instructions code-object))) + (src-end (foreign-symbol-sap "fun_end_breakpoint_end")) + (trap-loc (foreign-symbol-sap "fun_end_breakpoint_trap")) + (length (sap- src-end src-start)) + (code-object + (%primitive sb!c:allocate-code-object (1+ bogus-lra-constants) + length)) + (dst-start (code-instructions code-object))) (declare (type system-area-pointer - src-start src-end dst-start trap-loc) - (type index length)) + src-start src-end dst-start trap-loc) + (type index length)) (setf (%code-debug-info code-object) :bogus-lra) (setf (code-header-ref code-object sb!vm:code-trace-table-offset-slot) - length) + length) #!-(or x86 x86-64) (setf (code-header-ref code-object real-lra-slot) real-lra) #!+(or x86 x86-64) @@ -3272,18 +3272,18 @@ register." (setf (code-header-ref code-object real-lra-slot) code) (setf (code-header-ref code-object (1+ real-lra-slot)) offset)) (setf (code-header-ref code-object known-return-p-slot) - known-return-p) + known-return-p) (system-area-ub8-copy src-start 0 dst-start 0 length) (sb!vm:sanctify-for-execution code-object) #!+(or x86 x86-64) (values dst-start code-object (sap- trap-loc src-start)) #!-(or x86 x86-64) (let ((new-lra (make-lisp-obj (+ (sap-int dst-start) - sb!vm:other-pointer-lowtag)))) + sb!vm:other-pointer-lowtag)))) (set-header-data - new-lra - (logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1) - 1)) + new-lra + (logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1) + 1)) (sb!vm:sanctify-for-execution code-object) (values new-lra code-object (sap- trap-loc src-start)))))) @@ -3300,10 +3300,10 @@ register." (etypecase debug-fun (compiled-debug-fun (code-location-from-pc debug-fun - (sb!c::compiled-debug-fun-start-pc - (compiled-debug-fun-compiler-debug-fun - debug-fun)) - nil)) + (sb!c::compiled-debug-fun-start-pc + (compiled-debug-fun-compiler-debug-fun + debug-fun)) + nil)) ;; (There used to be more cases back before sbcl-0.7.0, when ;; we did special tricks to debug the IR1 interpreter.) )) diff --git a/src/code/debug-var-io.lisp b/src/code/debug-var-io.lisp index 087b46c..08ce07d 100644 --- a/src/code/debug-var-io.lisp +++ b/src/code/debug-var-io.lisp @@ -29,35 +29,35 @@ (defmacro read-var-integer (vec index) (once-only ((val `(aref ,vec ,index))) `(cond ((<= ,val 253) - (incf ,index) - ,val) - ((= ,val 254) - (prog1 - (logior (aref ,vec (+ ,index 1)) - (ash (aref ,vec (+ ,index 2)) 8)) - (incf ,index 3))) - (t - (prog1 - (logior (aref ,vec (+ ,index 1)) - (ash (aref ,vec (+ ,index 2)) 8) - (ash (aref ,vec (+ ,index 3)) 16) - (ash (aref ,vec (+ ,index 4)) 24)) - (incf ,index 5)))))) + (incf ,index) + ,val) + ((= ,val 254) + (prog1 + (logior (aref ,vec (+ ,index 1)) + (ash (aref ,vec (+ ,index 2)) 8)) + (incf ,index 3))) + (t + (prog1 + (logior (aref ,vec (+ ,index 1)) + (ash (aref ,vec (+ ,index 2)) 8) + (ash (aref ,vec (+ ,index 3)) 16) + (ash (aref ,vec (+ ,index 4)) 24)) + (incf ,index 5)))))) ;;; Take an adjustable vector VEC with a fill pointer and push the ;;; variable length representation of INT on the end. (defun write-var-integer (int vec) (declare (type (unsigned-byte 32) int)) (cond ((<= int 253) - (vector-push-extend int vec)) - (t - (let ((32-p (> int #xFFFF))) - (vector-push-extend (if 32-p 255 254) vec) - (vector-push-extend (ldb (byte 8 0) int) vec) - (vector-push-extend (ldb (byte 8 8) int) vec) - (when 32-p - (vector-push-extend (ldb (byte 8 16) int) vec) - (vector-push-extend (ldb (byte 8 24) int) vec))))) + (vector-push-extend int vec)) + (t + (let ((32-p (> int #xFFFF))) + (vector-push-extend (if 32-p 255 254) vec) + (vector-push-extend (ldb (byte 8 0) int) vec) + (vector-push-extend (ldb (byte 8 8) int) vec) + (when 32-p + (vector-push-extend (ldb (byte 8 16) int) vec) + (vector-push-extend (ldb (byte 8 24) int) vec))))) (values)) ;;;; packed strings @@ -70,9 +70,9 @@ (once-only ((len `(read-var-integer ,vec ,index))) (once-only ((res `(make-string ,len))) `(progn - (%byte-blt ,vec ,index ,res 0 ,len) - (incf ,index ,len) - ,res)))) + (%byte-blt ,vec ,index ,res 0 ,len) + (incf ,index ,len) + ,res)))) ;;; Write STRING into VEC (adjustable, with fill-pointer) represented ;;; as the length (in a var-length integer) followed by the codes of @@ -93,6 +93,6 @@ (once-only ((n-bytes bytes)) (once-only ((n-res `(make-array (* ,n-bytes 8) :element-type 'bit))) `(progn - (%byte-blt ,vec ,index ,n-res 0 ,n-bytes) - (incf ,index ,n-bytes) - ,n-res)))) + (%byte-blt ,vec ,index ,n-res 0 ,n-bytes) + (incf ,index ,n-bytes) + ,n-res)))) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index f7acf9a..e47ac17 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -24,7 +24,7 @@ ;;; * As condition :REPORT methods are converted to use the pretty ;;; printer, they acquire *PRINT-LEVEL* constraints, so e.g. under ;;; sbcl-0.7.1.28's old value of *DEBUG-PRINT-LEVEL*=3, an -;;; ARG-COUNT-ERROR printed as +;;; ARG-COUNT-ERROR printed as ;;; error while parsing arguments to DESTRUCTURING-BIND: ;;; invalid number of elements in ;;; # @@ -81,18 +81,18 @@ provide bindings for printer control variables.") (defun debug-prompt (stream) (sb!thread::get-foreground) (format stream - "~%~W~:[~;[~W~]] " - (sb!di:frame-number *current-frame*) - (> *debug-command-level* 1) - *debug-command-level*)) - + "~%~W~:[~;[~W~]] " + (sb!di:frame-number *current-frame*) + (> *debug-command-level* 1) + *debug-command-level*)) + (defparameter *debug-help-string* "The debug prompt is square brackets, with number(s) indicating the current control stack level and, if you've entered the debugger recursively, how deeply recursed you are. Any command -- including the name of a restart -- may be uniquely abbreviated. The debugger rebinds various special variables for controlling i/o, sometimes - to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to + to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to its own special values, based on SB-EXT:*DEBUG-PRINT-VARIABLE-ALIST*. Debug commands do not affect *, //, and similar variables, but evaluation in the debug loop does affect these variables. @@ -120,7 +120,7 @@ Inspecting frames: SOURCE [n] displays frame's source form with n levels of enclosing forms. Stepping: - STEP Selects the CONTINUE restart if one exists and starts + STEP Selects the CONTINUE restart if one exists and starts single-stepping. Single stepping affects only code compiled with under high DEBUG optimization quality. See User Manual for details. @@ -148,14 +148,14 @@ Other commands: (defun maybe-block-start-location (loc) (if (sb!di:code-location-unknown-p loc) (let* ((block (sb!di:code-location-debug-block loc)) - (start (sb!di:do-debug-block-locations (loc block) - (return loc)))) - (cond ((and (not (sb!di:debug-block-elsewhere-p block)) - start) - (format *debug-io* "~%unknown location: using block start~%") - start) - (t - loc))) + (start (sb!di:do-debug-block-locations (loc block) + (return loc)))) + (cond ((and (not (sb!di:debug-block-elsewhere-p block)) + start) + (format *debug-io* "~%unknown location: using block start~%") + start) + (t + loc))) loc)) ;;;; BACKTRACE @@ -167,7 +167,7 @@ In the debugger, the current frame is indicated by the prompt. COUNT is how many frames to show." (fresh-line stream) (do ((frame (if *in-the-debugger* *current-frame* (sb!di:top-frame)) - (sb!di:frame-down frame)) + (sb!di:frame-down frame)) (count count (1- count))) ((or (null frame) (zerop count))) (print-frame-call frame stream :number t)) @@ -178,7 +178,7 @@ is how many frames to show." #!+sb-doc "Return a list representing the current BACKTRACE." (do ((reversed-result nil) (frame (if *in-the-debugger* *current-frame* (sb!di:top-frame)) - (sb!di:frame-down frame)) + (sb!di:frame-down frame)) (count count (1- count))) ((or (null frame) (zerop count)) (nreverse reversed-result)) @@ -195,20 +195,20 @@ is how many frames to show." ;;; This is a convenient way to express what to do for each type of ;;; lambda-list element. (sb!xc:defmacro lambda-list-element-dispatch (element - &key - required - optional - rest - keyword - deleted) + &key + required + optional + rest + keyword + deleted) `(etypecase ,element (sb!di:debug-var ,@required) (cons (ecase (car ,element) - (:optional ,@optional) - (:rest ,@rest) - (:keyword ,@keyword))) + (:optional ,@optional) + (:rest ,@rest) + (:keyword ,@keyword))) (symbol (aver (eq ,element :deleted)) ,@deleted))) @@ -217,53 +217,53 @@ is how many frames to show." (let ((var (gensym))) `(let ((,var ,variable)) (cond ((eq ,var :deleted) ,deleted) - ((eq (sb!di:debug-var-validity ,var ,location) :valid) - ,valid) - (t ,other))))) + ((eq (sb!di:debug-var-validity ,var ,location) :valid) + ,valid) + (t ,other))))) ) ; EVAL-WHEN ;;; This is used in constructing arg lists for debugger printing when ;;; the arg list is unavailable, some arg is unavailable or unused, etc. (defstruct (unprintable-object - (:constructor make-unprintable-object (string)) - (:print-object (lambda (x s) - (print-unreadable-object (x s) - (write-string (unprintable-object-string x) - s)))) - (:copier nil)) + (:constructor make-unprintable-object (string)) + (:print-object (lambda (x s) + (print-unreadable-object (x s) + (write-string (unprintable-object-string x) + s)))) + (:copier nil)) string) ;;; Extract the function argument values for a debug frame. (defun frame-args-as-list (frame) (let ((debug-fun (sb!di:frame-debug-fun frame)) - (loc (sb!di:frame-code-location frame)) - (reversed-result nil)) + (loc (sb!di:frame-code-location frame)) + (reversed-result nil)) (handler-case - (progn - (dolist (ele (sb!di:debug-fun-lambda-list debug-fun)) - (lambda-list-element-dispatch ele - :required ((push (frame-call-arg ele loc frame) reversed-result)) - :optional ((push (frame-call-arg (second ele) loc frame) - reversed-result)) - :keyword ((push (second ele) reversed-result) - (push (frame-call-arg (third ele) loc frame) - reversed-result)) - :deleted ((push (frame-call-arg ele loc frame) reversed-result)) - :rest ((lambda-var-dispatch (second ele) loc - nil - (progn - (setf reversed-result - (append (reverse (sb!di:debug-var-value - (second ele) frame)) - reversed-result)) - (return)) - (push (make-unprintable-object - "unavailable &REST argument") - reversed-result))))) - ;; As long as we do an ordinary return (as opposed to SIGNALing - ;; a CONDITION) from the DOLIST above: - (nreverse reversed-result)) + (progn + (dolist (ele (sb!di:debug-fun-lambda-list debug-fun)) + (lambda-list-element-dispatch ele + :required ((push (frame-call-arg ele loc frame) reversed-result)) + :optional ((push (frame-call-arg (second ele) loc frame) + reversed-result)) + :keyword ((push (second ele) reversed-result) + (push (frame-call-arg (third ele) loc frame) + reversed-result)) + :deleted ((push (frame-call-arg ele loc frame) reversed-result)) + :rest ((lambda-var-dispatch (second ele) loc + nil + (progn + (setf reversed-result + (append (reverse (sb!di:debug-var-value + (second ele) frame)) + reversed-result)) + (return)) + (push (make-unprintable-object + "unavailable &REST argument") + reversed-result))))) + ;; As long as we do an ordinary return (as opposed to SIGNALing + ;; a CONDITION) from the DOLIST above: + (nreverse reversed-result)) (sb!di:lambda-list-unavailable () (make-unprintable-object "unavailable lambda list"))))) @@ -272,43 +272,43 @@ is how many frames to show." (defun clean-xep (name args) (values (second name) - (if (consp args) - (let ((count (first args)) - (real-args (rest args))) - (if (fixnump count) - (subseq real-args 0 - (min count (length real-args))) - real-args)) - args))) + (if (consp args) + (let ((count (first args)) + (real-args (rest args))) + (if (fixnump count) + (subseq real-args 0 + (min count (length real-args))) + real-args)) + args))) (defun clean-&more-processor (name args) (values (second name) - (if (consp args) - (let* ((more (last args 2)) - (context (first more)) - (count (second more))) - (append - (butlast args 2) - (if (fixnump count) - (multiple-value-list - (sb!c:%more-arg-values context 0 count)) - (list - (make-unprintable-object "more unavailable arguments"))))) - args))) + (if (consp args) + (let* ((more (last args 2)) + (context (first more)) + (count (second more))) + (append + (butlast args 2) + (if (fixnump count) + (multiple-value-list + (sb!c:%more-arg-values context 0 count)) + (list + (make-unprintable-object "more unavailable arguments"))))) + args))) (defun frame-call (frame) (labels ((clean-name-and-args (name args) (if (and (consp name) (not *show-entry-point-details*)) - ;; FIXME: do we need to deal with - ;; HAIRY-FUNCTION-ENTRY here? I can't make it or - ;; &AUX-BINDINGS appear in backtraces, so they are - ;; left alone for now. --NS 2005-02-28 + ;; FIXME: do we need to deal with + ;; HAIRY-FUNCTION-ENTRY here? I can't make it or + ;; &AUX-BINDINGS appear in backtraces, so they are + ;; left alone for now. --NS 2005-02-28 (case (first name) ((sb!c::xep sb!c::tl-xep) - (clean-xep name args)) + (clean-xep name args)) ((sb!c::&more-processor) - (clean-&more-processor name args)) - ((sb!c::hairy-arg-processor + (clean-&more-processor name args)) + ((sb!c::hairy-arg-processor sb!c::varargs-entry sb!c::&optional-processor) (clean-name-and-args (second name) args)) (t @@ -325,8 +325,8 @@ is how many frames to show." (defun ensure-printable-object (object) (handler-case (with-open-stream (out (make-broadcast-stream)) - (prin1 object out) - object) + (prin1 object out) + object) (error (cond) (declare (ignore cond)) (make-unprintable-object "error printing object")))) @@ -369,15 +369,15 @@ is how many frames to show." (when (>= verbosity 2) (let ((loc (sb!di:frame-code-location frame))) (handler-case - (progn + (progn ;; FIXME: Is this call really necessary here? If it is, ;; then the reason for it should be unobscured. - (sb!di:code-location-debug-block loc) - (format stream "~%source: ") - (prin1 (code-location-source-form loc 0) stream)) - (sb!di:debug-condition (ignore) + (sb!di:code-location-debug-block loc) + (format stream "~%source: ") + (prin1 (code-location-source-form loc 0) stream)) + (sb!di:debug-condition (ignore) ignore) - (error (c) + (error (c) (format stream "~&error finding source: ~A" c)))))) ;;;; INVOKE-DEBUGGER @@ -395,8 +395,8 @@ is how many frames to show." "This is either NIL or a designator for a function of two arguments, to be run when the debugger is about to be entered. The function is run with *INVOKE-DEBUGGER-HOOK* bound to NIL to minimize recursive - errors, and receives as arguments the condition that triggered - debugger entry and the previous value of *INVOKE-DEBUGGER-HOOK* + errors, and receives as arguments the condition that triggered + debugger entry and the previous value of *INVOKE-DEBUGGER-HOOK* This mechanism is an SBCL extension similar to the standard *DEBUGGER-HOOK*. In contrast to *DEBUGGER-HOOK*, it is observed by INVOKE-DEBUGGER even when @@ -415,17 +415,17 @@ is how many frames to show." (declare (type function fun)) ;; Try to force the other special variables into a useful state. (let (;; Protect from WITH-STANDARD-IO-SYNTAX some variables where - ;; any default we might use is less useful than just reusing - ;; the global values. - (original-package *package*) - (original-print-pretty *print-pretty*)) + ;; any default we might use is less useful than just reusing + ;; the global values. + (original-package *package*) + (original-print-pretty *print-pretty*)) (with-standard-io-syntax (with-sane-io-syntax (let (;; We want the printer and reader to be in a useful ;; state, regardless of where the debugger was invoked ;; in the program. WITH-STANDARD-IO-SYNTAX and ;; WITH-SANE-IO-SYNTAX do much of what we want, but - ;; * It doesn't affect our internal special variables + ;; * It doesn't affect our internal special variables ;; like *CURRENT-LEVEL-IN-PRINT*. ;; * It isn't customizable. ;; * It sets *PACKAGE* to COMMON-LISP-USER, which is not @@ -480,11 +480,11 @@ is how many frames to show." (let ((old-hook *debugger-hook*)) (when old-hook (let ((*debugger-hook* nil)) - (funcall old-hook condition old-hook)))) + (funcall old-hook condition old-hook)))) (let ((old-hook *invoke-debugger-hook*)) (when old-hook (let ((*invoke-debugger-hook* nil)) - (funcall old-hook condition old-hook)))) + (funcall old-hook condition old-hook)))) ;; Note: CMU CL had (SB-UNIX:UNIX-SIGSETMASK 0) here, to reset the ;; signal state in the case that we wind up in the debugger as a @@ -500,12 +500,12 @@ is how many frames to show." ;; this, but here causing an exception just as we're trying to handle ;; an exception would be confusing, so instead we use a special hack. (unless (and (packagep *package*) - (package-name *package*)) + (package-name *package*)) (setf *package* (find-package :cl-user)) (format *error-output* - "The value of ~S was not an undeleted PACKAGE. It has been + "The value of ~S was not an undeleted PACKAGE. It has been reset to ~S." - '*package* *package*)) + '*package* *package*)) ;; Before we start our own output, finish any pending output. ;; Otherwise, if the user tried to track the progress of his program @@ -516,43 +516,43 @@ reset to ~S." (funcall-with-debug-io-syntax #'%invoke-debugger condition)) (defun %invoke-debugger (condition) - + (let ((*debug-condition* condition) - (*debug-restarts* (compute-restarts condition)) - (*nested-debug-condition* nil)) + (*debug-restarts* (compute-restarts condition)) + (*nested-debug-condition* nil)) (handler-case - ;; (The initial output here goes to *ERROR-OUTPUT*, because the - ;; initial output is not interactive, just an error message, and - ;; when people redirect *ERROR-OUTPUT*, they could reasonably - ;; expect to see error messages logged there, regardless of what - ;; the debugger does afterwards.) - (format *error-output* - "~2&~@~%" - (type-of *debug-condition*) + (type-of *debug-condition*) #!+sb-thread sb!thread:*current-thread* #!-sb-thread nil - *debug-condition*) + *debug-condition*) (error (condition) - (setf *nested-debug-condition* condition) - (let ((ndc-type (type-of *nested-debug-condition*))) - (format *error-output* - "~&~@<(A ~S was caught when trying to print ~S when ~ + (setf *nested-debug-condition* condition) + (let ((ndc-type (type-of *nested-debug-condition*))) + (format *error-output* + "~&~@<(A ~S was caught when trying to print ~S when ~ entering the debugger. Printing was aborted and the ~ ~S was stored in ~S.)~@:>~%" - ndc-type - '*debug-condition* - ndc-type - '*nested-debug-condition*)) - (when (typep condition 'cell-error) - ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE: - (format *error-output* - "~&(CELL-ERROR-NAME ~S) = ~S~%" - '*debug-condition* - (cell-error-name *debug-condition*))))) + ndc-type + '*debug-condition* + ndc-type + '*nested-debug-condition*)) + (when (typep condition 'cell-error) + ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE: + (format *error-output* + "~&(CELL-ERROR-NAME ~S) = ~S~%" + '*debug-condition* + (cell-error-name *debug-condition*))))) (let ((background-p (sb!thread::debugger-wait-until-foreground-thread - *debug-io*))) + *debug-io*))) ;; After the initial error/condition/whatever announcement to ;; *ERROR-OUTPUT*, we become interactive, and should talk on @@ -563,27 +563,27 @@ reset to ~S." ;; been converted to behave this way. -- WHN 2000-11-16) (unwind-protect - (let (;; We used to bind *STANDARD-OUTPUT* to *DEBUG-IO* - ;; here as well, but that is probably bogus since it + (let (;; We used to bind *STANDARD-OUTPUT* to *DEBUG-IO* + ;; here as well, but that is probably bogus since it ;; removes the users ability to do output to a redirected ;; *S-O*. Now we just rebind it so that users can temporarily ;; frob it. FIXME: This and other "what gets bound when" ;; behaviour should be documented in the manual. (*standard-output* *standard-output*) ;; This seems reasonable: e.g. if the user has redirected - ;; *ERROR-OUTPUT* to some log file, it's probably wrong - ;; to send errors which occur in interactive debugging to - ;; that file, and right to send them to *DEBUG-IO*. - (*error-output* *debug-io*)) - (unless (typep condition 'step-condition) - (when *debug-beginner-help-p* - (format *debug-io* - "~%~@~2%")) - (show-restarts *debug-restarts* *debug-io*)) - (internal-debug)) - (when background-p - (sb!thread::release-foreground)))))) + (show-restarts *debug-restarts* *debug-io*)) + (internal-debug)) + (when background-p + (sb!thread::release-foreground)))))) ;;; this function is for use in *INVOKE-DEBUGGER-HOOK* when ordinary ;;; ANSI behavior has been suppressed by the "--disable-debugger" @@ -594,7 +594,7 @@ reset to ~S." ;; condition and terminate the program. (flet ((failure-quit (&key recklessly-p) (/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)") - (quit :unix-status 1 :recklessly-p recklessly-p))) + (quit :unix-status 1 :recklessly-p recklessly-p))) ;; This HANDLER-CASE is here mostly to stop output immediately ;; (and fall through to QUIT) when there's an I/O error. Thus, ;; when we're run under a shell script or something, we can die @@ -603,55 +603,55 @@ reset to ~S." ;; can terminate cleanly even if BACKTRACE dies because of bugs in ;; user PRINT-OBJECT methods. (handler-case - (progn - (format *error-output* - "~&~@~2%" - (type-of condition) + (progn + (format *error-output* + "~&~@~2%" + (type-of condition) #!+sb-thread sb!thread:*current-thread* #!-sb-thread nil - condition) - ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that - ;; even if we hit an error within BACKTRACE (e.g. a bug in - ;; the debugger's own frame-walking code, or a bug in a user - ;; PRINT-OBJECT method) we'll at least have the CONDITION - ;; printed out before we die. - (finish-output *error-output*) - ;; (Where to truncate the BACKTRACE is of course arbitrary, but - ;; it seems as though we should at least truncate it somewhere.) - (sb!debug:backtrace 128 *error-output*) - (format - *error-output* - "~%unhandled condition in --disable-debugger mode, quitting~%") - (finish-output *error-output*) - (failure-quit)) + condition) + ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that + ;; even if we hit an error within BACKTRACE (e.g. a bug in + ;; the debugger's own frame-walking code, or a bug in a user + ;; PRINT-OBJECT method) we'll at least have the CONDITION + ;; printed out before we die. + (finish-output *error-output*) + ;; (Where to truncate the BACKTRACE is of course arbitrary, but + ;; it seems as though we should at least truncate it somewhere.) + (sb!debug:backtrace 128 *error-output*) + (format + *error-output* + "~%unhandled condition in --disable-debugger mode, quitting~%") + (finish-output *error-output*) + (failure-quit)) (condition () - ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can - ;; fail when our output streams are blown away, as e.g. when - ;; we're running under a Unix shell script and it dies somehow - ;; (e.g. because of a SIGINT). In that case, we might as well - ;; just give it up for a bad job, and stop trying to notify - ;; the user of anything. + ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can + ;; fail when our output streams are blown away, as e.g. when + ;; we're running under a Unix shell script and it dies somehow + ;; (e.g. because of a SIGINT). In that case, we might as well + ;; just give it up for a bad job, and stop trying to notify + ;; the user of anything. ;; ;; Actually, the only way I've run across to exercise the - ;; problem is to have more than one layer of shell script. - ;; I have a shell script which does - ;; time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp - ;; and the problem occurs when I interrupt this with Ctrl-C - ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1). + ;; problem is to have more than one layer of shell script. + ;; I have a shell script which does + ;; time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp + ;; and the problem occurs when I interrupt this with Ctrl-C + ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1). ;; I haven't figured out whether it's bash, time, tee, Linux, or - ;; what that is responsible, but that it's possible at all - ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24 + ;; what that is responsible, but that it's possible at all + ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24 (ignore-errors (%primitive print - "Argh! error within --disable-debugger error handling")) - (failure-quit :recklessly-p t))))) + "Argh! error within --disable-debugger error handling")) + (failure-quit :recklessly-p t))))) ;;; halt-on-failures and prompt-on-failures modes, suitable for ;;; noninteractive and interactive use respectively (defun disable-debugger () (when (eql *invoke-debugger-hook* nil) (setf *debug-io* *error-output* - *invoke-debugger-hook* 'debugger-disabled-hook))) + *invoke-debugger-hook* 'debugger-disabled-hook))) (defun enable-debugger () (when (eql *invoke-debugger-hook* 'debugger-disabled-hook) @@ -662,36 +662,36 @@ reset to ~S." (defun show-restarts (restarts s) (cond ((null restarts) - (format s - "~&(no restarts: If you didn't do this on purpose, ~ + (format s + "~&(no restarts: If you didn't do this on purpose, ~ please report it as a bug.)~%")) - (t - (format s "~&restarts (invokable by number or by ~ + (t + (format s "~&restarts (invokable by number or by ~ possibly-abbreviated name):~%") - (let ((count 0) - (names-used '(nil)) - (max-name-len 0)) - (dolist (restart restarts) - (let ((name (restart-name restart))) - (when name - (let ((len (length (princ-to-string name)))) - (when (> len max-name-len) - (setf max-name-len len)))))) - (unless (zerop max-name-len) - (incf max-name-len 3)) - (dolist (restart restarts) - (let ((name (restart-name restart))) - ;; FIXME: maybe it would be better to display later names - ;; in parens instead of brakets, not just omit them fully. - ;; Call BREAK, call BREAK in the debugger, and tell me - ;; it's not confusing looking. --NS 20050310 - (cond ((member name names-used) - (format s "~& ~2D: ~V@T~A~%" count max-name-len restart)) - (t - (format s "~& ~2D: [~VA] ~A~%" - count (- max-name-len 3) name restart) - (push name names-used)))) - (incf count)))))) + (let ((count 0) + (names-used '(nil)) + (max-name-len 0)) + (dolist (restart restarts) + (let ((name (restart-name restart))) + (when name + (let ((len (length (princ-to-string name)))) + (when (> len max-name-len) + (setf max-name-len len)))))) + (unless (zerop max-name-len) + (incf max-name-len 3)) + (dolist (restart restarts) + (let ((name (restart-name restart))) + ;; FIXME: maybe it would be better to display later names + ;; in parens instead of brakets, not just omit them fully. + ;; Call BREAK, call BREAK in the debugger, and tell me + ;; it's not confusing looking. --NS 20050310 + (cond ((member name names-used) + (format s "~& ~2D: ~V@T~A~%" count max-name-len restart)) + (t + (format s "~& ~2D: [~VA] ~A~%" + count (- max-name-len 3) name restart) + (push name names-used)))) + (incf count)))))) (defvar *debug-loop-fun* #'debug-loop-fun "a function taking no parameters that starts the low-level debug loop") @@ -704,7 +704,7 @@ reset to ~S." ;;; errors. (defun internal-debug () (let ((*in-the-debugger* t) - (*read-suppress* nil)) + (*read-suppress* nil)) (unless (typep *debug-condition* 'step-condition) (clear-input *debug-io*)) (funcall *debug-loop-fun*))) @@ -720,50 +720,50 @@ reset to ~S." (defun debug-loop-fun () (let* ((*debug-command-level* (1+ *debug-command-level*)) - (*real-stack-top* (sb!di:top-frame)) - (*stack-top* (or *stack-top-hint* *real-stack-top*)) - (*stack-top-hint* nil) - (*current-frame* *stack-top*)) + (*real-stack-top* (sb!di:top-frame)) + (*stack-top* (or *stack-top-hint* *real-stack-top*)) + (*stack-top-hint* nil) + (*current-frame* *stack-top*)) (handler-bind ((sb!di:debug-condition - (lambda (condition) - (princ condition *debug-io*) - (/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER") - (throw 'debug-loop-catcher nil)))) + (lambda (condition) + (princ condition *debug-io*) + (/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER") + (throw 'debug-loop-catcher nil)))) (terpri *debug-io*) (print-frame-call *current-frame* *debug-io* :verbosity 2) (loop - (catch 'debug-loop-catcher - (handler-bind ((error (lambda (condition) - (when *flush-debug-errors* - (clear-input *debug-io*) - (princ condition *debug-io*) - (format *debug-io* - "~&error flushed (because ~ + (catch 'debug-loop-catcher + (handler-bind ((error (lambda (condition) + (when *flush-debug-errors* + (clear-input *debug-io*) + (princ condition *debug-io*) + (format *debug-io* + "~&error flushed (because ~ ~S is set)" - '*flush-debug-errors*) - (/show0 "throwing DEBUG-LOOP-CATCHER") - (throw 'debug-loop-catcher nil))))) - ;; We have to bind LEVEL for the restart function created by - ;; WITH-SIMPLE-RESTART. - (let ((level *debug-command-level*) - (restart-commands (make-restart-commands))) - (with-simple-restart (abort - "~@" - level) - (debug-prompt *debug-io*) - (force-output *debug-io*) - (let* ((exp (read *debug-io*)) - (cmd-fun (debug-command-p exp restart-commands))) - (cond ((not cmd-fun) - (debug-eval-print exp)) - ((consp cmd-fun) - (format *debug-io* + '*flush-debug-errors*) + (/show0 "throwing DEBUG-LOOP-CATCHER") + (throw 'debug-loop-catcher nil))))) + ;; We have to bind LEVEL for the restart function created by + ;; WITH-SIMPLE-RESTART. + (let ((level *debug-command-level*) + (restart-commands (make-restart-commands))) + (with-simple-restart (abort + "~@" + level) + (debug-prompt *debug-io*) + (force-output *debug-io*) + (let* ((exp (read *debug-io*)) + (cmd-fun (debug-command-p exp restart-commands))) + (cond ((not cmd-fun) + (debug-eval-print exp)) + ((consp cmd-fun) + (format *debug-io* "~&Your command, ~S, is ambiguous:~%" - exp) - (dolist (ele cmd-fun) - (format *debug-io* " ~A~%" ele))) - (t - (funcall cmd-fun)))))))))))) + exp) + (dolist (ele cmd-fun) + (format *debug-io* " ~A~%" ele))) + (t + (funcall cmd-fun)))))))))))) (defun debug-eval-print (expr) (/noshow "entering DEBUG-EVAL-PRINT" expr) @@ -783,85 +783,85 @@ reset to ~S." (sb!xc:defmacro define-var-operation (ref-or-set &optional value-var) `(let* ((temp (etypecase name - (symbol (sb!di:debug-fun-symbol-vars - (sb!di:frame-debug-fun *current-frame*) - name)) - (simple-string (sb!di:ambiguous-debug-vars - (sb!di:frame-debug-fun *current-frame*) - name)))) - (location (sb!di:frame-code-location *current-frame*)) - ;; Let's only deal with valid variables. - (vars (remove-if-not (lambda (v) - (eq (sb!di:debug-var-validity v location) - :valid)) - temp))) + (symbol (sb!di:debug-fun-symbol-vars + (sb!di:frame-debug-fun *current-frame*) + name)) + (simple-string (sb!di:ambiguous-debug-vars + (sb!di:frame-debug-fun *current-frame*) + name)))) + (location (sb!di:frame-code-location *current-frame*)) + ;; Let's only deal with valid variables. + (vars (remove-if-not (lambda (v) + (eq (sb!di:debug-var-validity v location) + :valid)) + temp))) (declare (list vars)) (cond ((null vars) - (error "No known valid variables match ~S." name)) - ((= (length vars) 1) - ,(ecase ref-or-set - (:ref - '(sb!di:debug-var-value (car vars) *current-frame*)) - (:set - `(setf (sb!di:debug-var-value (car vars) *current-frame*) - ,value-var)))) - (t - ;; Since we have more than one, first see whether we have - ;; any variables that exactly match the specification. - (let* ((name (etypecase name - (symbol (symbol-name name)) - (simple-string name))) - ;; FIXME: REMOVE-IF-NOT is deprecated, use STRING/= - ;; instead. - (exact (remove-if-not (lambda (v) - (string= (sb!di:debug-var-symbol-name v) - name)) - vars)) - (vars (or exact vars))) - (declare (simple-string name) - (list exact vars)) - (cond - ;; Check now for only having one variable. - ((= (length vars) 1) - ,(ecase ref-or-set - (:ref - '(sb!di:debug-var-value (car vars) *current-frame*)) - (:set - `(setf (sb!di:debug-var-value (car vars) *current-frame*) - ,value-var)))) - ;; If there weren't any exact matches, flame about - ;; ambiguity unless all the variables have the same - ;; name. - ((and (not exact) - (find-if-not - (lambda (v) - (string= (sb!di:debug-var-symbol-name v) - (sb!di:debug-var-symbol-name (car vars)))) - (cdr vars))) - (error "specification ambiguous:~%~{ ~A~%~}" - (mapcar #'sb!di:debug-var-symbol-name - (delete-duplicates - vars :test #'string= - :key #'sb!di:debug-var-symbol-name)))) - ;; All names are the same, so see whether the user - ;; ID'ed one of them. - (id-supplied - (let ((v (find id vars :key #'sb!di:debug-var-id))) - (unless v - (error - "invalid variable ID, ~W: should have been one of ~S" - id - (mapcar #'sb!di:debug-var-id vars))) - ,(ecase ref-or-set - (:ref - '(sb!di:debug-var-value v *current-frame*)) - (:set - `(setf (sb!di:debug-var-value v *current-frame*) - ,value-var))))) - (t - (error "Specify variable ID to disambiguate ~S. Use one of ~S." - name - (mapcar #'sb!di:debug-var-id vars))))))))) + (error "No known valid variables match ~S." name)) + ((= (length vars) 1) + ,(ecase ref-or-set + (:ref + '(sb!di:debug-var-value (car vars) *current-frame*)) + (:set + `(setf (sb!di:debug-var-value (car vars) *current-frame*) + ,value-var)))) + (t + ;; Since we have more than one, first see whether we have + ;; any variables that exactly match the specification. + (let* ((name (etypecase name + (symbol (symbol-name name)) + (simple-string name))) + ;; FIXME: REMOVE-IF-NOT is deprecated, use STRING/= + ;; instead. + (exact (remove-if-not (lambda (v) + (string= (sb!di:debug-var-symbol-name v) + name)) + vars)) + (vars (or exact vars))) + (declare (simple-string name) + (list exact vars)) + (cond + ;; Check now for only having one variable. + ((= (length vars) 1) + ,(ecase ref-or-set + (:ref + '(sb!di:debug-var-value (car vars) *current-frame*)) + (:set + `(setf (sb!di:debug-var-value (car vars) *current-frame*) + ,value-var)))) + ;; If there weren't any exact matches, flame about + ;; ambiguity unless all the variables have the same + ;; name. + ((and (not exact) + (find-if-not + (lambda (v) + (string= (sb!di:debug-var-symbol-name v) + (sb!di:debug-var-symbol-name (car vars)))) + (cdr vars))) + (error "specification ambiguous:~%~{ ~A~%~}" + (mapcar #'sb!di:debug-var-symbol-name + (delete-duplicates + vars :test #'string= + :key #'sb!di:debug-var-symbol-name)))) + ;; All names are the same, so see whether the user + ;; ID'ed one of them. + (id-supplied + (let ((v (find id vars :key #'sb!di:debug-var-id))) + (unless v + (error + "invalid variable ID, ~W: should have been one of ~S" + id + (mapcar #'sb!di:debug-var-id vars))) + ,(ecase ref-or-set + (:ref + '(sb!di:debug-var-value v *current-frame*)) + (:set + `(setf (sb!di:debug-var-value v *current-frame*) + ,value-var))))) + (t + (error "Specify variable ID to disambiguate ~S. Use one of ~S." + name + (mapcar #'sb!di:debug-var-id vars))))))))) ) ; EVAL-WHEN @@ -901,28 +901,28 @@ reset to ~S." (defun nth-arg (count args) (let ((n count)) (dolist (ele args (error "The argument specification ~S is out of range." - n)) + n)) (lambda-list-element-dispatch ele - :required ((if (zerop n) (return (values ele t)))) - :optional ((if (zerop n) (return (values (second ele) t)))) - :keyword ((cond ((zerop n) - (return (values (second ele) nil))) - ((zerop (decf n)) - (return (values (third ele) t))))) - :deleted ((if (zerop n) (return (values ele t)))) - :rest ((let ((var (second ele))) - (lambda-var-dispatch var (sb!di:frame-code-location - *current-frame*) - (error "unused &REST argument before n'th argument") - (dolist (value - (sb!di:debug-var-value var *current-frame*) - (error - "The argument specification ~S is out of range." - n)) - (if (zerop n) - (return-from nth-arg (values value nil)) - (decf n))) - (error "invalid &REST argument before n'th argument"))))) + :required ((if (zerop n) (return (values ele t)))) + :optional ((if (zerop n) (return (values (second ele) t)))) + :keyword ((cond ((zerop n) + (return (values (second ele) nil))) + ((zerop (decf n)) + (return (values (third ele) t))))) + :deleted ((if (zerop n) (return (values ele t)))) + :rest ((let ((var (second ele))) + (lambda-var-dispatch var (sb!di:frame-code-location + *current-frame*) + (error "unused &REST argument before n'th argument") + (dolist (value + (sb!di:debug-var-value var *current-frame*) + (error + "The argument specification ~S is out of range." + n)) + (if (zerop n) + (return-from nth-arg (values value nil)) + (decf n))) + (error "invalid &REST argument before n'th argument"))))) (decf n)))) (defun arg (n) @@ -932,15 +932,15 @@ reset to ~S." pairs as separate arguments." (multiple-value-bind (var lambda-var-p) (nth-arg n (handler-case (sb!di:debug-fun-lambda-list - (sb!di:frame-debug-fun *current-frame*)) - (sb!di:lambda-list-unavailable () - (error "No argument values are available.")))) + (sb!di:frame-debug-fun *current-frame*)) + (sb!di:lambda-list-unavailable () + (error "No argument values are available.")))) (if lambda-var-p - (lambda-var-dispatch var (sb!di:frame-code-location *current-frame*) - (error "Unused arguments have no values.") - (sb!di:debug-var-value var *current-frame*) - (error "invalid argument value")) - var))) + (lambda-var-dispatch var (sb!di:frame-code-location *current-frame*) + (error "Unused arguments have no values.") + (sb!di:debug-var-value var *current-frame*) + (error "invalid argument value")) + var))) ;;;; machinery for definition of debug loop commands @@ -952,11 +952,11 @@ reset to ~S." (let ((fun-name (symbolicate name "-DEBUG-COMMAND"))) `(progn (setf *debug-commands* - (remove ,name *debug-commands* :key #'car :test #'string=)) + (remove ,name *debug-commands* :key #'car :test #'string=)) (defun ,fun-name ,args - (unless *in-the-debugger* - (error "invoking debugger command while outside the debugger")) - ,@body) + (unless *in-the-debugger* + (error "invoking debugger command while outside the debugger")) + ,@body) (push (cons ,name #',fun-name) *debug-commands*) ',fun-name))) @@ -976,38 +976,38 @@ reset to ~S." (defun debug-command-p (form &optional other-commands) (if (or (symbolp form) (integerp form)) (let* ((name - (if (symbolp form) - (symbol-name form) - (format nil "~W" form))) - (len (length name)) - (res nil)) - (declare (simple-string name) - (fixnum len) - (list res)) - - ;; Find matching commands, punting if exact match. - (flet ((match-command (ele) - (let* ((str (car ele)) - (str-len (length str))) - (declare (simple-string str) - (fixnum str-len)) - (cond ((< str-len len)) - ((= str-len len) - (when (string= name str :end1 len :end2 len) - (return-from debug-command-p (cdr ele)))) - ((string= name str :end1 len :end2 len) - (push ele res)))))) - (mapc #'match-command *debug-commands*) - (mapc #'match-command other-commands)) - - ;; Return the right value. - (cond ((not res) nil) - ((= (length res) 1) - (cdar res)) - (t ; Just return the names. - (do ((cmds res (cdr cmds))) - ((not cmds) res) - (setf (car cmds) (caar cmds)))))))) + (if (symbolp form) + (symbol-name form) + (format nil "~W" form))) + (len (length name)) + (res nil)) + (declare (simple-string name) + (fixnum len) + (list res)) + + ;; Find matching commands, punting if exact match. + (flet ((match-command (ele) + (let* ((str (car ele)) + (str-len (length str))) + (declare (simple-string str) + (fixnum str-len)) + (cond ((< str-len len)) + ((= str-len len) + (when (string= name str :end1 len :end2 len) + (return-from debug-command-p (cdr ele)))) + ((string= name str :end1 len :end2 len) + (push ele res)))))) + (mapc #'match-command *debug-commands*) + (mapc #'match-command other-commands)) + + ;; Return the right value. + (cond ((not res) nil) + ((= (length res) 1) + (cdar res)) + (t ; Just return the names. + (do ((cmds res (cdr cmds))) + ((not cmds) res) + (setf (car cmds) (caar cmds)))))))) ;;; Return a list of debug commands (in the same format as ;;; *DEBUG-COMMANDS*) that invoke each active restart. @@ -1017,15 +1017,15 @@ reset to ~S." ;;; restart of the same name, or it is NIL). (defun make-restart-commands (&optional (restarts *debug-restarts*)) (let ((commands) - (num 0)) ; better be the same as show-restarts! + (num 0)) ; better be the same as show-restarts! (dolist (restart restarts) (let ((name (string (restart-name restart)))) (let ((restart-fun (lambda () - (/show0 "in restart-command closure, about to i-r-i") - (invoke-restart-interactively restart)))) + (/show0 "in restart-command closure, about to i-r-i") + (invoke-restart-interactively restart)))) (push (cons (prin1-to-string num) restart-fun) commands) - (unless (or (null (restart-name restart)) + (unless (or (null (restart-name restart)) (find name commands :key #'car :test #'string=)) (push (cons name restart-fun) commands)))) (incf num)) @@ -1036,18 +1036,18 @@ reset to ~S." (!def-debug-command "UP" () (let ((next (sb!di:frame-up *current-frame*))) (cond (next - (setf *current-frame* next) - (print-frame-call next *debug-io*)) - (t - (format *debug-io* "~&Top of stack."))))) + (setf *current-frame* next) + (print-frame-call next *debug-io*)) + (t + (format *debug-io* "~&Top of stack."))))) (!def-debug-command "DOWN" () (let ((next (sb!di:frame-down *current-frame*))) (cond (next - (setf *current-frame* next) - (print-frame-call next *debug-io*)) - (t - (format *debug-io* "~&Bottom of stack."))))) + (setf *current-frame* next) + (print-frame-call next *debug-io*)) + (t + (format *debug-io* "~&Bottom of stack."))))) (!def-debug-command-alias "D" "DOWN") @@ -1061,23 +1061,23 @@ reset to ~S." (!def-debug-command-alias "B" "BOTTOM") (!def-debug-command "FRAME" (&optional - (n (read-prompting-maybe "frame number: "))) + (n (read-prompting-maybe "frame number: "))) (setf *current-frame* - (multiple-value-bind (next-frame-fun limit-string) - (if (< n (sb!di:frame-number *current-frame*)) - (values #'sb!di:frame-up "top") - (values #'sb!di:frame-down "bottom")) - (do ((frame *current-frame*)) - ((= n (sb!di:frame-number frame)) - frame) - (let ((next-frame (funcall next-frame-fun frame))) - (cond (next-frame - (setf frame next-frame)) - (t - (format *debug-io* - "The ~A of the stack was encountered.~%" - limit-string) - (return frame))))))) + (multiple-value-bind (next-frame-fun limit-string) + (if (< n (sb!di:frame-number *current-frame*)) + (values #'sb!di:frame-up "top") + (values #'sb!di:frame-down "bottom")) + (do ((frame *current-frame*)) + ((= n (sb!di:frame-number frame)) + frame) + (let ((next-frame (funcall next-frame-fun frame))) + (cond (next-frame + (setf frame next-frame)) + (t + (format *debug-io* + "The ~A of the stack was encountered.~%" + limit-string) + (return frame))))))) (print-frame-call *current-frame* *debug-io*)) (!def-debug-command-alias "F" "FRAME") @@ -1099,21 +1099,21 @@ reset to ~S." (force-output) (setf num (read *debug-io*))) (let ((restart (typecase num - (unsigned-byte - (nth num *debug-restarts*)) - (symbol - (find num *debug-restarts* :key #'restart-name - :test (lambda (sym1 sym2) - (string= (symbol-name sym1) - (symbol-name sym2))))) - (t - (format *debug-io* "~S is invalid as a restart name.~%" + (unsigned-byte + (nth num *debug-restarts*)) + (symbol + (find num *debug-restarts* :key #'restart-name + :test (lambda (sym1 sym2) + (string= (symbol-name sym1) + (symbol-name sym2))))) + (t + (format *debug-io* "~S is invalid as a restart name.~%" num) - (return-from restart-debug-command nil))))) + (return-from restart-debug-command nil))))) (/show0 "got RESTART") (if restart - (invoke-restart-interactively restart) - (princ "There is no such restart." *debug-io*))))) + (invoke-restart-interactively restart) + (princ "There is no such restart." *debug-io*))))) ;;;; information commands @@ -1124,9 +1124,9 @@ reset to ~S." ;; desperate holdout is running this on a dumb terminal somewhere, ;; we tell him where to find the message stored as a string. (format *debug-io* - "~&~A~2%(The HELP string is stored in ~S.)~%" - *debug-help-string* - '*debug-help-string*)) + "~&~A~2%(The HELP string is stored in ~S.)~%" + *debug-help-string* + '*debug-help-string*)) (!def-debug-command-alias "?" "HELP") @@ -1145,35 +1145,35 @@ reset to ~S." (!def-debug-command "LIST-LOCALS" () (let ((d-fun (sb!di:frame-debug-fun *current-frame*))) (if (sb!di:debug-var-info-available d-fun) - (let ((*standard-output* *debug-io*) - (location (sb!di:frame-code-location *current-frame*)) - (prefix (read-if-available nil)) - (any-p nil) - (any-valid-p nil)) - (dolist (v (sb!di:ambiguous-debug-vars - d-fun - (if prefix (string prefix) ""))) - (setf any-p t) - (when (eq (sb!di:debug-var-validity v location) :valid) - (setf any-valid-p t) - (format *debug-io* "~S~:[#~W~;~*~] = ~S~%" - (sb!di:debug-var-symbol v) - (zerop (sb!di:debug-var-id v)) - (sb!di:debug-var-id v) - (sb!di:debug-var-value v *current-frame*)))) - - (cond - ((not any-p) - (format *debug-io* + (let ((*standard-output* *debug-io*) + (location (sb!di:frame-code-location *current-frame*)) + (prefix (read-if-available nil)) + (any-p nil) + (any-valid-p nil)) + (dolist (v (sb!di:ambiguous-debug-vars + d-fun + (if prefix (string prefix) ""))) + (setf any-p t) + (when (eq (sb!di:debug-var-validity v location) :valid) + (setf any-valid-p t) + (format *debug-io* "~S~:[#~W~;~*~] = ~S~%" + (sb!di:debug-var-symbol v) + (zerop (sb!di:debug-var-id v)) + (sb!di:debug-var-id v) + (sb!di:debug-var-value v *current-frame*)))) + + (cond + ((not any-p) + (format *debug-io* "There are no local variables ~@[starting with ~A ~]~ in the function." - prefix)) - ((not any-valid-p) - (format *debug-io* + prefix)) + ((not any-valid-p) + (format *debug-io* "All variables ~@[starting with ~A ~]currently ~ have invalid values." - prefix)))) - (write-line "There is no variable information available." + prefix)))) + (write-line "There is no variable information available." *debug-io*)))) (!def-debug-command-alias "L" "LIST-LOCALS") @@ -1208,8 +1208,8 @@ reset to ~S." ;;; Stuff to clean up before saving a core (defun debug-deinit () (setf *cached-debug-source* nil - *cached-source-stream* nil - *cached-readtable* nil)) + *cached-source-stream* nil + *cached-readtable* nil)) ;;; We also cache the last toplevel form that we printed a source for ;;; so that we don't have to do repeated reads and calls to @@ -1225,47 +1225,47 @@ reset to ~S." (defun get-toplevel-form (location) (let ((d-source (sb!di:code-location-debug-source location))) (if (and (eq d-source *cached-debug-source*) - (eql (sb!di:code-location-toplevel-form-offset location) - *cached-toplevel-form-offset*)) - (values *cached-form-number-translations* *cached-toplevel-form*) - (let* ((offset (sb!di:code-location-toplevel-form-offset location)) - (res - (ecase (sb!di:debug-source-from d-source) - (:file (get-file-toplevel-form location)) - (:lisp (svref (sb!di:debug-source-name d-source) offset))))) - (setq *cached-toplevel-form-offset* offset) - (values (setq *cached-form-number-translations* - (sb!di:form-number-translations res offset)) - (setq *cached-toplevel-form* res)))))) + (eql (sb!di:code-location-toplevel-form-offset location) + *cached-toplevel-form-offset*)) + (values *cached-form-number-translations* *cached-toplevel-form*) + (let* ((offset (sb!di:code-location-toplevel-form-offset location)) + (res + (ecase (sb!di:debug-source-from d-source) + (:file (get-file-toplevel-form location)) + (:lisp (svref (sb!di:debug-source-name d-source) offset))))) + (setq *cached-toplevel-form-offset* offset) + (values (setq *cached-form-number-translations* + (sb!di:form-number-translations res offset)) + (setq *cached-toplevel-form* res)))))) ;;; Locate the source file (if it still exists) and grab the top level ;;; form. If the file is modified, we use the top level form offset ;;; instead of the recorded character offset. (defun get-file-toplevel-form (location) (let* ((d-source (sb!di:code-location-debug-source location)) - (tlf-offset (sb!di:code-location-toplevel-form-offset location)) - (local-tlf-offset (- tlf-offset - (sb!di:debug-source-root-number d-source))) - (char-offset - (aref (or (sb!di:debug-source-start-positions d-source) - (error "no start positions map")) - local-tlf-offset)) - (name (sb!di:debug-source-name d-source))) + (tlf-offset (sb!di:code-location-toplevel-form-offset location)) + (local-tlf-offset (- tlf-offset + (sb!di:debug-source-root-number d-source))) + (char-offset + (aref (or (sb!di:debug-source-start-positions d-source) + (error "no start positions map")) + local-tlf-offset)) + (name (sb!di:debug-source-name d-source))) (unless (eq d-source *cached-debug-source*) (unless (and *cached-source-stream* - (equal (pathname *cached-source-stream*) - (pathname name))) - (setq *cached-readtable* nil) - (when *cached-source-stream* (close *cached-source-stream*)) - (setq *cached-source-stream* (open name :if-does-not-exist nil)) - (unless *cached-source-stream* - (error "The source file no longer exists:~% ~A" (namestring name))) - (format *debug-io* "~%; file: ~A~%" (namestring name))) - - (setq *cached-debug-source* - (if (= (sb!di:debug-source-created d-source) - (file-write-date name)) - d-source nil))) + (equal (pathname *cached-source-stream*) + (pathname name))) + (setq *cached-readtable* nil) + (when *cached-source-stream* (close *cached-source-stream*)) + (setq *cached-source-stream* (open name :if-does-not-exist nil)) + (unless *cached-source-stream* + (error "The source file no longer exists:~% ~A" (namestring name))) + (format *debug-io* "~%; file: ~A~%" (namestring name))) + + (setq *cached-debug-source* + (if (= (sb!di:debug-source-created d-source) + (file-write-date name)) + d-source nil))) (cond ((eq *cached-debug-source* d-source) @@ -1274,29 +1274,29 @@ reset to ~S." (format *debug-io* "~%; File has been modified since compilation:~%; ~A~@ ; Using form offset instead of character position.~%" - (namestring name)) + (namestring name)) (file-position *cached-source-stream* 0) (let ((*read-suppress* t)) - (dotimes (i local-tlf-offset) - (read *cached-source-stream*))))) + (dotimes (i local-tlf-offset) + (read *cached-source-stream*))))) (unless *cached-readtable* (setq *cached-readtable* (copy-readtable)) (set-dispatch-macro-character #\# #\. (lambda (stream sub-char &rest rest) - (declare (ignore rest sub-char)) - (let ((token (read stream t nil t))) - (format nil "#.~S" token))) + (declare (ignore rest sub-char)) + (let ((token (read stream t nil t))) + (format nil "#.~S" token))) *cached-readtable*)) (let ((*readtable* *cached-readtable*)) (read *cached-source-stream*)))) (defun code-location-source-form (location context) (let* ((location (maybe-block-start-location location)) - (form-num (sb!di:code-location-form-number location))) + (form-num (sb!di:code-location-form-number location))) (multiple-value-bind (translations form) (get-toplevel-form location) (unless (< form-num (length translations)) - (error "The source path no longer exists.")) + (error "The source path no longer exists.")) (sb!di:source-path-context form (svref translations form-num) context)))) @@ -1305,40 +1305,40 @@ reset to ~S." (!def-debug-command "STEP" () (let ((restart (find-restart 'continue *debug-condition*))) (cond (restart - (setf *stepping* t - *step* t) - (invoke-restart restart)) - (t - (format *debug-io* "~&Non-continuable error, cannot step.~%"))))) + (setf *stepping* t + *step* t) + (invoke-restart restart)) + (t + (format *debug-io* "~&Non-continuable error, cannot step.~%"))))) ;;; miscellaneous commands (!def-debug-command "DESCRIBE" () (let* ((curloc (sb!di:frame-code-location *current-frame*)) - (debug-fun (sb!di:code-location-debug-fun curloc)) - (function (sb!di:debug-fun-fun debug-fun))) + (debug-fun (sb!di:code-location-debug-fun curloc)) + (function (sb!di:debug-fun-fun debug-fun))) (if function - (describe function) - (format *debug-io* "can't figure out the function for this frame")))) + (describe function) + (format *debug-io* "can't figure out the function for this frame")))) (!def-debug-command "SLURP" () (loop while (read-char-no-hang *standard-input*))) (!def-debug-command "RETURN" (&optional - (return (read-prompting-maybe - "return: "))) + (return (read-prompting-maybe + "return: "))) (let ((tag (find-if (lambda (x) - (and (typep (car x) 'symbol) - (not (symbol-package (car x))) - (string= (car x) "SB-DEBUG-CATCH-TAG"))) - (sb!di::frame-catches *current-frame*)))) + (and (typep (car x) 'symbol) + (not (symbol-package (car x))) + (string= (car x) "SB-DEBUG-CATCH-TAG"))) + (sb!di::frame-catches *current-frame*)))) (if tag - (throw (car tag) - (funcall (sb!di:preprocess-for-eval - return - (sb!di:frame-code-location *current-frame*)) - *current-frame*)) - (format *debug-io* + (throw (car tag) + (funcall (sb!di:preprocess-for-eval + return + (sb!di:frame-code-location *current-frame*)) + *current-frame*)) + (format *debug-io* "~@")))) diff --git a/src/code/defbangconstant.lisp b/src/code/defbangconstant.lisp index fefa23a..9c5d0e7 100644 --- a/src/code/defbangconstant.lisp +++ b/src/code/defbangconstant.lisp @@ -29,12 +29,12 @@ (defconstant ,@(cdr whole)) #+sb-xc-host ,(unless (eql (find-symbol (symbol-name name) :cl) name) - `(defconstant ,@(cdr whole))) - #+sb-xc-host + `(defconstant ,@(cdr whole))) + #+sb-xc-host ,(let ((form `(sb!xc:defconstant ,@(cdr whole)))) - (if (boundp '*delayed-def!constants*) - `(push ',form *delayed-def!constants*) - form)))) + (if (boundp '*delayed-def!constants*) + `(push ',form *delayed-def!constants*) + form)))) ;;; machinery to implement DEF!CONSTANT delays #+sb-xc-host @@ -44,12 +44,12 @@ (/show "done binding *DELAYED-DEF!CONSTANTS*") (defun force-delayed-def!constants () (if (boundp '*delayed-def!constants*) - (progn - (mapc #'eval *delayed-def!constants*) - (makunbound '*delayed-def!constants*)) - ;; This condition is probably harmless if it comes up when - ;; interactively experimenting with the system by loading a - ;; source file into it more than once. But it's worth warning - ;; about it because it definitely shouldn't come up in an - ;; ordinary build process. - (warn "*DELAYED-DEF!CONSTANTS* is already unbound.")))) + (progn + (mapc #'eval *delayed-def!constants*) + (makunbound '*delayed-def!constants*)) + ;; This condition is probably harmless if it comes up when + ;; interactively experimenting with the system by loading a + ;; source file into it more than once. But it's worth warning + ;; about it because it definitely shouldn't come up in an + ;; ordinary build process. + (warn "*DELAYED-DEF!CONSTANTS* is already unbound.")))) diff --git a/src/code/defbangmacro.lisp b/src/code/defbangmacro.lisp index c2572dc..723a04e 100644 --- a/src/code/defbangmacro.lisp +++ b/src/code/defbangmacro.lisp @@ -38,12 +38,12 @@ (defmacro def!macro (name &rest rest) #-(or sb-xc-host sb-xc) `(defmacro ,name ,@rest) #+sb-xc-host `(progn - (defmacro ,name ,@rest) - ,(let ((uncrossed-args `(,(uncross name) ,@rest))) - (if (boundp '*delayed-def!macros*) - `(push (make-delayed-def!macro :args ',uncrossed-args) - *delayed-def!macros*) - `(sb!xc:defmacro ,@uncrossed-args)))) + (defmacro ,name ,@rest) + ,(let ((uncrossed-args `(,(uncross name) ,@rest))) + (if (boundp '*delayed-def!macros*) + `(push (make-delayed-def!macro :args ',uncrossed-args) + *delayed-def!macros*) + `(sb!xc:defmacro ,@uncrossed-args)))) ;; When cross-compiling, we don't want the DEF!MACRO to have any ;; effect at compile time, because (1) we already defined the macro ;; when building the cross-compiler, so at best it would be redundant @@ -62,9 +62,9 @@ (if (boundp '*delayed-def!macros*) (progn (mapcar (lambda (x) - (let ((*package* (delayed-def!macro-package x))) - (eval `(sb!xc:defmacro ,@(delayed-def!macro-args x))))) - (reverse *delayed-def!macros*)) + (let ((*package* (delayed-def!macro-package x))) + (eval `(sb!xc:defmacro ,@(delayed-def!macro-args x))))) + (reverse *delayed-def!macros*)) ;; We shouldn't need this list any more. Making it unbound serves as a ;; signal to DEF!MACRO that it needn't delayed DEF!MACROs any more. ;; It is also generally a good thing for other reasons: it frees diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp index 3e5c3a6..32d2135 100644 --- a/src/code/defbangstruct.lisp +++ b/src/code/defbangstruct.lisp @@ -34,7 +34,7 @@ (defun def!struct-supertype (type) (multiple-value-bind (value value-p) (gethash type *def!struct-supertype*) (unless value-p - (error "~S is not a DEF!STRUCT-defined type." type)) + (error "~S is not a DEF!STRUCT-defined type." type)) value)) (defun (setf def!struct-supertype) (value type) (when (and value #-sb-xc-host *type-system-initialized*) @@ -52,19 +52,19 @@ (defvar *def!struct-type-make-load-form-fun* (make-hash-table)) (defun def!struct-type-make-load-form-fun (type) (do ((supertype type)) - (nil) + (nil) (multiple-value-bind (value value-p) - (gethash supertype *def!struct-type-make-load-form-fun*) - (unless value-p - (error "~S (supertype of ~S) is not a DEF!STRUCT-defined type." - supertype - type)) - (when value - (return value)) - (setf supertype (def!struct-supertype supertype)) - (unless supertype - (error "There is no MAKE-LOAD-FORM function for bootstrap type ~S." - type))))) + (gethash supertype *def!struct-type-make-load-form-fun*) + (unless value-p + (error "~S (supertype of ~S) is not a DEF!STRUCT-defined type." + supertype + type)) + (when value + (return value)) + (setf supertype (def!struct-supertype supertype)) + (unless supertype + (error "There is no MAKE-LOAD-FORM function for bootstrap type ~S." + type))))) (defun (setf def!struct-type-make-load-form-fun) (new-value type) (when #+sb-xc-host t #-sb-xc-host *type-system-initialized* (aver (subtypep type 'structure!object)) @@ -125,26 +125,26 @@ ;; otherwise. (defun parse-def!struct-args (nameoid &rest rest) (multiple-value-bind (name options) ; Note: OPTIONS can change below. - (if (consp nameoid) - (values (first nameoid) (rest nameoid)) - (values nameoid nil)) + (if (consp nameoid) + (values (first nameoid) (rest nameoid)) + (values nameoid nil)) (declare (type list options)) (let* ((include-clause (find :include options :key #'first)) - (def!struct-supertype nil) ; may change below - (mlff-clause (find :make-load-form-fun options :key #'first)) - (mlff (and mlff-clause (second mlff-clause)))) - (when (find :type options :key #'first) - (error "can't use :TYPE option in DEF!STRUCT")) - (when mlff-clause - (setf options (remove mlff-clause options))) - (when include-clause - (setf def!struct-supertype (second include-clause))) - (if (eq name 'structure!object) ; if root of hierarchy - (aver (not include-clause)) - (unless include-clause - (setf def!struct-supertype 'structure!object) - (push `(:include ,def!struct-supertype) options))) - (values name `((,name ,@options) ,@rest) mlff def!struct-supertype))))) + (def!struct-supertype nil) ; may change below + (mlff-clause (find :make-load-form-fun options :key #'first)) + (mlff (and mlff-clause (second mlff-clause)))) + (when (find :type options :key #'first) + (error "can't use :TYPE option in DEF!STRUCT")) + (when mlff-clause + (setf options (remove mlff-clause options))) + (when include-clause + (setf def!struct-supertype (second include-clause))) + (if (eq name 'structure!object) ; if root of hierarchy + (aver (not include-clause)) + (unless include-clause + (setf def!struct-supertype 'structure!object) + (push `(:include ,def!struct-supertype) options))) + (values name `((,name ,@options) ,@rest) mlff def!struct-supertype))))) ;;; Part of the raison d'etre for DEF!STRUCT is to be able to emulate ;;; these low-level CMU CL functions in a vanilla ANSI Common Lisp @@ -159,27 +159,27 @@ (defun %instance-ref (instance index) (aver (typep instance 'structure!object)) (let* ((class (find-classoid (type-of instance))) - (layout (classoid-layout class))) + (layout (classoid-layout class))) (if (zerop index) - layout - (let* ((dd (layout-info layout)) - (dsd (elt (dd-slots dd) (1- index))) - (accessor-name (dsd-accessor-name dsd))) - (declare (type symbol accessor-name)) - (funcall accessor-name instance))))) + layout + (let* ((dd (layout-info layout)) + (dsd (elt (dd-slots dd) (1- index))) + (accessor-name (dsd-accessor-name dsd))) + (declare (type symbol accessor-name)) + (funcall accessor-name instance))))) (defun %instance-set (instance index new-value) (aver (typep instance 'structure!object)) (let* ((class (find-classoid (type-of instance))) - (layout (classoid-layout class))) + (layout (classoid-layout class))) (if (zerop index) - (error "can't set %INSTANCE-REF FOO 0 in cross-compilation host") - (let* ((dd (layout-info layout)) - (dsd (elt (dd-slots dd) (1- index))) - (accessor-name (dsd-accessor-name dsd))) - (declare (type symbol accessor-name)) - (funcall (fdefinition `(setf ,accessor-name)) - new-value - instance)))))) + (error "can't set %INSTANCE-REF FOO 0 in cross-compilation host") + (let* ((dd (layout-info layout)) + (dsd (elt (dd-slots dd) (1- index))) + (accessor-name (dsd-accessor-name dsd))) + (declare (type symbol accessor-name)) + (funcall (fdefinition `(setf ,accessor-name)) + new-value + instance)))))) ;;; a helper function for DEF!STRUCT in the #+SB-XC-HOST case: Return ;;; DEFSTRUCT-style arguments with any class names in the SB!XC @@ -191,22 +191,22 @@ (defun uncross-defstruct-args (defstruct-args) (destructuring-bind (name-and-options &rest slots-and-doc) defstruct-args (multiple-value-bind (name options) - (if (symbolp name-and-options) - (values name-and-options nil) - (values (first name-and-options) - (rest name-and-options))) - (flet ((uncross-option (option) - (if (eq (first option) :include) - (destructuring-bind - (include-keyword included-name &rest rest) - option - `(,include-keyword - ,(uncross included-name) - ,@rest)) - option))) - `((,(uncross name) - ,@(mapcar #'uncross-option options)) - ,@slots-and-doc)))))) + (if (symbolp name-and-options) + (values name-and-options nil) + (values (first name-and-options) + (rest name-and-options))) + (flet ((uncross-option (option) + (if (eq (first option) :include) + (destructuring-bind + (include-keyword included-name &rest rest) + option + `(,include-keyword + ,(uncross included-name) + ,@rest)) + option))) + `((,(uncross name) + ,@(mapcar #'uncross-option options)) + ,@slots-and-doc)))))) ;;; DEF!STRUCT's arguments are like DEFSTRUCT's arguments, except that ;;; DEF!STRUCT accepts an extra optional :MAKE-LOAD-FORM-FUN clause. @@ -229,20 +229,20 @@ ;; otherwise the bug might lurk until someone tried to do ;; MAKE-LOAD-FORM on an instance of the class. ,@(if (eq name 'structure!object) - (aver (null def!struct-supertype)) - `((aver (subtypep ',def!struct-supertype 'structure!object)))) + (aver (null def!struct-supertype)) + `((aver (subtypep ',def!struct-supertype 'structure!object)))) (defstruct ,@defstruct-args) (setf (def!struct-type-make-load-form-fun ',name) - ,(if (symbolp mlff) - `',mlff - mlff) - (def!struct-supertype ',name) - ',def!struct-supertype) + ,(if (symbolp mlff) + `',mlff + mlff) + (def!struct-supertype ',name) + ',def!struct-supertype) #+sb-xc-host ,(let ((u (uncross-defstruct-args defstruct-args))) - (if (boundp '*delayed-def!structs*) - `(push (make-delayed-def!struct :args ',u) - *delayed-def!structs*) - `(sb!xc:defstruct ,@u))) + (if (boundp '*delayed-def!structs*) + `(push (make-delayed-def!struct :args ',u) + *delayed-def!structs*) + `(sb!xc:defstruct ,@u))) ',name))) ;;; When building the cross-compiler, this function has to be called @@ -252,22 +252,22 @@ (defun force-delayed-def!structs () (if (boundp '*delayed-def!structs*) (progn - (mapcar (lambda (x) - (let ((*package* (delayed-def!struct-package x))) - ;; KLUDGE(?): EVAL is almost always the wrong thing. - ;; However, since we have to map DEFSTRUCT over the - ;; list, and since ANSI declined to specify any - ;; functional primitives corresponding to the - ;; DEFSTRUCT macro, it seems to me that EVAL is - ;; required in there somewhere.. - (eval `(sb!xc:defstruct ,@(delayed-def!struct-args x))))) - (reverse *delayed-def!structs*)) - ;; We shouldn't need this list any more. Making it unbound - ;; serves as a signal to DEF!STRUCT that it needn't delay - ;; DEF!STRUCTs any more. It is also generally a good thing for - ;; other reasons: it frees garbage, and it discourages anyone - ;; else from pushing anything else onto the list later. - (makunbound '*delayed-def!structs*)) + (mapcar (lambda (x) + (let ((*package* (delayed-def!struct-package x))) + ;; KLUDGE(?): EVAL is almost always the wrong thing. + ;; However, since we have to map DEFSTRUCT over the + ;; list, and since ANSI declined to specify any + ;; functional primitives corresponding to the + ;; DEFSTRUCT macro, it seems to me that EVAL is + ;; required in there somewhere.. + (eval `(sb!xc:defstruct ,@(delayed-def!struct-args x))))) + (reverse *delayed-def!structs*)) + ;; We shouldn't need this list any more. Making it unbound + ;; serves as a signal to DEF!STRUCT that it needn't delay + ;; DEF!STRUCTs any more. It is also generally a good thing for + ;; other reasons: it frees garbage, and it discourages anyone + ;; else from pushing anything else onto the list later. + (makunbound '*delayed-def!structs*)) ;; This condition is probably harmless if it comes up when ;; interactively experimenting with the system by loading a source ;; file into it more than once. But it's worth warning about it @@ -289,7 +289,7 @@ (defun structure!object-make-load-form (object &optional env) (declare (ignore env)) (funcall (def!struct-type-make-load-form-fun (type-of object)) - object)) + object)) ;;; Do the right thing at cold load time. ;;; diff --git a/src/code/defbangtype.lisp b/src/code/defbangtype.lisp index 7c58c4d..d59b7c1 100644 --- a/src/code/defbangtype.lisp +++ b/src/code/defbangtype.lisp @@ -31,11 +31,11 @@ (defmacro def!type (name &rest rest) `(progn (deftype ,name ,@rest) - #+sb-xc-host + #+sb-xc-host ,(let ((form `(sb!xc:deftype ,(uncross name) ,@rest))) - (if (boundp '*delayed-def!types*) - `(push ',form *delayed-def!types*) - form)))) + (if (boundp '*delayed-def!types*) + `(push ',form *delayed-def!types*) + form)))) ;;; machinery to implement DEF!TYPE delays #+sb-xc-host @@ -45,12 +45,12 @@ (/show "done binding *DELAYED-DEF!TYPES*") (defun force-delayed-def!types () (if (boundp '*delayed-def!types*) - (progn - (mapc #'eval *delayed-def!types*) - (makunbound '*delayed-def!types*)) - ;; This condition is probably harmless if it comes up when - ;; interactively experimenting with the system by loading a - ;; source file into it more than once. But it's worth warning - ;; about it because it definitely shouldn't come up in an - ;; ordinary build process. - (warn "*DELAYED-DEF!TYPES* is already unbound.")))) + (progn + (mapc #'eval *delayed-def!types*) + (makunbound '*delayed-def!types*)) + ;; This condition is probably harmless if it comes up when + ;; interactively experimenting with the system by loading a + ;; source file into it more than once. But it's worth warning + ;; about it because it definitely shouldn't come up in an + ;; ordinary build process. + (warn "*DELAYED-DEF!TYPES* is already unbound.")))) diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 43ad076..f87d263 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -38,13 +38,13 @@ ;; at this level, but the CMU CL code did it, so.. -- WHN 19990411 (if (= (length vars) 1) `(let ((,(car vars) ,value-form)) - ,@body) + ,@body) (let ((ignore (gensym))) - `(multiple-value-call #'(lambda (&optional ,@(mapcar #'list vars) - &rest ,ignore) - (declare (ignore ,ignore)) - ,@body) - ,value-form))) + `(multiple-value-call #'(lambda (&optional ,@(mapcar #'list vars) + &rest ,ignore) + (declare (ignore ,ignore)) + ,@body) + ,value-form))) (error "Vars is not a list of symbols: ~S" vars))) (defmacro-mundanely multiple-value-setq (vars value-form) @@ -68,19 +68,19 @@ (if (endp clauses) nil (let ((clause (first clauses))) - (if (atom clause) - (error "COND clause is not a list: ~S" clause) - (let ((test (first clause)) - (forms (rest clause))) - (if (endp forms) - (let ((n-result (gensym))) - `(let ((,n-result ,test)) - (if ,n-result - ,n-result - (cond ,@(rest clauses))))) - `(if ,test - (progn ,@forms) - (cond ,@(rest clauses))))))))) + (if (atom clause) + (error "COND clause is not a list: ~S" clause) + (let ((test (first clause)) + (forms (rest clause))) + (if (endp forms) + (let ((n-result (gensym))) + `(let ((,n-result ,test)) + (if ,n-result + ,n-result + (cond ,@(rest clauses))))) + `(if ,test + (progn ,@forms) + (cond ,@(rest clauses))))))))) ;;; other things defined in terms of COND (defmacro-mundanely when (test &body forms) @@ -95,30 +95,30 @@ `(cond ((not ,test) nil ,@forms))) (defmacro-mundanely and (&rest forms) (cond ((endp forms) t) - ((endp (rest forms)) (first forms)) - (t - `(if ,(first forms) - (and ,@(rest forms)) - nil)))) + ((endp (rest forms)) (first forms)) + (t + `(if ,(first forms) + (and ,@(rest forms)) + nil)))) (defmacro-mundanely or (&rest forms) (cond ((endp forms) nil) - ((endp (rest forms)) (first forms)) - (t - (let ((n-result (gensym))) - `(let ((,n-result ,(first forms))) - (if ,n-result - ,n-result - (or ,@(rest forms)))))))) + ((endp (rest forms)) (first forms)) + (t + (let ((n-result (gensym))) + `(let ((,n-result ,(first forms))) + (if ,n-result + ,n-result + (or ,@(rest forms)))))))) ;;;; various sequencing constructs (flet ((prog-expansion-from-let (varlist body-decls let) (multiple-value-bind (body decls) - (parse-body body-decls :doc-string-allowed nil) - `(block nil - (,let ,varlist - ,@decls - (tagbody ,@body)))))) + (parse-body body-decls :doc-string-allowed nil) + `(block nil + (,let ,varlist + ,@decls + (tagbody ,@body)))))) (defmacro-mundanely prog (varlist &body body-decls) (prog-expansion-from-let varlist body-decls 'let)) (defmacro-mundanely prog* (varlist &body body-decls) @@ -161,46 +161,46 @@ (warn "DEFUN of uninterned function name ~S (tricky for GENESIS)" name)) (multiple-value-bind (forms decls doc) (parse-body body) (let* (;; stuff shared between LAMBDA and INLINE-LAMBDA and NAMED-LAMBDA - (lambda-guts `(,args - ,@decls - (block ,(fun-name-block-name name) - ,@forms))) - (lambda `(lambda ,@lambda-guts)) + (lambda-guts `(,args + ,@decls + (block ,(fun-name-block-name name) + ,@forms))) + (lambda `(lambda ,@lambda-guts)) #-sb-xc-host - (named-lambda `(named-lambda ,name ,@lambda-guts)) - (inline-lambda - (when (inline-fun-name-p name) - ;; we want to attempt to inline, so complain if we can't - (or (sb!c:maybe-inline-syntactic-closure lambda env) - (progn - (#+sb-xc-host warn - #-sb-xc-host sb!c:maybe-compiler-notify - "lexical environment too hairy, can't inline DEFUN ~S" - name) - nil))))) + (named-lambda `(named-lambda ,name ,@lambda-guts)) + (inline-lambda + (when (inline-fun-name-p name) + ;; we want to attempt to inline, so complain if we can't + (or (sb!c:maybe-inline-syntactic-closure lambda env) + (progn + (#+sb-xc-host warn + #-sb-xc-host sb!c:maybe-compiler-notify + "lexical environment too hairy, can't inline DEFUN ~S" + name) + nil))))) `(progn - ;; In cross-compilation of toplevel DEFUNs, we arrange for - ;; the LAMBDA to be statically linked by GENESIS. + ;; In cross-compilation of toplevel DEFUNs, we arrange for + ;; the LAMBDA to be statically linked by GENESIS. ;; ;; It may seem strangely inconsistent not to use NAMED-LAMBDA ;; here instead of LAMBDA. The reason is historical: ;; COLD-FSET was written before NAMED-LAMBDA, and has special ;; logic of its own to notify the compiler about NAME. - #+sb-xc-host - (cold-fset ,name ,lambda) - - (eval-when (:compile-toplevel) - (sb!c:%compiler-defun ',name ',inline-lambda t)) - (eval-when (:load-toplevel :execute) - (%defun ',name - ;; In normal compilation (not for cold load) this is - ;; where the compiled LAMBDA first appears. In - ;; cross-compilation, we manipulate the - ;; previously-statically-linked LAMBDA here. - #-sb-xc-host ,named-lambda - #+sb-xc-host (fdefinition ',name) - ,doc - ',inline-lambda)))))) + #+sb-xc-host + (cold-fset ,name ,lambda) + + (eval-when (:compile-toplevel) + (sb!c:%compiler-defun ',name ',inline-lambda t)) + (eval-when (:load-toplevel :execute) + (%defun ',name + ;; In normal compilation (not for cold load) this is + ;; where the compiled LAMBDA first appears. In + ;; cross-compilation, we manipulate the + ;; previously-statically-linked LAMBDA here. + #-sb-xc-host ,named-lambda + #+sb-xc-host (fdefinition ',name) + ,doc + ',inline-lambda)))))) #-sb-xc-host (defun %defun (name def doc inline-lambda) @@ -212,13 +212,13 @@ (/show0 "redefining NAME in %DEFUN") (style-warn "redefining ~S in DEFUN" name)) (setf (sb!xc:fdefinition name) def) - + ;; FIXME: I want to do this here (and fix bug 137), but until the ;; breathtaking CMU CL function name architecture is converted into - ;; something sane, (1) doing so doesn't really fix the bug, and + ;; something sane, (1) doing so doesn't really fix the bug, and ;; (2) doing probably isn't even really safe. #+nil (setf (%fun-name def) name) - + (when doc (setf (fdocumentation name 'function) doc)) name) @@ -310,12 +310,12 @@ ;;; destructuring mechanisms. (defmacro-mundanely dotimes ((var count &optional (result nil)) &body body) (cond ((numberp count) - `(do ((,var 0 (1+ ,var))) + `(do ((,var 0 (1+ ,var))) ((>= ,var ,count) ,result) (declare (type unsigned-byte ,var)) ,@body)) - (t (let ((v1 (gensym))) - `(do ((,var 0 (1+ ,var)) (,v1 ,count)) + (t (let ((v1 (gensym))) + `(do ((,var 0 (1+ ,var)) (,v1 ,count)) ((>= ,var ,v1) ,result) (declare (type unsigned-byte ,var)) ,@body))))) @@ -329,7 +329,7 @@ (eq (car clause) 'ignore)))) (cdr decl)))) decls)) - + (defmacro-mundanely dolist ((var list &optional (result nil)) &body body) ;; We repeatedly bind the var instead of setting it so that we never ;; have to give the var an arbitrary value such as NIL (which might @@ -379,11 +379,11 @@ to the error currently being debugged. See also RESTART-CASE." (let ((n-cond (gensym))) `(let ((*condition-restarts* - (cons (let ((,n-cond ,condition-form)) - (cons ,n-cond - (append ,restarts-form - (cdr (assoc ,n-cond *condition-restarts*))))) - *condition-restarts*))) + (cons (let ((,n-cond ,condition-form)) + (cons ,n-cond + (append ,restarts-form + (cdr (assoc ,n-cond *condition-restarts*))))) + *condition-restarts*))) ,@body))) (defmacro-mundanely restart-bind (bindings &body forms) @@ -392,20 +392,20 @@ in effect. Users probably want to use RESTART-CASE. When clauses contain the same restart name, FIND-RESTART will find the first such clause." `(let ((*restart-clusters* - (cons (list - ,@(mapcar (lambda (binding) - (unless (or (car binding) - (member :report-function - binding - :test #'eq)) - (warn "Unnamed restart does not have a ~ + (cons (list + ,@(mapcar (lambda (binding) + (unless (or (car binding) + (member :report-function + binding + :test #'eq)) + (warn "Unnamed restart does not have a ~ report function: ~S" - binding)) - `(make-restart :name ',(car binding) - :function ,(cadr binding) - ,@(cddr binding))) - bindings)) - *restart-clusters*))) + binding)) + `(make-restart :name ',(car binding) + :function ,(cadr binding) + ,@(cddr binding))) + bindings)) + *restart-clusters*))) ,@forms)) ;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if @@ -413,25 +413,25 @@ (defun munge-restart-case-expression (expression env) (let ((exp (sb!xc:macroexpand expression env))) (if (consp exp) - (let* ((name (car exp)) - (args (if (eq name 'cerror) (cddr exp) (cdr exp)))) - (if (member name '(signal error cerror warn)) - (once-only ((n-cond `(coerce-to-condition - ,(first args) - (list ,@(rest args)) - ',(case name - (warn 'simple-warning) - (signal 'simple-condition) - (t 'simple-error)) - ',name))) - `(with-condition-restarts - ,n-cond - (car *restart-clusters*) - ,(if (eq name 'cerror) - `(cerror ,(second exp) ,n-cond) - `(,name ,n-cond)))) - expression)) - expression))) + (let* ((name (car exp)) + (args (if (eq name 'cerror) (cddr exp) (cdr exp)))) + (if (member name '(signal error cerror warn)) + (once-only ((n-cond `(coerce-to-condition + ,(first args) + (list ,@(rest args)) + ',(case name + (warn 'simple-warning) + (signal 'simple-condition) + (t 'simple-error)) + ',name))) + `(with-condition-restarts + ,n-cond + (car *restart-clusters*) + ,(if (eq name 'cerror) + `(cerror ,(second exp) ,n-cond) + `(,name ,n-cond)))) + expression)) + expression))) ;;; FIXME: I did a fair amount of rearrangement of this code in order to ;;; get WITH-KEYWORD-PAIRS to work cleanly. This code should be tested.. @@ -446,94 +446,94 @@ macroexpands into such) then the signalled condition will be associated with the new restarts." (flet ((transform-keywords (&key report interactive test) - (let ((result '())) - (when report - (setq result (list* (if (stringp report) - `#'(lambda (stream) - (write-string ,report stream)) - `#',report) - :report-function - result))) - (when interactive - (setq result (list* `#',interactive - :interactive-function - result))) - (when test - (setq result (list* `#',test :test-function result))) - (nreverse result))) - (parse-keyword-pairs (list keys) - (do ((l list (cddr l)) - (k '() (list* (cadr l) (car l) k))) - ((or (null l) (not (member (car l) keys))) - (values (nreverse k) l))))) + (let ((result '())) + (when report + (setq result (list* (if (stringp report) + `#'(lambda (stream) + (write-string ,report stream)) + `#',report) + :report-function + result))) + (when interactive + (setq result (list* `#',interactive + :interactive-function + result))) + (when test + (setq result (list* `#',test :test-function result))) + (nreverse result))) + (parse-keyword-pairs (list keys) + (do ((l list (cddr l)) + (k '() (list* (cadr l) (car l) k))) + ((or (null l) (not (member (car l) keys))) + (values (nreverse k) l))))) (let ((block-tag (gensym)) - (temp-var (gensym)) - (data - (macrolet (;; KLUDGE: This started as an old DEFMACRO - ;; WITH-KEYWORD-PAIRS general utility, which was used - ;; only in this one place in the code. It was translated - ;; literally into this MACROLET in order to avoid some - ;; cross-compilation bootstrap problems. It would almost - ;; certainly be clearer, and it would certainly be more - ;; concise, to do a more idiomatic translation, merging - ;; this with the TRANSFORM-KEYWORDS logic above. - ;; -- WHN 19990925 - (with-keyword-pairs ((names expression) &body forms) - (let ((temp (member '&rest names))) - (unless (= (length temp) 2) - (error "&REST keyword is ~:[missing~;misplaced~]." - temp)) - (let* ((key-vars (ldiff names temp)) - (keywords (mapcar #'keywordicate key-vars)) - (key-var (gensym)) - (rest-var (cadr temp))) - `(multiple-value-bind (,key-var ,rest-var) - (parse-keyword-pairs ,expression ',keywords) - (let ,(mapcar (lambda (var keyword) - `(,var (getf ,key-var - ,keyword))) - key-vars keywords) - ,@forms)))))) - (mapcar (lambda (clause) - (with-keyword-pairs ((report interactive test - &rest forms) - (cddr clause)) - (list (car clause) ;name=0 - (gensym) ;tag=1 - (transform-keywords :report report ;keywords=2 - :interactive interactive - :test test) - (cadr clause) ;bvl=3 - forms))) ;body=4 - clauses)))) + (temp-var (gensym)) + (data + (macrolet (;; KLUDGE: This started as an old DEFMACRO + ;; WITH-KEYWORD-PAIRS general utility, which was used + ;; only in this one place in the code. It was translated + ;; literally into this MACROLET in order to avoid some + ;; cross-compilation bootstrap problems. It would almost + ;; certainly be clearer, and it would certainly be more + ;; concise, to do a more idiomatic translation, merging + ;; this with the TRANSFORM-KEYWORDS logic above. + ;; -- WHN 19990925 + (with-keyword-pairs ((names expression) &body forms) + (let ((temp (member '&rest names))) + (unless (= (length temp) 2) + (error "&REST keyword is ~:[missing~;misplaced~]." + temp)) + (let* ((key-vars (ldiff names temp)) + (keywords (mapcar #'keywordicate key-vars)) + (key-var (gensym)) + (rest-var (cadr temp))) + `(multiple-value-bind (,key-var ,rest-var) + (parse-keyword-pairs ,expression ',keywords) + (let ,(mapcar (lambda (var keyword) + `(,var (getf ,key-var + ,keyword))) + key-vars keywords) + ,@forms)))))) + (mapcar (lambda (clause) + (with-keyword-pairs ((report interactive test + &rest forms) + (cddr clause)) + (list (car clause) ;name=0 + (gensym) ;tag=1 + (transform-keywords :report report ;keywords=2 + :interactive interactive + :test test) + (cadr clause) ;bvl=3 + forms))) ;body=4 + clauses)))) `(block ,block-tag - (let ((,temp-var nil)) - (tagbody - (restart-bind - ,(mapcar (lambda (datum) - (let ((name (nth 0 datum)) - (tag (nth 1 datum)) - (keys (nth 2 datum))) - `(,name #'(lambda (&rest temp) - (setq ,temp-var temp) - (go ,tag)) - ,@keys))) - data) - (return-from ,block-tag - ,(munge-restart-case-expression expression env))) - ,@(mapcan (lambda (datum) - (let ((tag (nth 1 datum)) - (bvl (nth 3 datum)) - (body (nth 4 datum))) - (list tag - `(return-from ,block-tag - (apply (lambda ,bvl ,@body) - ,temp-var))))) - data))))))) + (let ((,temp-var nil)) + (tagbody + (restart-bind + ,(mapcar (lambda (datum) + (let ((name (nth 0 datum)) + (tag (nth 1 datum)) + (keys (nth 2 datum))) + `(,name #'(lambda (&rest temp) + (setq ,temp-var temp) + (go ,tag)) + ,@keys))) + data) + (return-from ,block-tag + ,(munge-restart-case-expression expression env))) + ,@(mapcan (lambda (datum) + (let ((tag (nth 1 datum)) + (bvl (nth 3 datum)) + (body (nth 4 datum))) + (list tag + `(return-from ,block-tag + (apply (lambda ,bvl ,@body) + ,temp-var))))) + data))))))) (defmacro-mundanely with-simple-restart ((restart-name format-string - &rest format-arguments) - &body forms) + &rest format-arguments) + &body forms) #!+sb-doc "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments) body) @@ -545,8 +545,8 @@ ;; RESTART-CASE to "see" calls to ERROR, etc. ,(if (= (length forms) 1) (car forms) `(progn ,@forms)) (,restart-name () - :report (lambda (stream) - (format stream ,format-string ,@format-arguments)) + :report (lambda (stream) + (format stream ,format-string ,@format-arguments)) (values nil t)))) (defmacro-mundanely handler-bind (bindings &body forms) @@ -557,17 +557,17 @@ argument. The bindings are searched first to last in the event of a signalled condition." (let ((member-if (member-if (lambda (x) - (not (proper-list-of-length-p x 2))) - bindings))) + (not (proper-list-of-length-p x 2))) + bindings))) (when member-if (error "ill-formed handler binding: ~S" (first member-if)))) `(let ((*handler-clusters* - (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) - bindings)) - *handler-clusters*))) + (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) + bindings)) + *handler-clusters*))) (multiple-value-prog1 - (progn - ,@forms) + (progn + ,@forms) ;; Wait for any float exceptions. #!+x86 (float-wait)))) @@ -584,49 +584,49 @@ ;; understand the code below. (let ((no-error-clause (assoc ':no-error cases))) (if no-error-clause - (let ((normal-return (make-symbol "normal-return")) - (error-return (make-symbol "error-return"))) - `(block ,error-return - (multiple-value-call (lambda ,@(cdr no-error-clause)) - (block ,normal-return - (return-from ,error-return - (handler-case (return-from ,normal-return ,form) - ,@(remove no-error-clause cases))))))) - (let ((tag (gensym)) - (var (gensym)) - (annotated-cases (mapcar (lambda (case) (cons (gensym) case)) - cases))) - `(block ,tag - (let ((,var nil)) - (declare (ignorable ,var)) - (tagbody - (handler-bind - ,(mapcar (lambda (annotated-case) - (list (cadr annotated-case) - `(lambda (temp) - ,(if (caddr annotated-case) - `(setq ,var temp) - '(declare (ignore temp))) - (go ,(car annotated-case))))) - annotated-cases) - (return-from ,tag - #!-x86 ,form - #!+x86 (multiple-value-prog1 ,form - ;; Need to catch FP errors here! - (float-wait)))) - ,@(mapcan - (lambda (annotated-case) - (list (car annotated-case) - (let ((body (cdddr annotated-case))) - `(return-from - ,tag - ,(cond ((caddr annotated-case) - `(let ((,(caaddr annotated-case) - ,var)) - ,@body)) - (t - `(locally ,@body))))))) - annotated-cases)))))))) + (let ((normal-return (make-symbol "normal-return")) + (error-return (make-symbol "error-return"))) + `(block ,error-return + (multiple-value-call (lambda ,@(cdr no-error-clause)) + (block ,normal-return + (return-from ,error-return + (handler-case (return-from ,normal-return ,form) + ,@(remove no-error-clause cases))))))) + (let ((tag (gensym)) + (var (gensym)) + (annotated-cases (mapcar (lambda (case) (cons (gensym) case)) + cases))) + `(block ,tag + (let ((,var nil)) + (declare (ignorable ,var)) + (tagbody + (handler-bind + ,(mapcar (lambda (annotated-case) + (list (cadr annotated-case) + `(lambda (temp) + ,(if (caddr annotated-case) + `(setq ,var temp) + '(declare (ignore temp))) + (go ,(car annotated-case))))) + annotated-cases) + (return-from ,tag + #!-x86 ,form + #!+x86 (multiple-value-prog1 ,form + ;; Need to catch FP errors here! + (float-wait)))) + ,@(mapcan + (lambda (annotated-case) + (list (car annotated-case) + (let ((body (cdddr annotated-case))) + `(return-from + ,tag + ,(cond ((caddr annotated-case) + `(let ((,(caaddr annotated-case) + ,var)) + ,@body)) + (t + `(locally ,@body))))))) + annotated-cases)))))))) ;;;; miscellaneous @@ -646,8 +646,8 @@ ((endp pair) `(psetf ,@pairs)) (unless (symbolp (car pair)) (error 'simple-program-error - :format-control "variable ~S in PSETQ is not a SYMBOL" - :format-arguments (list (car pair)))))) + :format-control "variable ~S in PSETQ is not a SYMBOL" + :format-arguments (list (car pair)))))) (defmacro-mundanely lambda (&whole whole args &body body) (declare (ignore args body)) @@ -658,8 +658,8 @@ `#',whole) (defmacro-mundanely lambda-with-lexenv (&whole whole - declarations macros symbol-macros - &body body) + declarations macros symbol-macros + &body body) (declare (ignore declarations macros symbol-macros body)) `#',whole) @@ -669,26 +669,26 @@ ;;; magic functions here. -- CSR, 2003-04-01 #+sb-xc-host (sb!xc:proclaim '(ftype (function * *) - ;; functions appearing in fundamental defining - ;; macro expansions: - %compiler-deftype - %compiler-defvar - %defun - %defsetf - %defparameter - %defvar - sb!c:%compiler-defun - sb!c::%define-symbol-macro - sb!c::%defconstant - sb!c::%define-compiler-macro - sb!c::%defmacro - sb!kernel::%compiler-defstruct - sb!kernel::%compiler-define-condition - sb!kernel::%defstruct - sb!kernel::%define-condition - ;; miscellaneous functions commonly appearing - ;; as a result of macro expansions or compiler - ;; transformations: - sb!int:find-undeleted-package-or-lose ; IN-PACKAGE - sb!kernel::arg-count-error ; PARSE-DEFMACRO - )) + ;; functions appearing in fundamental defining + ;; macro expansions: + %compiler-deftype + %compiler-defvar + %defun + %defsetf + %defparameter + %defvar + sb!c:%compiler-defun + sb!c::%define-symbol-macro + sb!c::%defconstant + sb!c::%define-compiler-macro + sb!c::%defmacro + sb!kernel::%compiler-defstruct + sb!kernel::%compiler-define-condition + sb!kernel::%defstruct + sb!kernel::%define-condition + ;; miscellaneous functions commonly appearing + ;; as a result of macro expansions or compiler + ;; transformations: + sb!int:find-undeleted-package-or-lose ; IN-PACKAGE + sb!kernel::arg-count-error ; PARSE-DEFMACRO + )) diff --git a/src/code/defmacro.lisp b/src/code/defmacro.lisp index afa964e..21caf2d 100644 --- a/src/code/defmacro.lisp +++ b/src/code/defmacro.lisp @@ -33,17 +33,17 @@ name)) (with-unique-names (whole environment) (multiple-value-bind (new-body local-decs doc) - (parse-defmacro lambda-list whole body name 'defmacro - :environment environment) - (let ((def `(lambda (,whole ,environment) - ,@local-decs + (parse-defmacro lambda-list whole body name 'defmacro + :environment environment) + (let ((def `(lambda (,whole ,environment) + ,@local-decs ,new-body)) - ;; If we want to move over to list-style names - ;; [e.g. (DEFMACRO FOO), maybe to support some XREF-like - ;; functionality] here might be a good place to start. - (debug-name (sb!c::debug-name 'macro-function name))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (sb!c::%defmacro ',name #',def ',lambda-list + ;; If we want to move over to list-style names + ;; [e.g. (DEFMACRO FOO), maybe to support some XREF-like + ;; functionality] here might be a good place to start. + (debug-name (sb!c::debug-name 'macro-function name))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (sb!c::%defmacro ',name #',def ',lambda-list ,doc ',debug-name))))))) (macrolet @@ -91,11 +91,11 @@ (#.sb!vm:closure-header-widetag (setf (%simple-fun-arglist (%closure-fun definition)) lambda-list - (%simple-fun-name (%closure-fun definition)) - debug-name)) + (%simple-fun-name (%closure-fun definition)) + debug-name)) (#.sb!vm:simple-fun-header-widetag (setf (%simple-fun-arglist definition) lambda-list - (%simple-fun-name definition) debug-name)))) + (%simple-fun-name definition) debug-name)))) name)))) (progn (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil) diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp index c7772c8..01d38ce 100644 --- a/src/code/defpackage.lisp +++ b/src/code/defpackage.lisp @@ -28,11 +28,11 @@ nil)) (defmacro defpackage (package &rest options) - #!+sb-doc - #.(format nil - "Defines a new package called PACKAGE. Each of OPTIONS should be one of the + #!+sb-doc + #.(format nil + "Defines a new package called PACKAGE. Each of OPTIONS should be one of the following: ~{~&~4T~A~} - All options except ~{~A, ~}and :DOCUMENTATION can be used multiple + All options except ~{~A, ~}and :DOCUMENTATION can be used multiple times." '((:nicknames "{package-name}*") (:size "") @@ -47,102 +47,102 @@ (:documentation "doc-string")) '(:size #!+sb-package-locks :lock)) (let ((nicknames nil) - (size nil) - (shadows nil) - (shadowing-imports nil) - (use nil) - (use-p nil) - (imports nil) - (interns nil) - (exports nil) - (implement (stringify-names (list package) "package")) - (implement-p nil) - (lock nil) - (doc nil)) - #!-sb-package-locks + (size nil) + (shadows nil) + (shadowing-imports nil) + (use nil) + (use-p nil) + (imports nil) + (interns nil) + (exports nil) + (implement (stringify-names (list package) "package")) + (implement-p nil) + (lock nil) + (doc nil)) + #!-sb-package-locks (declare (ignore implement-p)) (dolist (option options) (unless (consp option) - (error 'simple-program-error - :format-control "bogus DEFPACKAGE option: ~S" - :format-arguments (list option))) + (error 'simple-program-error + :format-control "bogus DEFPACKAGE option: ~S" + :format-arguments (list option))) (case (car option) - (:nicknames - (setf nicknames (stringify-names (cdr option) "package"))) - (:size - (cond (size - (error 'simple-program-error - :format-control "can't specify :SIZE twice.")) - ((and (consp (cdr option)) - (typep (second option) 'unsigned-byte)) - (setf size (second option))) - (t - (error - 'simple-program-error - :format-control ":SIZE is not a positive integer: ~S" - :format-arguments (list (second option)))))) - (:shadow - (let ((new (stringify-names (cdr option) "symbol"))) - (setf shadows (append shadows new)))) - (:shadowing-import-from - (let ((package-name (stringify-name (second option) "package")) - (names (stringify-names (cddr option) "symbol"))) - (let ((assoc (assoc package-name shadowing-imports - :test #'string=))) - (if assoc - (setf (cdr assoc) (append (cdr assoc) names)) - (setf shadowing-imports - (acons package-name names shadowing-imports)))))) - (:use - (setf use (append use (stringify-names (cdr option) "package") ) - use-p t)) - (:import-from - (let ((package-name (stringify-name (second option) "package")) - (names (stringify-names (cddr option) "symbol"))) - (let ((assoc (assoc package-name imports - :test #'string=))) - (if assoc - (setf (cdr assoc) (append (cdr assoc) names)) - (setf imports (acons package-name names imports)))))) - (:intern - (let ((new (stringify-names (cdr option) "symbol"))) - (setf interns (append interns new)))) - (:export - (let ((new (stringify-names (cdr option) "symbol"))) - (setf exports (append exports new)))) - #!+sb-package-locks - (:implement - (unless implement-p - (setf implement nil)) - (let ((new (stringify-names (cdr option) "package"))) - (setf implement (append implement new) - implement-p t))) - #!+sb-package-locks - (:lock - (when lock - (error 'simple-program-error - :format-control "multiple :LOCK options")) - (setf lock (coerce (second option) 'boolean))) - (:documentation - (when doc - (error 'simple-program-error - :format-control "multiple :DOCUMENTATION options")) - (setf doc (coerce (second option) 'simple-string))) - (t - (error 'simple-program-error - :format-control "bogus DEFPACKAGE option: ~S" - :format-arguments (list option))))) + (:nicknames + (setf nicknames (stringify-names (cdr option) "package"))) + (:size + (cond (size + (error 'simple-program-error + :format-control "can't specify :SIZE twice.")) + ((and (consp (cdr option)) + (typep (second option) 'unsigned-byte)) + (setf size (second option))) + (t + (error + 'simple-program-error + :format-control ":SIZE is not a positive integer: ~S" + :format-arguments (list (second option)))))) + (:shadow + (let ((new (stringify-names (cdr option) "symbol"))) + (setf shadows (append shadows new)))) + (:shadowing-import-from + (let ((package-name (stringify-name (second option) "package")) + (names (stringify-names (cddr option) "symbol"))) + (let ((assoc (assoc package-name shadowing-imports + :test #'string=))) + (if assoc + (setf (cdr assoc) (append (cdr assoc) names)) + (setf shadowing-imports + (acons package-name names shadowing-imports)))))) + (:use + (setf use (append use (stringify-names (cdr option) "package") ) + use-p t)) + (:import-from + (let ((package-name (stringify-name (second option) "package")) + (names (stringify-names (cddr option) "symbol"))) + (let ((assoc (assoc package-name imports + :test #'string=))) + (if assoc + (setf (cdr assoc) (append (cdr assoc) names)) + (setf imports (acons package-name names imports)))))) + (:intern + (let ((new (stringify-names (cdr option) "symbol"))) + (setf interns (append interns new)))) + (:export + (let ((new (stringify-names (cdr option) "symbol"))) + (setf exports (append exports new)))) + #!+sb-package-locks + (:implement + (unless implement-p + (setf implement nil)) + (let ((new (stringify-names (cdr option) "package"))) + (setf implement (append implement new) + implement-p t))) + #!+sb-package-locks + (:lock + (when lock + (error 'simple-program-error + :format-control "multiple :LOCK options")) + (setf lock (coerce (second option) 'boolean))) + (:documentation + (when doc + (error 'simple-program-error + :format-control "multiple :DOCUMENTATION options")) + (setf doc (coerce (second option) 'simple-string))) + (t + (error 'simple-program-error + :format-control "bogus DEFPACKAGE option: ~S" + :format-arguments (list option))))) (check-disjoint `(:intern ,@interns) `(:export ,@exports)) (check-disjoint `(:intern ,@interns) - `(:import-from - ,@(apply #'append (mapcar #'rest imports))) - `(:shadow ,@shadows) - `(:shadowing-import-from - ,@(apply #'append (mapcar #'rest shadowing-imports)))) + `(:import-from + ,@(apply #'append (mapcar #'rest imports))) + `(:shadow ,@shadows) + `(:shadowing-import-from + ,@(apply #'append (mapcar #'rest shadowing-imports)))) `(eval-when (:compile-toplevel :load-toplevel :execute) (%defpackage ,(stringify-name package "package") ',nicknames ',size - ',shadows ',shadowing-imports ',(if use-p use :default) - ',imports ',interns ',exports ',implement ',lock ',doc)))) + ',shadows ',shadowing-imports ',(if use-p use :default) + ',imports ',interns ',exports ',implement ',lock ',doc)))) (defun check-disjoint (&rest args) ;; An arg is (:key . set) @@ -153,9 +153,9 @@ for y in (rest list) for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=)) when z do (error 'simple-program-error - :format-control "Parameters ~S and ~S must be disjoint ~ + :format-control "Parameters ~S and ~S must be disjoint ~ but have common elements ~% ~S" - :format-arguments (list (car x)(car y) z))))) + :format-arguments (list (car x)(car y) z))))) (defun stringify-name (name kind) (typecase name @@ -168,85 +168,85 @@ (defun stringify-names (names kind) (mapcar (lambda (name) - (stringify-name name kind)) - names)) + (stringify-name name kind)) + names)) (defun %defpackage (name nicknames size shadows shadowing-imports - use imports interns exports implement lock doc-string) + use imports interns exports implement lock doc-string) (declare (type simple-string name) - (type list nicknames shadows shadowing-imports - imports interns exports) - (type (or list (member :default)) use) - (type (or simple-string null) doc-string) - #!-sb-package-locks - (ignore implement lock)) + (type list nicknames shadows shadowing-imports + imports interns exports) + (type (or list (member :default)) use) + (type (or simple-string null) doc-string) + #!-sb-package-locks + (ignore implement lock)) (let ((package (or (find-package name) - (progn - (when (eq use :default) - (setf use '#.*default-package-use-list*)) - (make-package name - :use nil - :internal-symbols (or size 10) - :external-symbols (length exports)))))) + (progn + (when (eq use :default) + (setf use '#.*default-package-use-list*)) + (make-package name + :use nil + :internal-symbols (or size 10) + :external-symbols (length exports)))))) (unless (string= (the string (package-name package)) name) (error 'simple-package-error - :package name - :format-control "~A is a nickname for the package ~A" - :format-arguments (list name (package-name name)))) + :package name + :format-control "~A is a nickname for the package ~A" + :format-arguments (list name (package-name name)))) (enter-new-nicknames package nicknames) ;; Handle shadows and shadowing-imports. (let ((old-shadows (package-%shadowing-symbols package))) (shadow shadows package) (dolist (sym-name shadows) - (setf old-shadows (remove (find-symbol sym-name package) old-shadows))) + (setf old-shadows (remove (find-symbol sym-name package) old-shadows))) (dolist (simports-from shadowing-imports) - (let ((other-package (find-undeleted-package-or-lose - (car simports-from)))) - (dolist (sym-name (cdr simports-from)) - (let ((sym (find-or-make-symbol sym-name other-package))) - (shadowing-import sym package) - (setf old-shadows (remove sym old-shadows)))))) + (let ((other-package (find-undeleted-package-or-lose + (car simports-from)))) + (dolist (sym-name (cdr simports-from)) + (let ((sym (find-or-make-symbol sym-name other-package))) + (shadowing-import sym package) + (setf old-shadows (remove sym old-shadows)))))) (when old-shadows - (warn 'package-at-variance - :format-control "~A also shadows the following symbols:~% ~S" - :format-arguments (list name old-shadows)))) + (warn 'package-at-variance + :format-control "~A also shadows the following symbols:~% ~S" + :format-arguments (list name old-shadows)))) ;; Handle USE. (unless (eq use :default) (let ((old-use-list (package-use-list package)) - (new-use-list (mapcar #'find-undeleted-package-or-lose use))) - (use-package (set-difference new-use-list old-use-list) package) - (let ((laterize (set-difference old-use-list new-use-list))) - (when laterize - (unuse-package laterize package) - (warn 'package-at-variance - :format-control "~A used to use the following packages:~% ~S" - :format-arguments (list name laterize)))))) + (new-use-list (mapcar #'find-undeleted-package-or-lose use))) + (use-package (set-difference new-use-list old-use-list) package) + (let ((laterize (set-difference old-use-list new-use-list))) + (when laterize + (unuse-package laterize package) + (warn 'package-at-variance + :format-control "~A used to use the following packages:~% ~S" + :format-arguments (list name laterize)))))) ;; Handle IMPORT and INTERN. (dolist (sym-name interns) (intern sym-name package)) (dolist (imports-from imports) (let ((other-package (find-undeleted-package-or-lose (car - imports-from)))) - (dolist (sym-name (cdr imports-from)) - (import (list (find-or-make-symbol sym-name other-package)) - package)))) + imports-from)))) + (dolist (sym-name (cdr imports-from)) + (import (list (find-or-make-symbol sym-name other-package)) + package)))) ;; Handle exports. (let ((old-exports nil) - (exports (mapcar (lambda (sym-name) (intern sym-name package)) - exports))) + (exports (mapcar (lambda (sym-name) (intern sym-name package)) + exports))) (do-external-symbols (sym package) - (push sym old-exports)) + (push sym old-exports)) (export exports package) (let ((diff (set-difference old-exports exports))) - (when diff - (warn 'package-at-variance - :format-control "~A also exports the following symbols:~% ~S" - :format-arguments (list name diff))))) + (when diff + (warn 'package-at-variance + :format-control "~A also exports the following symbols:~% ~S" + :format-arguments (list name diff))))) #!+sb-package-locks (progn ;; Handle packages this is an implementation package of (dolist (p implement) - (add-implementation-package package p)) + (add-implementation-package package p)) ;; Handle lock (setf (package-lock package) lock)) ;; Handle documentation. @@ -256,11 +256,11 @@ (defun find-or-make-symbol (name package) (multiple-value-bind (symbol how) (find-symbol name package) (cond (how - symbol) - (t - (with-simple-restart (continue "INTERN it.") - (error 'simple-package-error - :package package - :format-control "no symbol named ~S in ~S" - :format-arguments (list name (package-name package)))) - (intern name package))))) + symbol) + (t + (with-simple-restart (continue "INTERN it.") + (error 'simple-package-error + :package package + :format-control "no symbol named ~S in ~S" + :format-arguments (list name (package-name package)))) + (intern name package))))) diff --git a/src/code/defsetfs.lisp b/src/code/defsetfs.lisp index ea47a7c..aa202b1 100644 --- a/src/code/defsetfs.lisp +++ b/src/code/defsetfs.lisp @@ -129,8 +129,8 @@ (defsetf sap-ref-double %set-sap-ref-double) #!+long-float (defsetf sap-ref-long %set-sap-ref-long) #-sb-xc-host (defsetf subseq (sequence start &optional (end nil)) (v) - `(progn (replace ,sequence ,v :start1 ,start :end1 ,end) - ,v)) + `(progn (replace ,sequence ,v :start1 ,start :end1 ,end) + ,v)) ;;; from fdefinition.lisp (in-package "SB!IMPL") diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 2ed87b4..89a8b9c 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -1,4 +1,4 @@ -;;;; that part of DEFSTRUCT implementation which is needed not just +;;;; that part of DEFSTRUCT implementation which is needed not just ;;;; in the target Lisp but also in the cross-compilation host ;;;; This software is part of the SBCL system. See the README file for @@ -21,10 +21,10 @@ (defun compiler-layout-or-lose (name) (let ((res (info :type :compiler-layout name))) (cond ((not res) - (error "Class is not yet defined or was undefined: ~S" name)) - ((not (typep (layout-info res) 'defstruct-description)) - (error "Class is not a structure class: ~S" name)) - (t res)))) + (error "Class is not yet defined or was undefined: ~S" name)) + ((not (typep (layout-info res) 'defstruct-description)) + (error "Class is not a structure class: ~S" name)) + (t res)))) ;;; Delay looking for compiler-layout until the constructor is being ;;; compiled, since it doesn't exist until after the EVAL-WHEN @@ -35,28 +35,28 @@ (sb!xc:defmacro %delayed-get-compiler-layout (name) (let ((layout (info :type :compiler-layout name))) (cond (layout - ;; ordinary case: When the DEFSTRUCT is at top level, - ;; then EVAL-WHEN (COMPILE) stuff will have set up the - ;; layout for us to use. - (unless (typep (layout-info layout) 'defstruct-description) - (error "Class is not a structure class: ~S" name)) - `,layout) - (t - ;; KLUDGE: In the case that DEFSTRUCT is not at top-level - ;; the layout doesn't exist at compile time. In that case - ;; we laboriously look it up at run time. This code will - ;; run on every constructor call and will likely be quite - ;; slow, so if anyone cares about performance of - ;; non-toplevel DEFSTRUCTs, it should be rewritten to be - ;; cleverer. -- WHN 2002-10-23 - (sb!c:compiler-notify - "implementation limitation: ~ + ;; ordinary case: When the DEFSTRUCT is at top level, + ;; then EVAL-WHEN (COMPILE) stuff will have set up the + ;; layout for us to use. + (unless (typep (layout-info layout) 'defstruct-description) + (error "Class is not a structure class: ~S" name)) + `,layout) + (t + ;; KLUDGE: In the case that DEFSTRUCT is not at top-level + ;; the layout doesn't exist at compile time. In that case + ;; we laboriously look it up at run time. This code will + ;; run on every constructor call and will likely be quite + ;; slow, so if anyone cares about performance of + ;; non-toplevel DEFSTRUCTs, it should be rewritten to be + ;; cleverer. -- WHN 2002-10-23 + (sb!c:compiler-notify + "implementation limitation: ~ Non-toplevel DEFSTRUCT constructors are slow.") - (with-unique-names (layout) - `(let ((,layout (info :type :compiler-layout ',name))) - (unless (typep (layout-info ,layout) 'defstruct-description) - (error "Class is not a structure class: ~S" ',name)) - ,layout)))))) + (with-unique-names (layout) + `(let ((,layout (info :type :compiler-layout ',name))) + (unless (typep (layout-info ,layout) 'defstruct-description) + (error "Class is not a structure class: ~S" ',name)) + ,layout)))))) ;;; Get layout right away. (sb!xc:defmacro compile-time-find-layout (name) @@ -73,14 +73,14 @@ ;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information ;;; about a structure type. (def!struct (defstruct-description - (:conc-name dd-) - (:make-load-form-fun just-dump-it-normally) - #-sb-xc-host (:pure t) - (:constructor make-defstruct-description - (name &aux - (conc-name (symbolicate name "-")) - (copier-name (symbolicate "COPY-" name)) - (predicate-name (symbolicate name "-P"))))) + (:conc-name dd-) + (:make-load-form-fun just-dump-it-normally) + #-sb-xc-host (:pure t) + (:constructor make-defstruct-description + (name &aux + (conc-name (symbolicate name "-")) + (copier-name (symbolicate "COPY-" name)) + (predicate-name (symbolicate name "-P"))))) ;; name of the structure (name (missing-arg) :type symbol :read-only t) ;; documentation on the structure @@ -113,7 +113,7 @@ (length 0 :type index) ;; General kind of implementation. (type 'structure :type (member structure vector list - funcallable-structure)) + funcallable-structure)) ;; The next three slots are for :TYPE'd structures (which aren't ;; classes, DD-CLASS-P = NIL) @@ -145,7 +145,7 @@ ;;; Does DD describe a structure with a class? (defun dd-class-p (dd) (member (dd-type dd) - '(structure funcallable-structure))) + '(structure funcallable-structure))) ;;; a type name which can be used when declaring things which operate ;;; on structure instances @@ -167,10 +167,10 @@ ;;; A DEFSTRUCT-SLOT-DESCRIPTION holds compile-time information about ;;; a structure slot. (def!struct (defstruct-slot-description - (:make-load-form-fun just-dump-it-normally) - (:conc-name dsd-) - (:copier nil) - #-sb-xc-host (:pure t)) + (:make-load-form-fun just-dump-it-normally) + (:conc-name dsd-) + (:copier nil) + #-sb-xc-host (:pure t)) ;; name of slot name ;; its position in the implementation sequence @@ -182,8 +182,8 @@ ;; shadow)") but that behavior doesn't seem to be specified by (or ;; even particularly consistent with) ANSI, so it's gone in SBCL.) (accessor-name nil) - default ; default value expression - (type t) ; declared type specifier + default ; default value expression + (type t) ; declared type specifier (safe-p t :type boolean) ; whether the slot is known to be ; always of the specified type ;; If this object does not describe a raw slot, this value is T. @@ -191,10 +191,10 @@ ;; If this object describes a raw slot, this value is the type of the ;; value that the raw slot holds. (raw-type t :type (member t single-float double-float - #!+long-float long-float - complex-single-float complex-double-float - #!+long-float complex-long-float - sb!vm:word)) + #!+long-float long-float + complex-single-float complex-double-float + #!+long-float complex-long-float + sb!vm:word)) (read-only nil :type (member t nil))) (def!method print-object ((x defstruct-slot-description) stream) (print-unreadable-object (x stream :type t) @@ -239,46 +239,46 @@ nil #!-hppa (let ((double-float-alignment - ;; white list of architectures that can load unaligned doubles: - #!+(or x86 x86-64 ppc) 1 - ;; at least sparc, mips and alpha can't: - #!-(or x86 x86-64 ppc) 2)) + ;; white list of architectures that can load unaligned doubles: + #!+(or x86 x86-64 ppc) 1 + ;; at least sparc, mips and alpha can't: + #!-(or x86 x86-64 ppc) 2)) (list (make-raw-slot-data :raw-type 'sb!vm:word - :accessor-name '%raw-instance-ref/word - :n-words 1) + :accessor-name '%raw-instance-ref/word + :n-words 1) (make-raw-slot-data :raw-type 'single-float - :accessor-name '%raw-instance-ref/single - ;; KLUDGE: On 64 bit architectures, we - ;; could pack two SINGLE-FLOATs into the - ;; same word if raw slots were indexed - ;; using bytes instead of words. However, - ;; I don't personally find optimizing - ;; SINGLE-FLOAT memory usage worthwile - ;; enough. And the other datatype that - ;; would really benefit is (UNSIGNED-BYTE - ;; 32), but that is a subtype of FIXNUM, so - ;; we store it unraw anyway. :-( -- DFL - :n-words 1) + :accessor-name '%raw-instance-ref/single + ;; KLUDGE: On 64 bit architectures, we + ;; could pack two SINGLE-FLOATs into the + ;; same word if raw slots were indexed + ;; using bytes instead of words. However, + ;; I don't personally find optimizing + ;; SINGLE-FLOAT memory usage worthwile + ;; enough. And the other datatype that + ;; would really benefit is (UNSIGNED-BYTE + ;; 32), but that is a subtype of FIXNUM, so + ;; we store it unraw anyway. :-( -- DFL + :n-words 1) (make-raw-slot-data :raw-type 'double-float - :accessor-name '%raw-instance-ref/double - :alignment double-float-alignment - :n-words (/ 8 sb!vm:n-word-bytes)) + :accessor-name '%raw-instance-ref/double + :alignment double-float-alignment + :n-words (/ 8 sb!vm:n-word-bytes)) (make-raw-slot-data :raw-type 'complex-single-float - :accessor-name '%raw-instance-ref/complex-single - :n-words (/ 8 sb!vm:n-word-bytes)) + :accessor-name '%raw-instance-ref/complex-single + :n-words (/ 8 sb!vm:n-word-bytes)) (make-raw-slot-data :raw-type 'complex-double-float - :accessor-name '%raw-instance-ref/complex-double - :alignment double-float-alignment - :n-words (/ 16 sb!vm:n-word-bytes)) + :accessor-name '%raw-instance-ref/complex-double + :alignment double-float-alignment + :n-words (/ 16 sb!vm:n-word-bytes)) #!+long-float (make-raw-slot-data :raw-type long-float - :accessor-name '%raw-instance-ref/long - :n-words #!+x86 3 #!+sparc 4) + :accessor-name '%raw-instance-ref/long + :n-words #!+x86 3 #!+sparc 4) #!+long-float (make-raw-slot-data :raw-type complex-long-float - :accessor-name '%raw-instance-ref/complex-long - :n-words #!+x86 6 #!+sparc 8))))) + :accessor-name '%raw-instance-ref/complex-long + :n-words #!+x86 6 #!+sparc 8))))) ;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its ;;;; close personal friend SB!XC:DEFSTRUCT) @@ -288,105 +288,105 @@ (defun class-method-definitions (defstruct) (let ((name (dd-name defstruct))) `((locally - ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant - ;; class names which creates fast but non-cold-loadable, - ;; non-compact code. In this context, we'd rather have - ;; compact, cold-loadable code. -- WHN 19990928 - (declare (notinline find-classoid)) - ,@(let ((pf (dd-print-function defstruct)) - (po (dd-print-object defstruct)) - (x (gensym)) - (s (gensym))) - ;; Giving empty :PRINT-OBJECT or :PRINT-FUNCTION options - ;; leaves PO or PF equal to NIL. The user-level effect is - ;; to generate a PRINT-OBJECT method specialized for the type, - ;; implementing the default #S structure-printing behavior. - (when (or (eq pf nil) (eq po nil)) - (setf pf '(default-structure-print) - po 0)) - (flet (;; Given an arg from a :PRINT-OBJECT or :PRINT-FUNCTION - ;; option, return the value to pass as an arg to FUNCTION. - (farg (oarg) - (destructuring-bind (fun-name) oarg - fun-name))) - (cond ((not (eql pf 0)) - `((def!method print-object ((,x ,name) ,s) - (funcall #',(farg pf) - ,x - ,s - *current-level-in-print*)))) - ((not (eql po 0)) - `((def!method print-object ((,x ,name) ,s) - (funcall #',(farg po) ,x ,s)))) - (t nil)))) - ,@(let ((pure (dd-pure defstruct))) - (cond ((eq pure t) - `((setf (layout-pure (classoid-layout - (find-classoid ',name))) - t))) - ((eq pure :substructure) - `((setf (layout-pure (classoid-layout - (find-classoid ',name))) - 0))))) - ,@(let ((def-con (dd-default-constructor defstruct))) - (when (and def-con (not (dd-alternate-metaclass defstruct))) - `((setf (structure-classoid-constructor (find-classoid ',name)) - #',def-con)))))))) + ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant + ;; class names which creates fast but non-cold-loadable, + ;; non-compact code. In this context, we'd rather have + ;; compact, cold-loadable code. -- WHN 19990928 + (declare (notinline find-classoid)) + ,@(let ((pf (dd-print-function defstruct)) + (po (dd-print-object defstruct)) + (x (gensym)) + (s (gensym))) + ;; Giving empty :PRINT-OBJECT or :PRINT-FUNCTION options + ;; leaves PO or PF equal to NIL. The user-level effect is + ;; to generate a PRINT-OBJECT method specialized for the type, + ;; implementing the default #S structure-printing behavior. + (when (or (eq pf nil) (eq po nil)) + (setf pf '(default-structure-print) + po 0)) + (flet (;; Given an arg from a :PRINT-OBJECT or :PRINT-FUNCTION + ;; option, return the value to pass as an arg to FUNCTION. + (farg (oarg) + (destructuring-bind (fun-name) oarg + fun-name))) + (cond ((not (eql pf 0)) + `((def!method print-object ((,x ,name) ,s) + (funcall #',(farg pf) + ,x + ,s + *current-level-in-print*)))) + ((not (eql po 0)) + `((def!method print-object ((,x ,name) ,s) + (funcall #',(farg po) ,x ,s)))) + (t nil)))) + ,@(let ((pure (dd-pure defstruct))) + (cond ((eq pure t) + `((setf (layout-pure (classoid-layout + (find-classoid ',name))) + t))) + ((eq pure :substructure) + `((setf (layout-pure (classoid-layout + (find-classoid ',name))) + 0))))) + ,@(let ((def-con (dd-default-constructor defstruct))) + (when (and def-con (not (dd-alternate-metaclass defstruct))) + `((setf (structure-classoid-constructor (find-classoid ',name)) + #',def-con)))))))) ;;; shared logic for CL:DEFSTRUCT and SB!XC:DEFSTRUCT (defmacro !expander-for-defstruct (name-and-options - slot-descriptions - expanding-into-code-for-xc-host-p) + slot-descriptions + expanding-into-code-for-xc-host-p) `(let ((name-and-options ,name-and-options) - (slot-descriptions ,slot-descriptions) - (expanding-into-code-for-xc-host-p - ,expanding-into-code-for-xc-host-p)) + (slot-descriptions ,slot-descriptions) + (expanding-into-code-for-xc-host-p + ,expanding-into-code-for-xc-host-p)) (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions - name-and-options - slot-descriptions)) - (name (dd-name dd))) + name-and-options + slot-descriptions)) + (name (dd-name dd))) (if (dd-class-p dd) - (let ((inherits (inherits-for-structure dd))) - `(progn - ;; Note we intentionally enforce package locks and - ;; call %DEFSTRUCT first, and especially before - ;; %COMPILER-DEFSTRUCT. %DEFSTRUCT has the tests (and - ;; resulting CERROR) for collisions with LAYOUTs which - ;; already exist in the runtime. If there are any - ;; collisions, we want the user's response to CERROR - ;; to control what happens. Especially, if the user - ;; responds to the collision with ABORT, we don't want - ;; %COMPILER-DEFSTRUCT to modify the definition of the - ;; class. - (with-single-package-locked-error - (:symbol ',name "defining ~A as a structure")) - (%defstruct ',dd ',inherits) - (eval-when (:compile-toplevel :load-toplevel :execute) - (%compiler-defstruct ',dd ',inherits)) - ,@(unless expanding-into-code-for-xc-host-p - (append ;; FIXME: We've inherited from CMU CL nonparallel - ;; code for creating copiers for typed and untyped - ;; structures. This should be fixed. - ;(copier-definition dd) - (constructor-definitions dd) - (class-method-definitions dd))) - ',name)) - `(progn - (with-single-package-locked-error - (:symbol ',name "defining ~A as a structure")) - (eval-when (:compile-toplevel :load-toplevel :execute) - (setf (info :typed-structure :info ',name) ',dd)) - ,@(unless expanding-into-code-for-xc-host-p - (append (typed-accessor-definitions dd) - (typed-predicate-definitions dd) - (typed-copier-definitions dd) - (constructor-definitions dd))) - ',name))))) + (let ((inherits (inherits-for-structure dd))) + `(progn + ;; Note we intentionally enforce package locks and + ;; call %DEFSTRUCT first, and especially before + ;; %COMPILER-DEFSTRUCT. %DEFSTRUCT has the tests (and + ;; resulting CERROR) for collisions with LAYOUTs which + ;; already exist in the runtime. If there are any + ;; collisions, we want the user's response to CERROR + ;; to control what happens. Especially, if the user + ;; responds to the collision with ABORT, we don't want + ;; %COMPILER-DEFSTRUCT to modify the definition of the + ;; class. + (with-single-package-locked-error + (:symbol ',name "defining ~A as a structure")) + (%defstruct ',dd ',inherits) + (eval-when (:compile-toplevel :load-toplevel :execute) + (%compiler-defstruct ',dd ',inherits)) + ,@(unless expanding-into-code-for-xc-host-p + (append ;; FIXME: We've inherited from CMU CL nonparallel + ;; code for creating copiers for typed and untyped + ;; structures. This should be fixed. + ;(copier-definition dd) + (constructor-definitions dd) + (class-method-definitions dd))) + ',name)) + `(progn + (with-single-package-locked-error + (:symbol ',name "defining ~A as a structure")) + (eval-when (:compile-toplevel :load-toplevel :execute) + (setf (info :typed-structure :info ',name) ',dd)) + ,@(unless expanding-into-code-for-xc-host-p + (append (typed-accessor-definitions dd) + (typed-predicate-definitions dd) + (typed-copier-definitions dd) + (constructor-definitions dd))) + ',name))))) (sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions) #!+sb-doc "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)} - Define the structure type Name. Instances are created by MAKE-, + Define the structure type Name. Instances are created by MAKE-, which takes &KEY arguments allowing initial slot values to the specified. A SETF'able function - is defined for each slot to read and write slot values. -p is a type predicate. @@ -431,25 +431,25 @@ ;;; typed DEFSTRUCT. (defun typed-predicate-definitions (defstruct) (let ((name (dd-name defstruct)) - (predicate-name (dd-predicate-name defstruct)) - (argname (gensym))) + (predicate-name (dd-predicate-name defstruct)) + (argname (gensym))) (when (and predicate-name (dd-named defstruct)) (let ((ltype (dd-lisp-type defstruct)) - (name-index (cdr (car (last (find-name-indices defstruct)))))) - `((defun ,predicate-name (,argname) - (and (typep ,argname ',ltype) - ,(cond - ((subtypep ltype 'list) + (name-index (cdr (car (last (find-name-indices defstruct)))))) + `((defun ,predicate-name (,argname) + (and (typep ,argname ',ltype) + ,(cond + ((subtypep ltype 'list) `(do ((head (the ,ltype ,argname) (cdr head)) - (i 0 (1+ i))) - ((or (not (consp head)) (= i ,name-index)) - (and (consp head) (eq ',name (car head)))))) - ((subtypep ltype 'vector) - `(and (= (length (the ,ltype ,argname)) - ,(dd-length defstruct)) - (eq ',name (aref (the ,ltype ,argname) ,name-index)))) - (t (bug "Uncatered-for lisp type in typed DEFSTRUCT: ~S." - ltype)))))))))) + (i 0 (1+ i))) + ((or (not (consp head)) (= i ,name-index)) + (and (consp head) (eq ',name (car head)))))) + ((subtypep ltype 'vector) + `(and (= (length (the ,ltype ,argname)) + ,(dd-length defstruct)) + (eq ',name (aref (the ,ltype ,argname) ,name-index)))) + (t (bug "Uncatered-for lisp type in typed DEFSTRUCT: ~S." + ltype)))))))))) ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT. (defun typed-copier-definitions (defstruct) @@ -465,28 +465,28 @@ (collect ((stuff)) (let ((ltype (dd-lisp-type defstruct))) (dolist (slot (dd-slots defstruct)) - (let ((name (dsd-accessor-name slot)) - (index (dsd-index slot)) - (slot-type `(and ,(dsd-type slot) - ,(dd-element-type defstruct)))) - (let ((inherited (accessor-inherited-data name defstruct))) - (cond - ((not inherited) - (stuff `(declaim (inline ,name (setf ,name)))) - ;; FIXME: The arguments in the next two DEFUNs should - ;; be gensyms. (Otherwise e.g. if NEW-VALUE happened to - ;; be the name of a special variable, things could get - ;; weird.) - (stuff `(defun ,name (structure) - (declare (type ,ltype structure)) - (the ,slot-type (elt structure ,index)))) - (unless (dsd-read-only slot) - (stuff - `(defun (setf ,name) (new-value structure) - (declare (type ,ltype structure) (type ,slot-type new-value)) - (setf (elt structure ,index) new-value))))) - ((not (= (cdr inherited) index)) - (style-warn "~@" name (dsd-name slot)))))))) (stuff))) @@ -495,66 +495,66 @@ (defun require-no-print-options-so-far (defstruct) (unless (and (eql (dd-print-function defstruct) 0) - (eql (dd-print-object defstruct) 0)) + (eql (dd-print-object defstruct) 0)) (error "No more than one of the following options may be specified: :PRINT-FUNCTION, :PRINT-OBJECT, :TYPE"))) ;;; Parse a single DEFSTRUCT option and store the results in DD. (defun parse-1-dd-option (option dd) (let ((args (rest option)) - (name (dd-name dd))) + (name (dd-name dd))) (case (first option) (:conc-name (destructuring-bind (&optional conc-name) args - (setf (dd-conc-name dd) - (if (symbolp conc-name) - conc-name - (make-symbol (string conc-name)))))) + (setf (dd-conc-name dd) + (if (symbolp conc-name) + conc-name + (make-symbol (string conc-name)))))) (:constructor (destructuring-bind (&optional (cname (symbolicate "MAKE-" name)) - &rest stuff) - args - (push (cons cname stuff) (dd-constructors dd)))) + &rest stuff) + args + (push (cons cname stuff) (dd-constructors dd)))) (:copier (destructuring-bind (&optional (copier (symbolicate "COPY-" name))) - args - (setf (dd-copier-name dd) copier))) + args + (setf (dd-copier-name dd) copier))) (:predicate (destructuring-bind (&optional (predicate-name (symbolicate name "-P"))) - args - (setf (dd-predicate-name dd) predicate-name))) + args + (setf (dd-predicate-name dd) predicate-name))) (:include (when (dd-include dd) - (error "more than one :INCLUDE option")) + (error "more than one :INCLUDE option")) (setf (dd-include dd) args)) (:print-function (require-no-print-options-so-far dd) (setf (dd-print-function dd) - (the (or symbol cons) args))) + (the (or symbol cons) args))) (:print-object (require-no-print-options-so-far dd) (setf (dd-print-object dd) - (the (or symbol cons) args))) + (the (or symbol cons) args))) (:type (destructuring-bind (type) args - (cond ((member type '(list vector)) - (setf (dd-element-type dd) t) - (setf (dd-type dd) type)) - ((and (consp type) (eq (first type) 'vector)) - (destructuring-bind (vector vtype) type - (declare (ignore vector)) - (setf (dd-element-type dd) vtype) - (setf (dd-type dd) 'vector))) - (t - (error "~S is a bad :TYPE for DEFSTRUCT." type))))) + (cond ((member type '(list vector)) + (setf (dd-element-type dd) t) + (setf (dd-type dd) type)) + ((and (consp type) (eq (first type) 'vector)) + (destructuring-bind (vector vtype) type + (declare (ignore vector)) + (setf (dd-element-type dd) vtype) + (setf (dd-type dd) 'vector))) + (t + (error "~S is a bad :TYPE for DEFSTRUCT." type))))) (:named (error "The DEFSTRUCT option :NAMED takes no arguments.")) (:initial-offset (destructuring-bind (offset) args - (setf (dd-offset dd) offset))) + (setf (dd-offset dd) offset))) (:pure (destructuring-bind (fun) args - (setf (dd-pure dd) fun))) + (setf (dd-pure dd) fun))) (t (error "unknown DEFSTRUCT option:~% ~S" option))))) ;;; Given name and options, return a DD holding that info. @@ -563,36 +563,36 @@ (aver name) ; A null name doesn't seem to make sense here. (let ((dd (make-defstruct-description name))) (dolist (option options) - (cond ((eq option :named) - (setf (dd-named dd) t)) - ((consp option) - (parse-1-dd-option option dd)) - ((member option '(:conc-name :constructor :copier :predicate)) - (parse-1-dd-option (list option) dd)) - (t - (error "unrecognized DEFSTRUCT option: ~S" option)))) + (cond ((eq option :named) + (setf (dd-named dd) t)) + ((consp option) + (parse-1-dd-option option dd)) + ((member option '(:conc-name :constructor :copier :predicate)) + (parse-1-dd-option (list option) dd)) + (t + (error "unrecognized DEFSTRUCT option: ~S" option)))) (case (dd-type dd) - (structure - (when (dd-offset dd) - (error ":OFFSET can't be specified unless :TYPE is specified.")) - (unless (dd-include dd) - ;; FIXME: It'd be cleaner to treat no-:INCLUDE as defaulting - ;; to :INCLUDE STRUCTURE-OBJECT, and then let the general-case - ;; (INCF (DD-LENGTH DD) (DD-LENGTH included-DD)) logic take - ;; care of this. (Except that the :TYPE VECTOR and :TYPE - ;; LIST cases, with their :NAMED and un-:NAMED flavors, - ;; make that messy, alas.) - (incf (dd-length dd)))) - (t - (require-no-print-options-so-far dd) - (when (dd-named dd) - (incf (dd-length dd))) - (let ((offset (dd-offset dd))) - (when offset (incf (dd-length dd) offset))))) + (structure + (when (dd-offset dd) + (error ":OFFSET can't be specified unless :TYPE is specified.")) + (unless (dd-include dd) + ;; FIXME: It'd be cleaner to treat no-:INCLUDE as defaulting + ;; to :INCLUDE STRUCTURE-OBJECT, and then let the general-case + ;; (INCF (DD-LENGTH DD) (DD-LENGTH included-DD)) logic take + ;; care of this. (Except that the :TYPE VECTOR and :TYPE + ;; LIST cases, with their :NAMED and un-:NAMED flavors, + ;; make that messy, alas.) + (incf (dd-length dd)))) + (t + (require-no-print-options-so-far dd) + (when (dd-named dd) + (incf (dd-length dd))) + (let ((offset (dd-offset dd))) + (when offset (incf (dd-length dd) offset))))) (when (dd-include dd) - (frob-dd-inclusion-stuff dd)) + (frob-dd-inclusion-stuff dd)) dd))) @@ -602,8 +602,8 @@ (defun parse-defstruct-name-and-options-and-slot-descriptions (name-and-options slot-descriptions) (let ((result (parse-defstruct-name-and-options (if (atom name-and-options) - (list name-and-options) - name-and-options)))) + (list name-and-options) + name-and-options)))) (when (stringp (car slot-descriptions)) (setf (dd-doc result) (pop slot-descriptions))) (dolist (slot-description slot-descriptions) @@ -617,62 +617,62 @@ ;;; that we modify to get the new slot. This is supplied when handling ;;; included slots. (defun parse-1-dsd (defstruct spec &optional - (slot (make-defstruct-slot-description :name "" - :index 0 - :type t))) + (slot (make-defstruct-slot-description :name "" + :index 0 + :type t))) (multiple-value-bind (name default default-p type type-p read-only ro-p) (typecase spec - (symbol - (when (keywordp spec) - (style-warn "Keyword slot name indicates probable syntax ~ + (symbol + (when (keywordp spec) + (style-warn "Keyword slot name indicates probable syntax ~ error in DEFSTRUCT: ~S." - spec)) - spec) - (cons - (destructuring-bind - (name - &optional (default nil default-p) - &key (type nil type-p) (read-only nil ro-p)) - spec - (values name - default default-p - (uncross type) type-p - read-only ro-p))) - (t (error 'simple-program-error - :format-control "in DEFSTRUCT, ~S is not a legal slot ~ + spec)) + spec) + (cons + (destructuring-bind + (name + &optional (default nil default-p) + &key (type nil type-p) (read-only nil ro-p)) + spec + (values name + default default-p + (uncross type) type-p + read-only ro-p))) + (t (error 'simple-program-error + :format-control "in DEFSTRUCT, ~S is not a legal slot ~ description." - :format-arguments (list spec)))) + :format-arguments (list spec)))) (when (find name (dd-slots defstruct) - :test #'string= - :key (lambda (x) (symbol-name (dsd-name x)))) + :test #'string= + :key (lambda (x) (symbol-name (dsd-name x)))) (error 'simple-program-error - :format-control "duplicate slot name ~S" - :format-arguments (list name))) + :format-control "duplicate slot name ~S" + :format-arguments (list name))) (setf (dsd-name slot) name) (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list slot))) (let ((accessor-name (if (dd-conc-name defstruct) - (symbolicate (dd-conc-name defstruct) name) - name)) - (predicate-name (dd-predicate-name defstruct))) + (symbolicate (dd-conc-name defstruct) name) + name)) + (predicate-name (dd-predicate-name defstruct))) (setf (dsd-accessor-name slot) accessor-name) (when (eql accessor-name predicate-name) - ;; Some adventurous soul has named a slot so that its accessor - ;; collides with the structure type predicate. ANSI doesn't - ;; specify what to do in this case. As of 2001-09-04, Martin - ;; Atzmueller reports that CLISP and Lispworks both give - ;; priority to the slot accessor, so that the predicate is - ;; overwritten. We might as well do the same (as well as - ;; signalling a warning). - (style-warn - "~@" - accessor-name) - (setf (dd-predicate-name defstruct) nil)) + accessor-name) + (setf (dd-predicate-name defstruct) nil)) ;; FIXME: It would be good to check for name collisions here, but ;; the easy check, ;;x#-sb-xc-host @@ -684,21 +684,21 @@ ;; occur not just because the code was constructed, but because it ;; is actually compiled or loaded. ) - + (when default-p (setf (dsd-default slot) default)) (when type-p (setf (dsd-type slot) - (if (eq (dsd-type slot) t) - type - `(and ,(dsd-type slot) ,type)))) + (if (eq (dsd-type slot) t) + type + `(and ,(dsd-type slot) ,type)))) (when ro-p (if read-only - (setf (dsd-read-only slot) t) - (when (dsd-read-only slot) - (error "~@" - (dsd-name slot))))) + (dsd-name slot))))) slot)) ;;; When a value of type TYPE is stored in a structure, should it be @@ -713,31 +713,31 @@ ;; putting INDEX-typed values into raw slots if we didn't test ;; FIXNUM-CERTAIN?.) (if (or fixnum? (not fixnum-certain?)) - nil - (dolist (data *raw-slot-data-list*) - (when (sb!xc:subtypep type (raw-slot-data-raw-type data)) - (return data)))))) + nil + (dolist (data *raw-slot-data-list*) + (when (sb!xc:subtypep type (raw-slot-data-raw-type data)) + (return data)))))) ;;; Allocate storage for a DSD in DD. This is where we decide whether ;;; a slot is raw or not. Raw objects are aligned on the unit of their size. (defun allocate-1-slot (dd dsd) (let ((rsd - (if (eq (dd-type dd) 'structure) - (structure-raw-slot-data (dsd-type dsd)) - nil))) + (if (eq (dd-type dd) 'structure) + (structure-raw-slot-data (dsd-type dsd)) + nil))) (cond ((null rsd) - (setf (dsd-index dsd) (dd-length dd)) - (incf (dd-length dd))) + (setf (dsd-index dsd) (dd-length dd)) + (incf (dd-length dd))) (t - (let* ((words (raw-slot-data-n-words rsd)) - (alignment (raw-slot-data-alignment rsd)) - (off (rem (dd-raw-length dd) alignment))) - (unless (zerop off) - (incf (dd-raw-length dd) (- alignment off))) - (setf (dsd-raw-type dsd) (raw-slot-data-raw-type rsd)) - (setf (dsd-index dsd) (dd-raw-length dd)) - (incf (dd-raw-length dd) words))))) + (let* ((words (raw-slot-data-n-words rsd)) + (alignment (raw-slot-data-alignment rsd)) + (off (rem (dd-raw-length dd) alignment))) + (unless (zerop off) + (incf (dd-raw-length dd) (- alignment off))) + (setf (dsd-raw-type dsd) (raw-slot-data-raw-type rsd)) + (setf (dsd-index dsd) (dd-raw-length dd)) + (incf (dd-raw-length dd) words))))) (values)) (defun typed-structure-info-or-lose (name) @@ -749,70 +749,70 @@ (defun frob-dd-inclusion-stuff (dd) (destructuring-bind (included-name &rest modified-slots) (dd-include dd) (let* ((type (dd-type dd)) - (included-structure - (if (dd-class-p dd) - (layout-info (compiler-layout-or-lose included-name)) - (typed-structure-info-or-lose included-name)))) + (included-structure + (if (dd-class-p dd) + (layout-info (compiler-layout-or-lose included-name)) + (typed-structure-info-or-lose included-name)))) ;; checks on legality (unless (and (eq type (dd-type included-structure)) - (type= (specifier-type (dd-element-type included-structure)) - (specifier-type (dd-element-type dd)))) - (error ":TYPE option mismatch between structures ~S and ~S" - (dd-name dd) included-name)) + (type= (specifier-type (dd-element-type included-structure)) + (specifier-type (dd-element-type dd)))) + (error ":TYPE option mismatch between structures ~S and ~S" + (dd-name dd) included-name)) (let ((included-classoid (find-classoid included-name nil))) - (when included-classoid - ;; It's not particularly well-defined to :INCLUDE any of the - ;; CMU CL INSTANCE weirdosities like CONDITION or - ;; GENERIC-FUNCTION, and it's certainly not ANSI-compliant. - (let* ((included-layout (classoid-layout included-classoid)) - (included-dd (layout-info included-layout))) - (when (and (dd-alternate-metaclass included-dd) - ;; As of sbcl-0.pre7.73, anyway, STRUCTURE-OBJECT - ;; is represented with an ALTERNATE-METACLASS. But - ;; it's specifically OK to :INCLUDE (and PCL does) - ;; so in this one case, it's OK to include - ;; something with :ALTERNATE-METACLASS after all. - (not (eql included-name 'structure-object))) - (error "can't :INCLUDE class ~S (has alternate metaclass)" - included-name))))) + (when included-classoid + ;; It's not particularly well-defined to :INCLUDE any of the + ;; CMU CL INSTANCE weirdosities like CONDITION or + ;; GENERIC-FUNCTION, and it's certainly not ANSI-compliant. + (let* ((included-layout (classoid-layout included-classoid)) + (included-dd (layout-info included-layout))) + (when (and (dd-alternate-metaclass included-dd) + ;; As of sbcl-0.pre7.73, anyway, STRUCTURE-OBJECT + ;; is represented with an ALTERNATE-METACLASS. But + ;; it's specifically OK to :INCLUDE (and PCL does) + ;; so in this one case, it's OK to include + ;; something with :ALTERNATE-METACLASS after all. + (not (eql included-name 'structure-object))) + (error "can't :INCLUDE class ~S (has alternate metaclass)" + included-name))))) (incf (dd-length dd) (dd-length included-structure)) (when (dd-class-p dd) - (let ((mc (rest (dd-alternate-metaclass included-structure)))) - (when (and mc (not (dd-alternate-metaclass dd))) - (setf (dd-alternate-metaclass dd) - (cons included-name mc)))) - (when (eq (dd-pure dd) :unspecified) - (setf (dd-pure dd) (dd-pure included-structure))) - (setf (dd-raw-length dd) (dd-raw-length included-structure))) + (let ((mc (rest (dd-alternate-metaclass included-structure)))) + (when (and mc (not (dd-alternate-metaclass dd))) + (setf (dd-alternate-metaclass dd) + (cons included-name mc)))) + (when (eq (dd-pure dd) :unspecified) + (setf (dd-pure dd) (dd-pure included-structure))) + (setf (dd-raw-length dd) (dd-raw-length included-structure))) (setf (dd-inherited-accessor-alist dd) - (dd-inherited-accessor-alist included-structure)) + (dd-inherited-accessor-alist included-structure)) (dolist (included-slot (dd-slots included-structure)) - (let* ((included-name (dsd-name included-slot)) - (modified (or (find included-name modified-slots - :key (lambda (x) (if (atom x) x (car x))) - :test #'string=) - `(,included-name)))) - ;; We stash away an alist of accessors to parents' slots - ;; that have already been created to avoid conflicts later - ;; so that structures with :INCLUDE and :CONC-NAME (and - ;; other edge cases) can work as specified. - (when (dsd-accessor-name included-slot) - ;; the "oldest" (i.e. highest up the tree of inheritance) - ;; will prevail, so don't push new ones on if they - ;; conflict. - (pushnew (cons (dsd-accessor-name included-slot) - (dsd-index included-slot)) - (dd-inherited-accessor-alist dd) - :test #'eq :key #'car)) - (let ((new-slot (parse-1-dsd dd + (let* ((included-name (dsd-name included-slot)) + (modified (or (find included-name modified-slots + :key (lambda (x) (if (atom x) x (car x))) + :test #'string=) + `(,included-name)))) + ;; We stash away an alist of accessors to parents' slots + ;; that have already been created to avoid conflicts later + ;; so that structures with :INCLUDE and :CONC-NAME (and + ;; other edge cases) can work as specified. + (when (dsd-accessor-name included-slot) + ;; the "oldest" (i.e. highest up the tree of inheritance) + ;; will prevail, so don't push new ones on if they + ;; conflict. + (pushnew (cons (dsd-accessor-name included-slot) + (dsd-index included-slot)) + (dd-inherited-accessor-alist dd) + :test #'eq :key #'car)) + (let ((new-slot (parse-1-dsd dd modified (copy-structure included-slot)))) (when (and (neq (dsd-type new-slot) (dsd-type included-slot)) (not (sb!xc:subtypep (dsd-type included-slot) - (dsd-type new-slot))) + (dsd-type new-slot))) (dsd-safe-p included-slot)) (setf (dsd-safe-p new-slot) nil) ;; XXX: notify? @@ -825,33 +825,33 @@ (defun inherits-for-structure (info) (declare (type defstruct-description info)) (let* ((include (dd-include info)) - (superclass-opt (dd-alternate-metaclass info)) - (super - (if include - (compiler-layout-or-lose (first include)) - (classoid-layout (find-classoid - (or (first superclass-opt) - 'structure-object)))))) + (superclass-opt (dd-alternate-metaclass info)) + (super + (if include + (compiler-layout-or-lose (first include)) + (classoid-layout (find-classoid + (or (first superclass-opt) + 'structure-object)))))) (case (dd-name info) ((ansi-stream) (concatenate 'simple-vector - (layout-inherits super) - (vector super (classoid-layout (find-classoid 'stream))))) + (layout-inherits super) + (vector super (classoid-layout (find-classoid 'stream))))) ((fd-stream) (concatenate 'simple-vector - (layout-inherits super) - (vector super - (classoid-layout (find-classoid 'file-stream))))) - ((sb!impl::string-input-stream - sb!impl::string-output-stream - sb!impl::fill-pointer-output-stream) + (layout-inherits super) + (vector super + (classoid-layout (find-classoid 'file-stream))))) + ((sb!impl::string-input-stream + sb!impl::string-output-stream + sb!impl::fill-pointer-output-stream) (concatenate 'simple-vector - (layout-inherits super) - (vector super - (classoid-layout (find-classoid 'string-stream))))) - (t (concatenate 'simple-vector - (layout-inherits super) - (vector super)))))) + (layout-inherits super) + (vector super + (classoid-layout (find-classoid 'string-stream))))) + (t (concatenate 'simple-vector + (layout-inherits super) + (vector super)))))) ;;; Do miscellaneous (LOAD EVAL) time actions for the structure ;;; described by DD. Create the class and LAYOUT, checking for @@ -865,17 +865,17 @@ (multiple-value-bind (classoid layout old-layout) (ensure-structure-class dd inherits "current" "new") (cond ((not old-layout) - (unless (eq (classoid-layout classoid) layout) - (register-layout layout))) - (t - (let ((old-dd (layout-info old-layout))) - (when (defstruct-description-p old-dd) - (dolist (slot (dd-slots old-dd)) - (fmakunbound (dsd-accessor-name slot)) - (unless (dsd-read-only slot) - (fmakunbound `(setf ,(dsd-accessor-name slot))))))) - (%redefine-defstruct classoid old-layout layout) - (setq layout (classoid-layout classoid)))) + (unless (eq (classoid-layout classoid) layout) + (register-layout layout))) + (t + (let ((old-dd (layout-info old-layout))) + (when (defstruct-description-p old-dd) + (dolist (slot (dd-slots old-dd)) + (fmakunbound (dsd-accessor-name slot)) + (unless (dsd-read-only slot) + (fmakunbound `(setf ,(dsd-accessor-name slot))))))) + (%redefine-defstruct classoid old-layout layout) + (setq layout (classoid-layout classoid)))) (setf (find-classoid (dd-name dd)) classoid) ;; Various other operations only make sense on the target SBCL. @@ -888,18 +888,18 @@ ;;; in the instance named INSTANCE-NAME. (defun %accessor-place-form (dd dsd instance-name) (let (;; the operator that we'll use to access a typed slot - (ref (ecase (dd-type dd) - (structure '%instance-ref) - (list 'nth-but-with-sane-arg-order) - (vector 'aref))) - (raw-type (dsd-raw-type dsd))) + (ref (ecase (dd-type dd) + (structure '%instance-ref) + (list 'nth-but-with-sane-arg-order) + (vector 'aref))) + (raw-type (dsd-raw-type dsd))) (if (eq raw-type t) ; if not raw slot - `(,ref ,instance-name ,(dsd-index dsd)) - (let* ((raw-slot-data (find raw-type *raw-slot-data-list* - :key #'raw-slot-data-raw-type - :test #'equal)) - (raw-slot-accessor (raw-slot-data-accessor-name raw-slot-data))) - `(,raw-slot-accessor ,instance-name ,(dsd-index dsd)))))) + `(,ref ,instance-name ,(dsd-index dsd)) + (let* ((raw-slot-data (find raw-type *raw-slot-data-list* + :key #'raw-slot-data-raw-type + :test #'equal)) + (raw-slot-accessor (raw-slot-data-accessor-name raw-slot-data))) + `(,raw-slot-accessor ,instance-name ,(dsd-index dsd)))))) ;;; Return source transforms for the reader and writer functions of ;;; the slot described by DSD. They should be inline expanded, but @@ -930,41 +930,41 @@ ;;; core compile-time setup of any class with a LAYOUT, used even by ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities (defun %compiler-set-up-layout (dd - &optional - ;; Several special cases (STRUCTURE-OBJECT - ;; itself, and structures with alternate - ;; metaclasses) call this function directly, - ;; and they're all at the base of the - ;; instance class structure, so this is - ;; a handy default. - (inherits (vector (find-layout t) - (find-layout 'instance)))) + &optional + ;; Several special cases (STRUCTURE-OBJECT + ;; itself, and structures with alternate + ;; metaclasses) call this function directly, + ;; and they're all at the base of the + ;; instance class structure, so this is + ;; a handy default. + (inherits (vector (find-layout t) + (find-layout 'instance)))) (multiple-value-bind (classoid layout old-layout) (multiple-value-bind (clayout clayout-p) - (info :type :compiler-layout (dd-name dd)) - (ensure-structure-class dd - inherits - (if clayout-p "previously compiled" "current") - "compiled" - :compiler-layout clayout)) + (info :type :compiler-layout (dd-name dd)) + (ensure-structure-class dd + inherits + (if clayout-p "previously compiled" "current") + "compiled" + :compiler-layout clayout)) (cond (old-layout - (undefine-structure (layout-classoid old-layout)) - (when (and (classoid-subclasses classoid) - (not (eq layout old-layout))) - (collect ((subs)) - (dohash (classoid layout (classoid-subclasses classoid)) - (declare (ignore layout)) - (undefine-structure classoid) - (subs (classoid-proper-name classoid))) - (when (subs) - (warn "removing old subclasses of ~S:~% ~S" - (classoid-name classoid) - (subs)))))) - (t - (unless (eq (classoid-layout classoid) layout) - (register-layout layout :invalidate nil)) - (setf (find-classoid (dd-name dd)) classoid))) + (undefine-structure (layout-classoid old-layout)) + (when (and (classoid-subclasses classoid) + (not (eq layout old-layout))) + (collect ((subs)) + (dohash (classoid layout (classoid-subclasses classoid)) + (declare (ignore layout)) + (undefine-structure classoid) + (subs (classoid-proper-name classoid))) + (when (subs) + (warn "removing old subclasses of ~S:~% ~S" + (classoid-name classoid) + (subs)))))) + (t + (unless (eq (classoid-layout classoid) layout) + (register-layout layout :invalidate nil)) + (setf (find-classoid (dd-name dd)) classoid))) ;; At this point the class should be set up in the INFO database. ;; But the logic that enforces this is a little tangled and @@ -986,58 +986,58 @@ (let ((copier-name (dd-copier-name dd))) (when copier-name - (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dtype) ,copier-name)))) + (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dtype) ,copier-name)))) (let ((predicate-name (dd-predicate-name dd))) (when predicate-name - (sb!xc:proclaim `(ftype (sfunction (t) boolean) ,predicate-name)) - ;; Provide inline expansion (or not). - (ecase (dd-type dd) - ((structure funcallable-structure) - ;; Let the predicate be inlined. - (setf (info :function :inline-expansion-designator predicate-name) - (lambda () - `(lambda (x) - ;; This dead simple definition works because the - ;; type system knows how to generate inline type - ;; tests for instances. - (typep x ',(dd-name dd)))) - (info :function :inlinep predicate-name) - :inline)) - ((list vector) - ;; Just punt. We could provide inline expansions for :TYPE - ;; LIST and :TYPE VECTOR predicates too, but it'd be a - ;; little messier and we don't bother. (Does anyway use - ;; typed DEFSTRUCTs at all, let alone for high - ;; performance?) - )))) + (sb!xc:proclaim `(ftype (sfunction (t) boolean) ,predicate-name)) + ;; Provide inline expansion (or not). + (ecase (dd-type dd) + ((structure funcallable-structure) + ;; Let the predicate be inlined. + (setf (info :function :inline-expansion-designator predicate-name) + (lambda () + `(lambda (x) + ;; This dead simple definition works because the + ;; type system knows how to generate inline type + ;; tests for instances. + (typep x ',(dd-name dd)))) + (info :function :inlinep predicate-name) + :inline)) + ((list vector) + ;; Just punt. We could provide inline expansions for :TYPE + ;; LIST and :TYPE VECTOR predicates too, but it'd be a + ;; little messier and we don't bother. (Does anyway use + ;; typed DEFSTRUCTs at all, let alone for high + ;; performance?) + )))) (dolist (dsd (dd-slots dd)) (let* ((accessor-name (dsd-accessor-name dsd)) - (dsd-type (dsd-type dsd))) - (when accessor-name - (let ((inherited (accessor-inherited-data accessor-name dd))) - (cond - ((not inherited) - (multiple-value-bind (reader-designator writer-designator) - (slot-accessor-transforms dd dsd) - (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dsd-type) - ,accessor-name)) - (setf (info :function :source-transform accessor-name) - reader-designator) - (unless (dsd-read-only dsd) - (let ((setf-accessor-name `(setf ,accessor-name))) - (sb!xc:proclaim - `(ftype (sfunction (,dsd-type ,dtype) ,dsd-type) - ,setf-accessor-name)) - (setf (info :function :source-transform setf-accessor-name) - writer-designator))))) - ((not (= (cdr inherited) (dsd-index dsd))) - (style-warn "~@" - accessor-name - (dsd-name dsd))))))))) + accessor-name + (dsd-name dsd))))))))) (values)) ;;;; redefinition stuff @@ -1048,40 +1048,40 @@ ;;; 3. Deleted slots. (defun compare-slots (old new) (let* ((oslots (dd-slots old)) - (nslots (dd-slots new)) - (onames (mapcar #'dsd-name oslots)) - (nnames (mapcar #'dsd-name nslots))) + (nslots (dd-slots new)) + (onames (mapcar #'dsd-name oslots)) + (nnames (mapcar #'dsd-name nslots))) (collect ((moved) - (retyped)) + (retyped)) (dolist (name (intersection onames nnames)) - (let ((os (find name oslots :key #'dsd-name :test #'string=)) - (ns (find name nslots :key #'dsd-name :test #'string=))) - (unless (sb!xc:subtypep (dsd-type ns) (dsd-type os)) - (retyped name)) - (unless (and (= (dsd-index os) (dsd-index ns)) - (eq (dsd-raw-type os) (dsd-raw-type ns))) - (moved name)))) + (let ((os (find name oslots :key #'dsd-name :test #'string=)) + (ns (find name nslots :key #'dsd-name :test #'string=))) + (unless (sb!xc:subtypep (dsd-type ns) (dsd-type os)) + (retyped name)) + (unless (and (= (dsd-index os) (dsd-index ns)) + (eq (dsd-raw-type os) (dsd-raw-type ns))) + (moved name)))) (values (moved) - (retyped) - (set-difference onames nnames :test #'string=))))) + (retyped) + (set-difference onames nnames :test #'string=))))) ;;; If we are redefining a structure with different slots than in the ;;; currently loaded version, give a warning and return true. (defun redefine-structure-warning (classoid old new) (declare (type defstruct-description old new) - (type classoid classoid) - (ignore classoid)) + (type classoid classoid) + (ignore classoid)) (let ((name (dd-name new))) (multiple-value-bind (moved retyped deleted) (compare-slots old new) (when (or moved retyped deleted) - (warn - "incompatibly redefining slots of structure class ~S~@ + (warn + "incompatibly redefining slots of structure class ~S~@ Make sure any uses of affected accessors are recompiled:~@ ~@[ These slots were moved to new positions:~% ~S~%~]~ ~@[ These slots have new incompatible types:~% ~S~%~]~ ~@[ These slots were deleted:~% ~S~%~]" - name moved retyped deleted) - t)))) + name moved retyped deleted) + t)))) ;;; This function is called when we are incompatibly redefining a ;;; structure CLASS to have the specified NEW-LAYOUT. We signal an @@ -1089,40 +1089,40 @@ ;;; be used. (defun %redefine-defstruct (classoid old-layout new-layout) (declare (type classoid classoid) - (type layout old-layout new-layout)) + (type layout old-layout new-layout)) (let ((name (classoid-proper-name classoid))) (restart-case - (error "~@" - 'structure-object - name) + (error "~@" + 'structure-object + name) (continue () :report (lambda (s) - (format s - "~@" - name)) + name)) (register-layout new-layout)) (recklessly-continue () :report (lambda (s) - (format s - "~@" - name)) - ;; classic CMU CL warning: "Any old ~S instances will be in a bad way. + name)) + ;; classic CMU CL warning: "Any old ~S instances will be in a bad way. ;; I hope you know what you're doing..." (register-layout new-layout - :invalidate nil - :destruct-layout old-layout)) + :invalidate nil + :destruct-layout old-layout)) (clobber-it () ;; FIXME: deprecated 2002-10-16, and since it's only interactive ;; hackery instead of a supported feature, can probably be deleted ;; in early 2003 :report "(deprecated synonym for RECKLESSLY-CONTINUE)" (register-layout new-layout - :invalidate nil - :destruct-layout old-layout)))) + :invalidate nil + :destruct-layout old-layout)))) (values)) ;;; This is called when we are about to define a structure class. It @@ -1132,76 +1132,76 @@ ;;; value is true if this is an incompatible redefinition, in which ;;; case it is the old layout. (defun ensure-structure-class (info inherits old-context new-context - &key compiler-layout) + &key compiler-layout) (multiple-value-bind (class old-layout) (destructuring-bind - (&optional - name - (class 'structure-classoid) - (constructor 'make-structure-classoid)) - (dd-alternate-metaclass info) - (declare (ignore name)) - (insured-find-classoid (dd-name info) - (if (eq class 'structure-classoid) - (lambda (x) - (sb!xc:typep x 'structure-classoid)) - (lambda (x) - (sb!xc:typep x (find-classoid class)))) - (fdefinition constructor))) + (&optional + name + (class 'structure-classoid) + (constructor 'make-structure-classoid)) + (dd-alternate-metaclass info) + (declare (ignore name)) + (insured-find-classoid (dd-name info) + (if (eq class 'structure-classoid) + (lambda (x) + (sb!xc:typep x 'structure-classoid)) + (lambda (x) + (sb!xc:typep x (find-classoid class)))) + (fdefinition constructor))) (setf (classoid-direct-superclasses class) - (case (dd-name info) - ((ansi-stream - fd-stream - sb!impl::string-input-stream sb!impl::string-output-stream - sb!impl::fill-pointer-output-stream) - (list (layout-classoid (svref inherits (1- (length inherits)))) - (layout-classoid (svref inherits (- (length inherits) 2))))) - (t - (list (layout-classoid - (svref inherits (1- (length inherits)))))))) + (case (dd-name info) + ((ansi-stream + fd-stream + sb!impl::string-input-stream sb!impl::string-output-stream + sb!impl::fill-pointer-output-stream) + (list (layout-classoid (svref inherits (1- (length inherits)))) + (layout-classoid (svref inherits (- (length inherits) 2))))) + (t + (list (layout-classoid + (svref inherits (1- (length inherits)))))))) (let ((new-layout (make-layout :classoid class - :inherits inherits - :depthoid (length inherits) - :length (+ (dd-length info) - (dd-raw-length info)) - :n-untagged-slots (dd-raw-length info) - :info info)) - (old-layout (or compiler-layout old-layout))) + :inherits inherits + :depthoid (length inherits) + :length (+ (dd-length info) + (dd-raw-length info)) + :n-untagged-slots (dd-raw-length info) + :info info)) + (old-layout (or compiler-layout old-layout))) (cond ((not old-layout) - (values class new-layout nil)) + (values class new-layout nil)) (;; This clause corresponds to an assertion in REDEFINE-LAYOUT-WARNING - ;; of classic CMU CL. I moved it out to here because it was only - ;; exercised in this code path anyway. -- WHN 19990510 - (not (eq (layout-classoid new-layout) (layout-classoid old-layout))) - (error "shouldn't happen: weird state of OLD-LAYOUT?")) + ;; of classic CMU CL. I moved it out to here because it was only + ;; exercised in this code path anyway. -- WHN 19990510 + (not (eq (layout-classoid new-layout) (layout-classoid old-layout))) + (error "shouldn't happen: weird state of OLD-LAYOUT?")) ((not *type-system-initialized*) - (setf (layout-info old-layout) info) - (values class old-layout nil)) + (setf (layout-info old-layout) info) + (values class old-layout nil)) ((redefine-layout-warning old-context - old-layout - new-context - (layout-length new-layout) - (layout-inherits new-layout) - (layout-depthoid new-layout) - (layout-n-untagged-slots new-layout)) - (values class new-layout old-layout)) + old-layout + new-context + (layout-length new-layout) + (layout-inherits new-layout) + (layout-depthoid new-layout) + (layout-n-untagged-slots new-layout)) + (values class new-layout old-layout)) (t - (let ((old-info (layout-info old-layout))) - (typecase old-info - ((or defstruct-description) - (cond ((redefine-structure-warning class old-info info) - (values class new-layout old-layout)) - (t - (setf (layout-info old-layout) info) - (values class old-layout nil)))) - (null - (setf (layout-info old-layout) info) - (values class old-layout nil)) - (t - (error "shouldn't happen! strange thing in LAYOUT-INFO:~% ~S" - old-layout) - (values class new-layout old-layout))))))))) + (let ((old-info (layout-info old-layout))) + (typecase old-info + ((or defstruct-description) + (cond ((redefine-structure-warning class old-info info) + (values class new-layout old-layout)) + (t + (setf (layout-info old-layout) info) + (values class old-layout nil)))) + (null + (setf (layout-info old-layout) info) + (values class old-layout nil)) + (t + (error "shouldn't happen! strange thing in LAYOUT-INFO:~% ~S" + old-layout) + (values class new-layout old-layout))))))))) ;;; Blow away all the compiler info for the structure CLASS. Iterate ;;; over this type, clearing the compiler structure type info, and @@ -1210,16 +1210,16 @@ (let ((info (layout-info (classoid-layout class)))) (when (defstruct-description-p info) (let ((type (dd-name info))) - (remhash type *typecheckfuns*) - (setf (info :type :compiler-layout type) nil) - (undefine-fun-name (dd-copier-name info)) - (undefine-fun-name (dd-predicate-name info)) - (dolist (slot (dd-slots info)) - (let ((fun (dsd-accessor-name slot))) - (unless (accessor-inherited-data fun info) - (undefine-fun-name fun) - (unless (dsd-read-only slot) - (undefine-fun-name `(setf ,fun))))))) + (remhash type *typecheckfuns*) + (setf (info :type :compiler-layout type) nil) + (undefine-fun-name (dd-copier-name info)) + (undefine-fun-name (dd-predicate-name info)) + (dolist (slot (dd-slots info)) + (let ((fun (dsd-accessor-name slot))) + (unless (accessor-inherited-data fun info) + (undefine-fun-name fun) + (unless (dsd-read-only slot) + (undefine-fun-name `(setf ,fun))))))) ;; Clear out the SPECIFIER-TYPE cache so that subsequent ;; references are unknown types. (values-specifier-type-cache-clear))) @@ -1233,17 +1233,17 @@ (collect ((res)) (let ((infos ())) (do ((info defstruct - (typed-structure-info-or-lose (first (dd-include info))))) - ((not (dd-include info)) - (push info infos)) - (push info infos)) + (typed-structure-info-or-lose (first (dd-include info))))) + ((not (dd-include info)) + (push info infos)) + (push info infos)) (let ((i 0)) - (dolist (info infos) - (incf i (or (dd-offset info) 0)) - (when (dd-named info) - (res (cons (dd-name info) i))) - (setq i (dd-length info))))) + (dolist (info infos) + (incf i (or (dd-offset info) 0)) + (when (dd-named info) + (res (cons (dd-name info) i))) + (setq i (dd-length info))))) (res))) @@ -1266,20 +1266,20 @@ ;;; allocated and indirectly referenced. (defun create-vector-constructor (dd cons-name arglist vars types values) (let ((temp (gensym)) - (etype (dd-element-type dd))) + (etype (dd-element-type dd))) `(defun ,cons-name ,arglist (declare ,@(mapcar (lambda (var type) `(type (and ,type ,etype) ,var)) - vars types)) + vars types)) (let ((,temp (make-array ,(dd-length dd) - :element-type ',(dd-element-type dd)))) - ,@(mapcar (lambda (x) - `(setf (aref ,temp ,(cdr x)) ',(car x))) - (find-name-indices dd)) - ,@(mapcar (lambda (dsd value) - (unless (eq value '.do-not-initialize-slot.) + :element-type ',(dd-element-type dd)))) + ,@(mapcar (lambda (x) + `(setf (aref ,temp ,(cdr x)) ',(car x))) + (find-name-indices dd)) + ,@(mapcar (lambda (dsd value) + (unless (eq value '.do-not-initialize-slot.) `(setf (aref ,temp ,(dsd-index dsd)) ,value))) - (dd-slots dd) values) - ,temp)))) + (dd-slots dd) values) + ,temp)))) (defun create-list-constructor (dd cons-name arglist vars types values) (let ((vals (make-list (dd-length dd) :initial-element nil))) (dolist (x (find-name-indices dd)) @@ -1295,37 +1295,37 @@ (let* ((instance (gensym "INSTANCE"))) `(defun ,cons-name ,arglist (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) - vars types)) + vars types)) (let ((,instance (truly-the ,(dd-name dd) - (%make-instance-with-layout - (%delayed-get-compiler-layout ,(dd-name dd)))))) - ,@(mapcar (lambda (dsd value) - ;; (Note that we can't in general use the - ;; ordinary named slot setter function here - ;; because the slot might be :READ-ONLY, so we - ;; whip up new LAMBDA representations of slot - ;; setters for the occasion.) + (%make-instance-with-layout + (%delayed-get-compiler-layout ,(dd-name dd)))))) + ,@(mapcar (lambda (dsd value) + ;; (Note that we can't in general use the + ;; ordinary named slot setter function here + ;; because the slot might be :READ-ONLY, so we + ;; whip up new LAMBDA representations of slot + ;; setters for the occasion.) (unless (eq value '.do-not-initialize-slot.) `(,(slot-setter-lambda-form dd dsd) ,value ,instance))) - (dd-slots dd) - values) - ,instance)))) + (dd-slots dd) + values) + ,instance)))) ;;; Create a default (non-BOA) keyword constructor. (defun create-keyword-constructor (defstruct creator) (declare (type function creator)) (collect ((arglist (list '&key)) - (types) - (vals)) + (types) + (vals)) (dolist (slot (dd-slots defstruct)) (let ((dum (gensym)) - (name (dsd-name slot))) - (arglist `((,(keywordicate name) ,dum) ,(dsd-default slot))) - (types (dsd-type slot)) - (vals dum))) + (name (dsd-name slot))) + (arglist `((,(keywordicate name) ,dum) ,(dsd-default slot))) + (types (dsd-type slot)) + (vals dum))) (funcall creator - defstruct (dd-default-constructor defstruct) - (arglist) (vals) (types) (vals)))) + defstruct (dd-default-constructor defstruct) + (arglist) (vals) (types) (vals)))) ;;; Given a structure and a BOA constructor spec, call CREATOR with ;;; the appropriate args to make a constructor. @@ -1334,78 +1334,78 @@ (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux) (parse-lambda-list (second boa)) (collect ((arglist) - (vars) - (types) + (vars) + (types) (skipped-vars)) (labels ((get-slot (name) - (let ((res (find name (dd-slots defstruct) - :test #'string= - :key #'dsd-name))) - (if res - (values (dsd-type res) (dsd-default res)) - (values t nil)))) - (do-default (arg) - (multiple-value-bind (type default) (get-slot arg) - (arglist `(,arg ,default)) - (vars arg) - (types type)))) - (dolist (arg req) - (arglist arg) - (vars arg) - (types (get-slot arg))) - - (when opt - (arglist '&optional) - (dolist (arg opt) - (cond ((consp arg) - (destructuring-bind - ;; FIXME: this shares some logic (though not - ;; code) with the &key case below (and it - ;; looks confusing) -- factor out the logic - ;; if possible. - CSR, 2002-04-19 - (name - &optional - (def (nth-value 1 (get-slot name))) - (supplied-test nil supplied-test-p)) - arg - (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil))) - (vars name) - (types (get-slot name)))) - (t - (do-default arg))))) - - (when restp - (arglist '&rest rest) - (vars rest) - (types 'list)) - - (when keyp - (arglist '&key) - (dolist (key keys) - (if (consp key) - (destructuring-bind (wot + (let ((res (find name (dd-slots defstruct) + :test #'string= + :key #'dsd-name))) + (if res + (values (dsd-type res) (dsd-default res)) + (values t nil)))) + (do-default (arg) + (multiple-value-bind (type default) (get-slot arg) + (arglist `(,arg ,default)) + (vars arg) + (types type)))) + (dolist (arg req) + (arglist arg) + (vars arg) + (types (get-slot arg))) + + (when opt + (arglist '&optional) + (dolist (arg opt) + (cond ((consp arg) + (destructuring-bind + ;; FIXME: this shares some logic (though not + ;; code) with the &key case below (and it + ;; looks confusing) -- factor out the logic + ;; if possible. - CSR, 2002-04-19 + (name + &optional + (def (nth-value 1 (get-slot name))) + (supplied-test nil supplied-test-p)) + arg + (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil))) + (vars name) + (types (get-slot name)))) + (t + (do-default arg))))) + + (when restp + (arglist '&rest rest) + (vars rest) + (types 'list)) + + (when keyp + (arglist '&key) + (dolist (key keys) + (if (consp key) + (destructuring-bind (wot &optional (def nil def-p) (supplied-test nil supplied-test-p)) key - (let ((name (if (consp wot) - (destructuring-bind (key var) wot - (declare (ignore key)) - var) - wot))) - (multiple-value-bind (type slot-def) + (let ((name (if (consp wot) + (destructuring-bind (key var) wot + (declare (ignore key)) + var) + wot))) + (multiple-value-bind (type slot-def) (get-slot name) - (arglist `(,wot ,(if def-p def slot-def) + (arglist `(,wot ,(if def-p def slot-def) ,@(if supplied-test-p `(,supplied-test) nil))) - (vars name) - (types type)))) - (do-default key)))) + (vars name) + (types type)))) + (do-default key)))) - (when allowp (arglist '&allow-other-keys)) + (when allowp (arglist '&allow-other-keys)) - (when auxp - (arglist '&aux) - (dolist (arg aux) + (when auxp + (arglist '&aux) + (dolist (arg aux) (arglist arg) (if (proper-list-of-length-p arg 2) (let ((var (first arg))) @@ -1414,7 +1414,7 @@ (skipped-vars (if (consp arg) (first arg) arg)))))) (funcall creator defstruct (first boa) - (arglist) (vars) (types) + (arglist) (vars) (types) (loop for slot in (dd-slots defstruct) for name = (dsd-name slot) collect (cond ((find name (skipped-vars) :test #'string=) @@ -1427,22 +1427,22 @@ ;;; any) to create. (defun constructor-definitions (defstruct) (let ((no-constructors nil) - (boas ()) - (defaults ()) - (creator (ecase (dd-type defstruct) - (structure #'create-structure-constructor) - (vector #'create-vector-constructor) - (list #'create-list-constructor)))) + (boas ()) + (defaults ()) + (creator (ecase (dd-type defstruct) + (structure #'create-structure-constructor) + (vector #'create-vector-constructor) + (list #'create-list-constructor)))) (dolist (constructor (dd-constructors defstruct)) (destructuring-bind (name &optional (boa-ll nil boa-p)) constructor - (declare (ignore boa-ll)) - (cond ((not name) (setq no-constructors t)) - (boa-p (push constructor boas)) - (t (push name defaults))))) + (declare (ignore boa-ll)) + (cond ((not name) (setq no-constructors t)) + (boa-p (push constructor boas)) + (t (push name defaults))))) (when no-constructors (when (or defaults boas) - (error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs")) + (error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs")) (return-from constructor-definitions ())) (unless (or defaults boas) @@ -1498,131 +1498,131 @@ ;;;; functionality of DEFINE-PRIMITIVE-OBJECT..) (defun make-dd-with-alternate-metaclass (&key (class-name (missing-arg)) - (superclass-name (missing-arg)) - (metaclass-name (missing-arg)) - (dd-type (missing-arg)) - metaclass-constructor - slot-names) + (superclass-name (missing-arg)) + (metaclass-name (missing-arg)) + (dd-type (missing-arg)) + metaclass-constructor + slot-names) (let* ((dd (make-defstruct-description class-name)) - (conc-name (concatenate 'string (symbol-name class-name) "-")) - (dd-slots (let ((reversed-result nil) - ;; The index starts at 1 for ordinary - ;; named slots because slot 0 is - ;; magical, used for LAYOUT in - ;; CONDITIONs or for something (?) in - ;; funcallable instances. - (index 1)) - (dolist (slot-name slot-names) - (push (make-defstruct-slot-description - :name slot-name - :index index - :accessor-name (symbolicate conc-name slot-name)) - reversed-result) - (incf index)) - (nreverse reversed-result)))) + (conc-name (concatenate 'string (symbol-name class-name) "-")) + (dd-slots (let ((reversed-result nil) + ;; The index starts at 1 for ordinary + ;; named slots because slot 0 is + ;; magical, used for LAYOUT in + ;; CONDITIONs or for something (?) in + ;; funcallable instances. + (index 1)) + (dolist (slot-name slot-names) + (push (make-defstruct-slot-description + :name slot-name + :index index + :accessor-name (symbolicate conc-name slot-name)) + reversed-result) + (incf index)) + (nreverse reversed-result)))) (setf (dd-alternate-metaclass dd) (list superclass-name - metaclass-name - metaclass-constructor) - (dd-slots dd) dd-slots - (dd-length dd) (1+ (length slot-names)) - (dd-type dd) dd-type) + metaclass-name + metaclass-constructor) + (dd-slots dd) dd-slots + (dd-length dd) (1+ (length slot-names)) + (dd-type dd) dd-type) dd)) (sb!xc:defmacro !defstruct-with-alternate-metaclass (class-name &key - (slot-names (missing-arg)) - (boa-constructor (missing-arg)) - (superclass-name (missing-arg)) - (metaclass-name (missing-arg)) - (metaclass-constructor (missing-arg)) - (dd-type (missing-arg)) - predicate - (runtime-type-checks-p t)) + (slot-names (missing-arg)) + (boa-constructor (missing-arg)) + (superclass-name (missing-arg)) + (metaclass-name (missing-arg)) + (metaclass-constructor (missing-arg)) + (dd-type (missing-arg)) + predicate + (runtime-type-checks-p t)) (declare (type (and list (not null)) slot-names)) (declare (type (and symbol (not null)) - boa-constructor - superclass-name - metaclass-name - metaclass-constructor)) + boa-constructor + superclass-name + metaclass-name + metaclass-constructor)) (declare (type symbol predicate)) (declare (type (member structure funcallable-structure) dd-type)) (let* ((dd (make-dd-with-alternate-metaclass - :class-name class-name - :slot-names slot-names - :superclass-name superclass-name - :metaclass-name metaclass-name - :metaclass-constructor metaclass-constructor - :dd-type dd-type)) - (dd-slots (dd-slots dd)) - (dd-length (1+ (length slot-names))) - (object-gensym (gensym "OBJECT")) - (new-value-gensym (gensym "NEW-VALUE-")) - (delayed-layout-form `(%delayed-get-compiler-layout ,class-name))) + :class-name class-name + :slot-names slot-names + :superclass-name superclass-name + :metaclass-name metaclass-name + :metaclass-constructor metaclass-constructor + :dd-type dd-type)) + (dd-slots (dd-slots dd)) + (dd-length (1+ (length slot-names))) + (object-gensym (gensym "OBJECT")) + (new-value-gensym (gensym "NEW-VALUE-")) + (delayed-layout-form `(%delayed-get-compiler-layout ,class-name))) (multiple-value-bind (raw-maker-form raw-reffer-operator) - (ecase dd-type - (structure - (values `(let ((,object-gensym (%make-instance ,dd-length))) - (setf (%instance-layout ,object-gensym) - ,delayed-layout-form) - ,object-gensym) - '%instance-ref)) - (funcallable-structure - (values `(%make-funcallable-instance ,dd-length - ,delayed-layout-form) - '%funcallable-instance-info))) + (ecase dd-type + (structure + (values `(let ((,object-gensym (%make-instance ,dd-length))) + (setf (%instance-layout ,object-gensym) + ,delayed-layout-form) + ,object-gensym) + '%instance-ref)) + (funcallable-structure + (values `(%make-funcallable-instance ,dd-length + ,delayed-layout-form) + '%funcallable-instance-info))) `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (%compiler-set-up-layout ',dd)) - - ;; slot readers and writers - (declaim (inline ,@(mapcar #'dsd-accessor-name dd-slots))) - ,@(mapcar (lambda (dsd) - `(defun ,(dsd-accessor-name dsd) (,object-gensym) - ,@(when runtime-type-checks-p - `((declare (type ,class-name ,object-gensym)))) - (,raw-reffer-operator ,object-gensym - ,(dsd-index dsd)))) - dd-slots) - (declaim (inline ,@(mapcar (lambda (dsd) - `(setf ,(dsd-accessor-name dsd))) - dd-slots))) - ,@(mapcar (lambda (dsd) - `(defun (setf ,(dsd-accessor-name dsd)) (,new-value-gensym - ,object-gensym) - ,@(when runtime-type-checks-p - `((declare (type ,class-name ,object-gensym)))) - (setf (,raw-reffer-operator ,object-gensym - ,(dsd-index dsd)) - ,new-value-gensym))) - dd-slots) - - ;; constructor - (defun ,boa-constructor ,slot-names - (let ((,object-gensym ,raw-maker-form)) - ,@(mapcar (lambda (slot-name) - (let ((dsd (find (symbol-name slot-name) dd-slots - :key (lambda (x) - (symbol-name (dsd-name x))) - :test #'string=))) - ;; KLUDGE: bug 117 bogowarning. Neither - ;; DECLAREing the type nor TRULY-THE cut - ;; the mustard -- it still gives warnings. - (enforce-type dsd defstruct-slot-description) - `(setf (,(dsd-accessor-name dsd) ,object-gensym) - ,slot-name))) - slot-names) - ,object-gensym)) - - ;; predicate - ,@(when predicate - ;; Just delegate to the compiler's type optimization - ;; code, which knows how to generate inline type tests - ;; for the whole CMU CL INSTANCE menagerie. - `(defun ,predicate (,object-gensym) - (typep ,object-gensym ',class-name))))))) + (eval-when (:compile-toplevel :load-toplevel :execute) + (%compiler-set-up-layout ',dd)) + + ;; slot readers and writers + (declaim (inline ,@(mapcar #'dsd-accessor-name dd-slots))) + ,@(mapcar (lambda (dsd) + `(defun ,(dsd-accessor-name dsd) (,object-gensym) + ,@(when runtime-type-checks-p + `((declare (type ,class-name ,object-gensym)))) + (,raw-reffer-operator ,object-gensym + ,(dsd-index dsd)))) + dd-slots) + (declaim (inline ,@(mapcar (lambda (dsd) + `(setf ,(dsd-accessor-name dsd))) + dd-slots))) + ,@(mapcar (lambda (dsd) + `(defun (setf ,(dsd-accessor-name dsd)) (,new-value-gensym + ,object-gensym) + ,@(when runtime-type-checks-p + `((declare (type ,class-name ,object-gensym)))) + (setf (,raw-reffer-operator ,object-gensym + ,(dsd-index dsd)) + ,new-value-gensym))) + dd-slots) + + ;; constructor + (defun ,boa-constructor ,slot-names + (let ((,object-gensym ,raw-maker-form)) + ,@(mapcar (lambda (slot-name) + (let ((dsd (find (symbol-name slot-name) dd-slots + :key (lambda (x) + (symbol-name (dsd-name x))) + :test #'string=))) + ;; KLUDGE: bug 117 bogowarning. Neither + ;; DECLAREing the type nor TRULY-THE cut + ;; the mustard -- it still gives warnings. + (enforce-type dsd defstruct-slot-description) + `(setf (,(dsd-accessor-name dsd) ,object-gensym) + ,slot-name))) + slot-names) + ,object-gensym)) + + ;; predicate + ,@(when predicate + ;; Just delegate to the compiler's type optimization + ;; code, which knows how to generate inline type tests + ;; for the whole CMU CL INSTANCE menagerie. + `(defun ,predicate (,object-gensym) + (typep ,object-gensym ',class-name))))))) ;;;; finalizing bootstrapping @@ -1638,7 +1638,7 @@ (setf ;; Note: This has an ALTERNATE-METACLASS only because of blind ;; clueless imitation of the CMU CL code -- dunno if or why it's - ;; needed. -- WHN + ;; needed. -- WHN (dd-alternate-metaclass dd) '(instance) (dd-slots dd) nil (dd-length dd) 1 @@ -1649,12 +1649,12 @@ ;;; early structure predeclarations: Set up DD and LAYOUT for ordinary ;;; (non-ALTERNATE-METACLASS) structures which are needed early. (dolist (args - '#.(sb-cold:read-from-file - "src/code/early-defstruct-args.lisp-expr")) + '#.(sb-cold:read-from-file + "src/code/early-defstruct-args.lisp-expr")) (let* ((dd (parse-defstruct-name-and-options-and-slot-descriptions - (first args) - (rest args))) - (inherits (inherits-for-structure dd))) + (first args) + (rest args))) + (inherits (inherits-for-structure dd))) (%compiler-defstruct dd inherits))) (/show0 "code/defstruct.lisp end of file") diff --git a/src/code/deftypes-for-target.lisp b/src/code/deftypes-for-target.lisp index 26a0f49..7c8fe9a 100644 --- a/src/code/deftypes-for-target.lisp +++ b/src/code/deftypes-for-target.lisp @@ -33,18 +33,18 @@ (sb!xc:deftype signed-byte (&optional s) (cond ((eq s '*) 'integer) - ((and (integerp s) (> s 0)) - (let ((bound (ash 1 (1- s)))) - `(integer ,(- bound) ,(1- bound)))) - (t - (error "bad size specified for SIGNED-BYTE type specifier: ~S" s)))) + ((and (integerp s) (> s 0)) + (let ((bound (ash 1 (1- s)))) + `(integer ,(- bound) ,(1- bound)))) + (t + (error "bad size specified for SIGNED-BYTE type specifier: ~S" s)))) (sb!xc:deftype unsigned-byte (&optional s) (cond ((eq s '*) '(integer 0)) - ((and (integerp s) (> s 0)) - `(integer 0 ,(1- (ash 1 s)))) - (t - (error "bad size specified for UNSIGNED-BYTE type specifier: ~S" s)))) + ((and (integerp s) (> s 0)) + `(integer 0 ,(1- (ash 1 s)))) + (t + (error "bad size specified for UNSIGNED-BYTE type specifier: ~S" s)))) ;;; ANSI got UNSIGNED-BYTE wrong, prohibiting (UNSIGNED-BYTE 0). ;;; Since this is actually a substantial impediment to clarity... @@ -180,28 +180,28 @@ ;;; decomposing floats into integers (sb!xc:deftype single-float-exponent () `(integer ,(- sb!vm:single-float-normal-exponent-min - sb!vm:single-float-bias - sb!vm:single-float-digits) - ,(- sb!vm:single-float-normal-exponent-max - sb!vm:single-float-bias))) + sb!vm:single-float-bias + sb!vm:single-float-digits) + ,(- sb!vm:single-float-normal-exponent-max + sb!vm:single-float-bias))) (sb!xc:deftype double-float-exponent () `(integer ,(- sb!vm:double-float-normal-exponent-min - sb!vm:double-float-bias - sb!vm:double-float-digits) - ,(- sb!vm:double-float-normal-exponent-max - sb!vm:double-float-bias))) + sb!vm:double-float-bias + sb!vm:double-float-digits) + ,(- sb!vm:double-float-normal-exponent-max + sb!vm:double-float-bias))) (sb!xc:deftype single-float-int-exponent () `(integer ,(- sb!vm:single-float-normal-exponent-min - sb!vm:single-float-bias - (* sb!vm:single-float-digits 2)) - ,(- sb!vm:single-float-normal-exponent-max - sb!vm:single-float-bias - sb!vm:single-float-digits))) + sb!vm:single-float-bias + (* sb!vm:single-float-digits 2)) + ,(- sb!vm:single-float-normal-exponent-max + sb!vm:single-float-bias + sb!vm:single-float-digits))) (sb!xc:deftype double-float-int-exponent () `(integer ,(- sb!vm:double-float-normal-exponent-min sb!vm:double-float-bias - (* sb!vm:double-float-digits 2)) - ,(- sb!vm:double-float-normal-exponent-max sb!vm:double-float-bias - sb!vm:double-float-digits))) + (* sb!vm:double-float-digits 2)) + ,(- sb!vm:double-float-normal-exponent-max sb!vm:double-float-bias + sb!vm:double-float-digits))) (sb!xc:deftype single-float-significand () `(integer 0 (,(ash 1 sb!vm:single-float-digits)))) (sb!xc:deftype double-float-significand () diff --git a/src/code/describe.lisp b/src/code/describe.lisp index f36be45..17aba76 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -27,7 +27,7 @@ ;; DESCRIBE exists as an interface primarily to manage argument ;; defaulting (including conversion of arguments T and NIL into ;; stream objects) and to inhibit any return values from - ;; DESCRIBE-OBJECT. + ;; DESCRIBE-OBJECT. ;; doesn't mention either FRESH-LINEing or PPRINT-LOGICAL-BLOCKing, ;; and the example of typical DESCRIBE-OBJECT behavior in ANSI's ;; specification of DESCRIBE-OBJECT will work poorly if we do them @@ -49,7 +49,7 @@ (defmethod describe-object ((x cons) s) (call-next-method) (when (and (legal-fun-name-p x) - (fboundp x)) + (fboundp x)) (%describe-fun (fdefinition x) s :function x) ;;was: (format s "~@:_Its FDEFINITION is ~S.~@:_" (fdefinition x)) ;; TO DO: should check for SETF documentation. @@ -63,21 +63,21 @@ (cond ((= 1 (array-rank x)) (format s "~S is a vector with ~D elements." - x (car (array-dimensions x))) + x (car (array-dimensions x))) (when (array-has-fill-pointer-p x) - (format s "~@:_It has a fill pointer value of ~S." - (fill-pointer x)))) + (format s "~@:_It has a fill pointer value of ~S." + (fill-pointer x)))) (t (format s "~S is an array of dimension ~:S." - x (array-dimensions x)))) + x (array-dimensions x)))) (let ((array-element-type (array-element-type x))) (unless (eq array-element-type t) - (format s - "~@:_Its element type is specialized to ~S." - array-element-type))) + (format s + "~@:_Its element type is specialized to ~S." + array-element-type))) (if (and (array-header-p x) (%array-displaced-p x)) - (format s "~@:_The array is displaced with offset ~S." - (%array-displacement x)))) + (format s "~@:_The array is displaced with offset ~S." + (%array-displacement x)))) (terpri s)) (defmethod describe-object ((x hash-table) s) @@ -85,24 +85,24 @@ (format s "~&~@<~S ~_is an ~S hash table.~:>" x (hash-table-test x)) (format s "~&Its SIZE is ~S." (hash-table-size x)) (format s - "~&~@" - (hash-table-rehash-size x) - (hash-table-rehash-threshold x)) + "~&~@" + (hash-table-rehash-size x) + (hash-table-rehash-threshold x)) (fresh-line s) (pprint-logical-block (s nil) (let ((count (hash-table-count x))) (format s "It holds ~S key/value pair~:P~:[: ~2I~_~;.~]" - count (zerop count)) + count (zerop count)) (let ((n 0)) - (declare (type index n)) - (dohash (k v x) - (unless (zerop n) - (write-char #\space s)) - (incf n) - (when (and *print-length* (> n *print-length*)) - (format s "~:_...") - (return)) - (format s "~:_(~@<~S ~:_~S~:>)" k v))))) + (declare (type index n)) + (dohash (k v x) + (unless (zerop n) + (write-char #\space s)) + (incf n) + (when (and *print-length* (> n *print-length*)) + (format s "~:_...") + (return)) + (format s "~:_(~@<~S ~:_~S~:>)" k v))))) (terpri s)) (defmethod describe-object ((condition condition) s) @@ -119,8 +119,8 @@ (when (and name (typep name '(or symbol cons))) (let ((doc (fdocumentation name kind))) (when doc - (format s "~&~@(~A documentation:~)~% ~A" - (or kind-doc kind) doc)))) + (format s "~&~@(~A documentation:~)~% ~A" + (or kind-doc kind) doc)))) (values)) ;;; Describe various stuff about the functional semantics attached to @@ -129,23 +129,23 @@ ;;; things, it might not be.) TYPE-SPEC is the function type specifier ;;; extracted from the definition, or NIL if none. (declaim (ftype (function (t stream t)) %describe-fun-name)) -(defun %describe-fun-name (name s type-spec) +(defun %describe-fun-name (name s type-spec) (when (and name (typep name '(or symbol cons))) (multiple-value-bind (type where) - (if (legal-fun-name-p name) - (values (type-specifier (info :function :type name)) - (info :function :where-from name)) - (values type-spec :defined)) + (if (legal-fun-name-p name) + (values (type-specifier (info :function :type name)) + (info :function :where-from name)) + (values type-spec :defined)) (when (consp type) - (format s "~&Its ~(~A~) argument types are:~% ~S" - where (second type)) - (format s "~&Its result type is:~% ~S" (third type)))) + (format s "~&Its ~(~A~) argument types are:~% ~S" + where (second type)) + (format s "~&Its result type is:~% ~S" (third type)))) (let ((inlinep (info :function :inlinep name))) (when inlinep - (format s - "~&It is currently declared ~(~A~);~ - ~:[no~;~] expansion is available." - inlinep (info :function :inline-expansion-designator name)))))) + (format s + "~&It is currently declared ~(~A~);~ + ~:[no~;~] expansion is available." + inlinep (info :function :inline-expansion-designator name)))))) ;;; Print information from the debug-info about where CODE-OBJ was ;;; compiled from. @@ -154,19 +154,19 @@ (let ((info (sb-kernel:%code-debug-info code-obj))) (when info (let ((source (sb-c::debug-info-source info))) - (when source - (format s "~&On ~A it was compiled from:" - ;; FIXME: The FORMAT-UNIVERSAL-TIME calls in the system - ;; should become more consistent, probably not using - ;; any nondefault options. - (format-universal-time nil (sb-c::debug-source-compiled source) - :style :abbreviated)) - (let ((name (sb-c::debug-source-name source))) - (ecase (sb-c::debug-source-from source) - (:file - (format s "~&~A~@:_ Created: " (namestring name)) - (format-universal-time s (sb-c::debug-source-created source))) - (:lisp (format s "~&~S" name))))))))) + (when source + (format s "~&On ~A it was compiled from:" + ;; FIXME: The FORMAT-UNIVERSAL-TIME calls in the system + ;; should become more consistent, probably not using + ;; any nondefault options. + (format-universal-time nil (sb-c::debug-source-compiled source) + :style :abbreviated)) + (let ((name (sb-c::debug-source-name source))) + (ecase (sb-c::debug-source-from source) + (:file + (format s "~&~A~@:_ Created: " (namestring name)) + (format-universal-time s (sb-c::debug-source-created source))) + (:lisp (format s "~&~S" name))))))))) ;;; Describe a compiled function. The closure case calls us to print ;;; the guts. @@ -174,10 +174,10 @@ (declare (type stream s)) (let ((args (%simple-fun-arglist x))) (cond ((not args) - (write-string " There are no arguments." s)) - (t + (write-string " There are no arguments." s)) + (t (format s "~&~@(The ~@[~A's ~]arguments are:~@:_~)" kind) - (write-string " " s) + (write-string " " s) (let ((*print-pretty* t) (*print-escape* t) (*print-base* 10) @@ -202,19 +202,19 @@ (ecase kind (:macro (format s "Macro-function: ~S" x)) (:function (if name - (format s "Function: ~S" x) - (format s "~S is a function." x)))) + (format s "Function: ~S" x) + (format s "~S is a function." x)))) (format s "~@:_~@" - 'function-lambda-expression - (%fun-name x)) + 'function-lambda-expression + (%fun-name x)) (case (widetag-of x) (#.sb-vm:closure-header-widetag (%describe-fun-compiled (%closure-fun x) s kind name) (format s "~@:_Its closure environment is:") (pprint-logical-block (s nil) - (pprint-indent :current 8) - (dotimes (i (- (get-closure-length x) (1- sb-vm:closure-info-offset))) - (format s "~@:_~S: ~S" i (%closure-index-ref x i))))) + (pprint-indent :current 8) + (dotimes (i (- (get-closure-length x) (1- sb-vm:closure-info-offset))) + (format s "~@:_~S: ~S" i (%closure-index-ref x i))))) (#.sb-vm:simple-fun-header-widetag (%describe-fun-compiled x s kind name)) (#.sb-vm:funcallable-instance-header-widetag @@ -246,12 +246,12 @@ ;; Describe the packaging. (let ((package (symbol-package x))) (if package - (multiple-value-bind (symbol status) - (find-symbol (symbol-name x) package) - (declare (ignore symbol)) - (format s "~&~@<~S is ~_an ~(~A~) symbol ~_in ~S.~:>" - x status (symbol-package x))) - (format s "~&~@<~S is ~_an uninterned symbol.~:>" x))) + (multiple-value-bind (symbol status) + (find-symbol (symbol-name x) package) + (declare (ignore symbol)) + (format s "~&~@<~S is ~_an ~(~A~) symbol ~_in ~S.~:>" + x status (symbol-package x))) + (format s "~&~@<~S is ~_an uninterned symbol.~:>" x))) ;; TO DO: We could grovel over all packages looking for and ;; reporting other phenomena, e.g. IMPORT and SHADOW, or ;; availability in some package even after (SYMBOL-PACKAGE X) has @@ -259,34 +259,34 @@ ;; Describe the value cell. (let* ((kind (info :variable :kind x)) - (wot (ecase kind - (:special "special variable") - (:macro "symbol macro") - (:constant "constant") - (:global "undefined variable") - (:alien nil)))) + (wot (ecase kind + (:special "special variable") + (:macro "symbol macro") + (:constant "constant") + (:global "undefined variable") + (:alien nil)))) (pprint-logical-block (s nil) (cond ((eq kind :alien) - (let ((info (info :variable :alien-info x))) - (format s "~&~@" - (sap-int (eval (sb-alien::heap-alien-info-sap-form info))) - (sb-alien-internals:unparse-alien-type - (sb-alien::heap-alien-info-type info))) - (format s "~&~@" - (eval x)))) + (let ((info (info :variable :alien-info x))) + (format s "~&~@" + (sap-int (eval (sb-alien::heap-alien-info-sap-form info))) + (sb-alien-internals:unparse-alien-type + (sb-alien::heap-alien-info-type info))) + (format s "~&~@" + (eval x)))) ((eq kind :macro) - (let ((expansion (info :variable :macro-expansion x))) - (format s "~&It is a ~A with expansion ~S." wot expansion))) + (let ((expansion (info :variable :macro-expansion x))) + (format s "~&It is a ~A with expansion ~S." wot expansion))) ((boundp x) - (format s "~&~@" - wot (symbol-value x))) + (format s "~&~@" + wot (symbol-value x))) ((not (eq kind :global)) - (format s "~&~@" wot))) + (format s "~&~@" wot))) (when (eq (info :variable :where-from x) :declared) - (format s "~&~@" - (type-specifier (info :variable :type x))))) + (format s "~&~@" + (type-specifier (info :variable :type x))))) (%describe-doc x s 'variable kind)) @@ -295,11 +295,11 @@ ;; Describe the function cell. (cond ((macro-function x) - (%describe-fun (macro-function x) s :macro x)) - ((special-operator-p x) - (%describe-doc x s :function "Special form")) - ((fboundp x) - (describe-symbol-fdefinition (fdefinition x) s :name x))) + (%describe-fun (macro-function x) s :macro x)) + ((special-operator-p x) + (%describe-doc x s :function "Special form")) + ((fboundp x) + (describe-symbol-fdefinition (fdefinition x) s :name x))) ;; Print other documentation. (%describe-doc x s 'structure "Structure") @@ -307,10 +307,10 @@ (%describe-doc x s 'setf "Setf macro") (dolist (assoc (info :random-documentation :stuff x)) (format s - "~&~@" - (car assoc) - (cdr assoc))) - + "~&~@" + (car assoc) + (cdr assoc))) + ;; Mention the associated type information, if any. ;; ;; As of sbcl-0.7.2, (INFO :TYPE :KIND X) might be diff --git a/src/code/destructuring-bind.lisp b/src/code/destructuring-bind.lisp index 3e65da7..58bc4c0 100644 --- a/src/code/destructuring-bind.lisp +++ b/src/code/destructuring-bind.lisp @@ -14,10 +14,10 @@ "Bind the variables in LAMBDA-LIST to the contents of ARG-LIST." (let ((arg-list-name (gensym "ARG-LIST-"))) (multiple-value-bind (body local-decls) - (parse-defmacro lambda-list arg-list-name body nil 'destructuring-bind - :anonymousp t - :doc-string-allowed nil + (parse-defmacro lambda-list arg-list-name body nil 'destructuring-bind + :anonymousp t + :doc-string-allowed nil :wrap-block nil) `(let ((,arg-list-name ,arg-list)) - ,@local-decls - ,body)))) + ,@local-decls + ,body)))) diff --git a/src/code/dyncount.lisp b/src/code/dyncount.lisp index a8071c0..fb723cf 100644 --- a/src/code/dyncount.lisp +++ b/src/code/dyncount.lisp @@ -39,7 +39,7 @@ comments from CMU CL: (let ((res (make-hash-table-like table1))) (dohash (k v table1) (unless (nth-value 1 (gethash k table2)) - (setf (gethash k res) v))) + (setf (gethash k res) v))) res)) (defun hash-list (table) @@ -58,36 +58,36 @@ comments from CMU CL: (dotimes (i 3) (format t "~%; ~A" (read-line s))) (let* ((eof '(nil)) - (test (read s)) - (reader (read s)) - (res (make-hash-table :test test))) + (test (read s)) + (reader (read s)) + (res (make-hash-table :test test))) (read s); Discard writer... (loop - (let ((key (read s nil eof))) - (when (eq key eof) (return)) - (setf (gethash key res) - (funcall reader s key)))) + (let ((key (read s nil eof))) + (when (eq key eof) (return)) + (setf (gethash key res) + (funcall reader s key)))) res))) (defun write-hash-table (table file &key - (comment (format nil "Contents of ~S" table)) - (reader 'read) (writer 'prin1) (test 'equal)) + (comment (format nil "Contents of ~S" table)) + (reader 'read) (writer 'prin1) (test 'equal)) (with-open-file (s file :direction :output :if-exists :new-version) (with-standard-io-syntax (let ((*print-readably* nil)) - (format s - "~A~%~A version ~A on ~A~%" - comment - (lisp-implementation-type) - (lisp-implementation-version) - (machine-instance)) - (format-universal-time s (get-universal-time)) - (terpri s) - (format s "~S ~S ~S~%" test reader writer) - (dohash (k v table) - (prin1 k s) - (write-char #\space s) - (funcall writer v s) - (terpri s))))) + (format s + "~A~%~A version ~A on ~A~%" + comment + (lisp-implementation-type) + (lisp-implementation-version) + (machine-instance)) + (format-universal-time s (get-universal-time)) + (terpri s) + (format s "~S ~S ~S~%" test reader writer) + (dohash (k v table) + (prin1 k s) + (write-char #\space s) + (funcall writer v s) + (terpri s))))) table) ;;;; info accumulation @@ -97,9 +97,9 @@ comments from CMU CL: ;;; overflows. (deftype count-vector () '(simple-array double-float (2))) (defstruct (vop-stats - (:constructor %make-vop-stats (name)) - (:constructor make-vop-stats-key) - (:copier nil)) + (:constructor %make-vop-stats (name)) + (:constructor make-vop-stats-key) + (:copier nil)) (name (missing-arg) :type simple-string) (data (make-array 2 :element-type 'double-float) :type count-vector)) @@ -119,36 +119,36 @@ comments from CMU CL: ;;; (which may be compiled with profiling on.) (defun note-dyncount-info (info) (declare (type dyncount-info info) (inline get %put) - (optimize (speed 2))) + (optimize (speed 2))) (let ((counts (dyncount-info-counts info)) - (vops (dyncount-info-vops info))) + (vops (dyncount-info-vops info))) (dotimes (index (length counts)) (declare (type index index)) (let ((count (coerce (the (unsigned-byte 31) - (aref counts index)) - 'double-float))) - (when (minusp count) - (warn "Oops: overflow.") - (return-from note-dyncount-info nil)) - (unless (zerop count) - (let* ((vop-info (svref vops index)) - (length (length vop-info))) - (declare (simple-vector vop-info)) - (do ((i 0 (+ i 4))) - ((>= i length)) - (declare (type index i)) - (let* ((name (svref vop-info i)) - (entry (or (get name 'vop-stats) - (setf (get name 'vop-stats) - (%make-vop-stats (symbol-name name)))))) - (incf (vop-stats-count entry) - (* (coerce (the index (svref vop-info (1+ i))) - 'double-float) - count)) - (incf (vop-stats-cost entry) - (* (coerce (the index (svref vop-info (+ i 2))) - 'double-float) - count)))))))))) + (aref counts index)) + 'double-float))) + (when (minusp count) + (warn "Oops: overflow.") + (return-from note-dyncount-info nil)) + (unless (zerop count) + (let* ((vop-info (svref vops index)) + (length (length vop-info))) + (declare (simple-vector vop-info)) + (do ((i 0 (+ i 4))) + ((>= i length)) + (declare (type index i)) + (let* ((name (svref vop-info i)) + (entry (or (get name 'vop-stats) + (setf (get name 'vop-stats) + (%make-vop-stats (symbol-name name)))))) + (incf (vop-stats-count entry) + (* (coerce (the index (svref vop-info (1+ i))) + 'double-float) + count)) + (incf (vop-stats-cost entry) + (* (coerce (the index (svref vop-info (+ i 2))) + 'double-float) + count)))))))))) (defun clear-dyncount-info (info) (declare (type dyncount-info info)) @@ -168,15 +168,15 @@ comments from CMU CL: (locally (declare (optimize (speed 3) (safety 0)) - (inline sb!vm::map-allocated-objects)) + (inline sb!vm::map-allocated-objects)) (without-gcing (dolist (space spaces) - (sb!vm::map-allocated-objects - (lambda (object type-code size) - (declare (ignore type-code size)) - (when (dyncount-info-p object) - (clear-dyncount-info object))) - space))))) + (sb!vm::map-allocated-objects + (lambda (object type-code size) + (declare (ignore type-code size)) + (when (dyncount-info-p object) + (clear-dyncount-info object))) + space))))) ;;; Call NOTE-DYNCOUNT-INFO on all DYNCOUNT-INFO structure allocated in the ;;; specified spaces. Return a hashtable describing the counts. The initial @@ -189,39 +189,39 @@ comments from CMU CL: zero as a side effect." (locally (declare (optimize (speed 3) (safety 0)) - (inline sb!vm::map-allocated-objects)) + (inline sb!vm::map-allocated-objects)) (without-gcing (dolist (space spaces) - (sb!vm::map-allocated-objects - (lambda (object type-code size) - (declare (ignore type-code size)) - (when (dyncount-info-p object) - (note-dyncount-info object) - (when clear - (clear-dyncount-info object)))) - space)))) + (sb!vm::map-allocated-objects + (lambda (object type-code size) + (declare (ignore type-code size)) + (when (dyncount-info-p object) + (note-dyncount-info object) + (when clear + (clear-dyncount-info object)))) + space)))) (let ((counts (make-hash-table :test 'equal))) (dohash (k v *backend-template-names*) (declare (ignore v)) (let ((stats (get k 'vop-stats))) - (when stats - (setf (gethash (symbol-name k) counts) stats) - (when clear - (remprop k 'vop-stats))))) + (when stats + (setf (gethash (symbol-name k) counts) stats) + (when clear + (remprop k 'vop-stats))))) counts)) ;;; Return the DYNCOUNT-INFO for FUNCTION. (defun find-info-for (function) (declare (type function function)) (let* ((function (%primitive closure-fun function)) - (component (sb!di::fun-code-header function))) + (component (sb!di::fun-code-header function))) (do ((end (get-header-data component)) - (i sb!vm:code-constants-offset (1+ i))) - ((= end i)) + (i sb!vm:code-constants-offset (1+ i))) + ((= end i)) (let ((constant (code-header-ref component i))) - (when (dyncount-info-p constant) - (return constant)))))) + (when (dyncount-info-p constant) + (return constant)))))) (defun vop-counts-apply (function args &key (spaces '(:dynamic)) by-space) #!+sb-doc @@ -233,8 +233,8 @@ comments from CMU CL: (apply function args) (if by-space (mapcar (lambda (space) - (get-vop-counts (list space) :clear t)) - spaces) + (get-vop-counts (list space) :clear t)) + spaces) (get-vop-counts spaces))) ;;;; adjustments @@ -247,9 +247,9 @@ comments from CMU CL: (dohash (name v *assembler-routines*) (declare (ignore v)) (let ((vop (gethash name *backend-template-names*))) - (when vop - (setf (gethash (symbol-name name) res) - (template-cost (template-or-lose name)))))) + (when vop + (setf (gethash (symbol-name name) res) + (template-cost (template-or-lose name)))))) res)) (defvar *native-costs* (get-vop-costs) @@ -301,8 +301,8 @@ comments from CMU CL: (let ((name (concatenate 'string "$" name "$"))) (dolist (pat (if (listp pattern) pattern (list pattern)) nil) (when (search (the simple-string (string pat)) - name :test #'char=) - (return t))))) + name :test #'char=) + (return t))))) ;;; Utilities for debugging classification rules. FIND-MATCHES returns a ;;; list of all the VOP names in Table that match Pattern. WHAT-CLASS returns @@ -327,15 +327,15 @@ comments from CMU CL: (let ((res (make-hash-table-like table))) (dohash (key value table) (let ((class (dolist (class classes nil) - (when (matches-pattern key (rest class)) - (return (first class)))))) - (if class - (let ((found (or (gethash class res) - (setf (gethash class res) - (%make-vop-stats class))))) - (incf (vop-stats-count found) (vop-stats-count value)) - (incf (vop-stats-cost found) (vop-stats-cost value))) - (setf (gethash key res) value)))) + (when (matches-pattern key (rest class)) + (return (first class)))))) + (if class + (let ((found (or (gethash class res) + (setf (gethash class res) + (%make-vop-stats class))))) + (incf (vop-stats-count found) (vop-stats-count value)) + (incf (vop-stats-cost found) (vop-stats-cost value))) + (setf (gethash key res) value)))) res)) ;;;; analysis @@ -343,7 +343,7 @@ comments from CMU CL: ;;; Sum the count and costs. (defun cost-summary (table) (let ((total-count 0d0) - (total-cost 0d0)) + (total-cost 0d0)) (dohash (k v table) (declare (ignore k)) (incf total-count (vop-stats-count v)) @@ -356,15 +356,15 @@ comments from CMU CL: (let ((res (make-hash-table-like table))) (dohash (key value table) (unless (or (string= key "COUNT-ME") - (member key ignore :test #'string=)) - (let ((cost (gethash key costs))) - (if cost - (let* ((count (vop-stats-count value)) - (sum (+ (* cost count) - (vop-stats-cost value)))) - (setf (gethash key res) - (make-vop-stats :name key :count count :cost sum))) - (setf (gethash key res) value))))) + (member key ignore :test #'string=)) + (let ((cost (gethash key costs))) + (if cost + (let* ((count (vop-stats-count value)) + (sum (+ (* cost count) + (vop-stats-cost value)))) + (setf (gethash key res) + (make-vop-stats :name key :count count :cost sum))) + (setf (gethash key res) value))))) res)) ;;; Take two tables of vop-stats and return a table of entries where the @@ -376,14 +376,14 @@ comments from CMU CL: (let ((res (make-hash-table-like original))) (dohash (k cv compared) (let ((ov (gethash k original))) - (when ov - (let ((norm-cnt (/ (vop-stats-count ov) (vop-stats-count cv)))) - (setf (gethash k res) - (make-vop-stats - :name k - :count norm-cnt - :cost (- (/ (vop-stats-cost ov) norm-cnt) - (vop-stats-cost cv)))))))) + (when ov + (let ((norm-cnt (/ (vop-stats-count ov) (vop-stats-count cv)))) + (setf (gethash k res) + (make-vop-stats + :name k + :count norm-cnt + :cost (- (/ (vop-stats-cost ov) norm-cnt) + (vop-stats-cost cv)))))))) res)) (defun combine-stats (&rest tables) @@ -393,44 +393,44 @@ comments from CMU CL: (let ((res (make-hash-table-like (first tables)))) (dolist (table tables) (dohash (k v table) - (let ((found (or (gethash k res) - (setf (gethash k res) (%make-vop-stats k))))) - (incf (vop-stats-count found) (vop-stats-count v)) - (incf (vop-stats-cost found) (vop-stats-cost v))))) + (let ((found (or (gethash k res) + (setf (gethash k res) (%make-vop-stats k))))) + (incf (vop-stats-count found) (vop-stats-count v)) + (incf (vop-stats-cost found) (vop-stats-cost v))))) res)) ;;;; report generation (defun sort-result (table by) (sort (hash-list table) #'> - :key (lambda (x) - (abs (ecase by - (:count (vop-stats-count x)) - (:cost (vop-stats-cost x))))))) + :key (lambda (x) + (abs (ecase by + (:count (vop-stats-count x)) + (:cost (vop-stats-cost x))))))) ;;; Report about VOPs in the list of stats structures. (defun entry-report (entries cut-off compensated compare total-cost) (let ((counter (if (and cut-off (> (length entries) cut-off)) - cut-off - most-positive-fixnum))) + cut-off + most-positive-fixnum))) (dolist (entry entries) (let* ((cost (vop-stats-cost entry)) - (name (vop-stats-name entry)) - (entry-count (vop-stats-count entry)) - (comp-entry (if compare (gethash name compare) entry)) - (count (vop-stats-count comp-entry))) + (name (vop-stats-name entry)) + (entry-count (vop-stats-count entry)) + (comp-entry (if compare (gethash name compare) entry)) + (count (vop-stats-count comp-entry))) (format t "~30<~A~>: ~:[~13:D~;~13,2F~] ~9,2F ~5,2,2F%~%" - (vop-stats-name entry) - compare - (if compare entry-count (round entry-count)) - (/ cost count) - (/ (if compare - (- (vop-stats-cost (gethash name compensated)) - (vop-stats-cost comp-entry)) - cost) - total-cost)) + (vop-stats-name entry) + compare + (if compare entry-count (round entry-count)) + (/ cost count) + (/ (if compare + (- (vop-stats-cost (gethash name compensated)) + (vop-stats-cost comp-entry)) + cost) + total-cost)) (when (zerop (decf counter)) - (format t "[End of top ~W]~%" cut-off)))))) + (format t "[End of top ~W]~%" cut-off)))))) ;;; Divide SORTED into two lists, the first CUT-OFF elements long. Any VOP ;;; names that match one of the report strings are moved into the REPORT list @@ -439,63 +439,63 @@ comments from CMU CL: (if (or (not cut-off) (<= (length sorted) cut-off)) (values sorted ()) (let ((not-cut (subseq sorted 0 cut-off))) - (collect ((select) - (reject)) - (dolist (el (nthcdr cut-off sorted)) - (let ((name (vop-stats-name el))) - (if (matches-pattern name report) - (select el) - (reject el)))) - (values (append not-cut (select)) (reject)))))) + (collect ((select) + (reject)) + (dolist (el (nthcdr cut-off sorted)) + (let ((name (vop-stats-name el))) + (if (matches-pattern name report) + (select el) + (reject el)))) + (values (append not-cut (select)) (reject)))))) ;;; Display information about entries that were not displayed due to the ;;; cut-off. Note: if compare, we find the total cost delta and the geometric ;;; mean of the normalized counts. (defun cut-off-report (other compare total-cost) (let ((rest-cost 0d0) - (rest-count 0d0) - (rest-entry-count (if compare 1d0 0d0))) + (rest-count 0d0) + (rest-entry-count (if compare 1d0 0d0))) (dolist (entry other) (incf rest-cost (vop-stats-cost entry)) (incf rest-count - (vop-stats-count - (if compare - (gethash (vop-stats-name entry) compare) - entry))) + (vop-stats-count + (if compare + (gethash (vop-stats-name entry) compare) + entry))) (if compare - (setq rest-entry-count - (* rest-entry-count (vop-stats-count entry))) - (incf rest-entry-count (vop-stats-count entry)))) + (setq rest-entry-count + (* rest-entry-count (vop-stats-count entry))) + (incf rest-entry-count (vop-stats-count entry)))) (let ((count (if compare - (expt rest-entry-count - (/ (coerce (length other) 'double-float))) - (round rest-entry-count)))) + (expt rest-entry-count + (/ (coerce (length other) 'double-float))) + (round rest-entry-count)))) (format t "~30: ~:[~13:D~;~13,2F~] ~9,2F ~@[~5,2,2F%~]~%" - compare count - (/ rest-cost rest-count) - (unless compare - (/ rest-cost total-cost)))))) + compare count + (/ rest-cost rest-count) + (unless compare + (/ rest-cost total-cost)))))) ;;; Report summary information about the difference between the comparison ;;; and base data sets. (defun compare-report (total-count total-cost compare-total-count - compare-total-cost compensated compare) + compare-total-cost compensated compare) (format t "~30: ~13,2F ~9,2F~%" - (/ total-count compare-total-count) - (/ total-cost compare-total-cost)) + (/ total-count compare-total-count) + (/ total-cost compare-total-cost)) (flet ((frob (a b sign wot) - (multiple-value-bind (cost count) - (cost-summary (hash-difference a b)) - (unless (zerop count) - (format t "~30<~A~>: ~13:D ~9,2F ~5,2,2F%~%" - wot (* sign (round count)) - (* sign (/ cost count)) - (* sign (/ cost compare-total-cost))))))) + (multiple-value-bind (cost count) + (cost-summary (hash-difference a b)) + (unless (zerop count) + (format t "~30<~A~>: ~13:D ~9,2F ~5,2,2F%~%" + wot (* sign (round count)) + (* sign (/ cost count)) + (* sign (/ cost compare-total-cost))))))) (frob compensated compare 1 "Not in comparison") (frob compare compensated -1 "Only in comparison")) (format t "~30: ~13,2E ~9,2E~%" - compare-total-count compare-total-cost)) + compare-total-count compare-total-cost)) ;;; The fraction of system time that we guess happened during GC. (defparameter *gc-system-fraction* 2/3) @@ -503,55 +503,55 @@ comments from CMU CL: ;;; Estimate CPI from CPU time and cycles accounted in profiling information. (defun find-cpi (total-cost user system gc clock) (let ((adj-time (if (zerop gc) - user - (- user (- gc (* system *gc-system-fraction*)))))) + user + (- user (- gc (* system *gc-system-fraction*)))))) (/ (* adj-time clock) total-cost))) ;;; Generate a report from the specified table. (defun generate-report (table &key (cut-off 15) (sort-by :cost) - (costs *native-costs*) - ((:compare uncomp-compare)) - (compare-costs costs) - ignore report - (classes *basic-classes*) - user (system 0d0) (gc 0d0) - (clock 25d6)) + (costs *native-costs*) + ((:compare uncomp-compare)) + (compare-costs costs) + ignore report + (classes *basic-classes*) + user (system 0d0) (gc 0d0) + (clock 25d6)) (let* ((compensated - (classify-costs - (if costs - (compensate-costs table costs ignore) - table) - classes)) - (compare - (when uncomp-compare - (classify-costs - (if compare-costs - (compensate-costs uncomp-compare compare-costs ignore) - uncomp-compare) - classes))) - (compared (if compare - (compare-stats compensated compare) - compensated))) + (classify-costs + (if costs + (compensate-costs table costs ignore) + table) + classes)) + (compare + (when uncomp-compare + (classify-costs + (if compare-costs + (compensate-costs uncomp-compare compare-costs ignore) + uncomp-compare) + classes))) + (compared (if compare + (compare-stats compensated compare) + compensated))) (multiple-value-bind (total-count total-cost) (cost-summary compensated) (multiple-value-bind (compare-total-count compare-total-cost) - (when compare (cost-summary compare)) - (format t "~2&~30 ~13 ~9 ~6:@~%") - (let ((sorted (sort-result compared sort-by)) - (base-total (if compare compare-total-cost total-cost))) - (multiple-value-bind (report other) - (find-cut-off sorted cut-off report) - (entry-report report cut-off compensated compare base-total) - (when other - (cut-off-report other compare base-total)))) - - (when compare - (compare-report total-count total-cost compare-total-count - compare-total-cost compensated compare)) - - (format t "~30: ~13,2E ~9,2E~%" total-count total-cost) - (when user - (format t "~%Cycles per instruction = ~,2F~%" - (find-cpi total-cost user system gc clock)))))) + (when compare (cost-summary compare)) + (format t "~2&~30 ~13 ~9 ~6:@~%") + (let ((sorted (sort-result compared sort-by)) + (base-total (if compare compare-total-cost total-cost))) + (multiple-value-bind (report other) + (find-cut-off sorted cut-off report) + (entry-report report cut-off compensated compare base-total) + (when other + (cut-off-report other compare base-total)))) + + (when compare + (compare-report total-count total-cost compare-total-count + compare-total-cost compensated compare)) + + (format t "~30: ~13,2E ~9,2E~%" total-count total-cost) + (when user + (format t "~%Cycles per instruction = ~,2F~%" + (find-cpi total-cost user system gc clock)))))) (values)) ;;; Read & write VOP stats using hash IO utility. diff --git a/src/code/early-cl.lisp b/src/code/early-cl.lisp index f8a1aa2..4c071dd 100644 --- a/src/code/early-cl.lisp +++ b/src/code/early-cl.lisp @@ -15,7 +15,7 @@ (proclaim '(special sb!xc:*macroexpand-hook*)) ;;; the Common Lisp defined type spec symbols -(defparameter *!standard-type-names* +(defparameter *!standard-type-names* '(array atom bignum bit bit-vector character compiled-function complex cons double-float extended-char fixnum float function hash-table integer keyword list long-float nil null number package diff --git a/src/code/early-defstructs.lisp b/src/code/early-defstructs.lisp index 2883fbd..f7a67a7 100644 --- a/src/code/early-defstructs.lisp +++ b/src/code/early-defstructs.lisp @@ -15,7 +15,7 @@ #.`(progn ,@(mapcar (lambda (args) - `(defstruct ,@args)) - (sb-cold:read-from-file "src/code/early-defstruct-args.lisp-expr"))) + `(defstruct ,@args)) + (sb-cold:read-from-file "src/code/early-defstruct-args.lisp-expr"))) (/show0 "done with early-defstructs.lisp") diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index f87de04..c590c21 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -49,21 +49,21 @@ ;;; Motivated by the mips port. -- CSR, 2002-08-22 (def!type signed-byte-with-a-bite-out (s bite) (cond ((eq s '*) 'integer) - ((and (integerp s) (> s 1)) - (let ((bound (ash 1 (1- s)))) - `(integer ,(- bound) ,(- bound bite 1)))) - (t - (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s)))) + ((and (integerp s) (> s 1)) + (let ((bound (ash 1 (1- s)))) + `(integer ,(- bound) ,(- bound bite 1)))) + (t + (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s)))) (def!type load/store-index (scale lowtag min-offset - &optional (max-offset min-offset)) + &optional (max-offset min-offset)) `(integer ,(- (truncate (+ (ash 1 16) - (* min-offset sb!vm:n-word-bytes) - (- lowtag)) - scale)) - ,(truncate (- (+ (1- (ash 1 16)) lowtag) - (* max-offset sb!vm:n-word-bytes)) - scale))) + (* min-offset sb!vm:n-word-bytes) + (- lowtag)) + scale)) + ,(truncate (- (+ (1- (ash 1 16)) lowtag) + (* max-offset sb!vm:n-word-bytes)) + scale))) ;;; Similar to FUNCTION, but the result type is "exactly" specified: ;;; if it is an object type, then the function returns exactly one @@ -130,27 +130,27 @@ ;;; Is X a list containing a cycle? (defun cyclic-list-p (x) (and (listp x) - (labels ((safe-cddr (x) (if (listp (cdr x)) (cddr x)))) - (do ((y x (safe-cddr y)) - (started-p nil t) - (z x (cdr z))) - ((not (and (consp z) (consp y))) nil) - (when (and started-p (eq y z)) - (return t)))))) + (labels ((safe-cddr (x) (if (listp (cdr x)) (cddr x)))) + (do ((y x (safe-cddr y)) + (started-p nil t) + (z x (cdr z))) + ((not (and (consp z) (consp y))) nil) + (when (and started-p (eq y z)) + (return t)))))) ;;; Is X a (possibly-improper) list of at least N elements? (declaim (ftype (function (t index)) list-of-length-at-least-p)) (defun list-of-length-at-least-p (x n) (or (zerop n) ; since anything can be considered an improper list of length 0 (and (consp x) - (list-of-length-at-least-p (cdr x) (1- n))))) + (list-of-length-at-least-p (cdr x) (1- n))))) (declaim (inline singleton-p)) (defun singleton-p (list) (and (consp list) (null (rest list)))) -;;; Is X is a positive prime integer? +;;; Is X is a positive prime integer? (defun positive-primep (x) ;; This happens to be called only from one place in sbcl-0.7.0, and ;; only for fixnums, we can limit it to fixnums for efficiency. (And @@ -160,14 +160,14 @@ (if (<= x 5) (and (>= x 2) (/= x 4)) (and (not (evenp x)) - (not (zerop (rem x 3))) - (do ((q 6) - (r 1) - (inc 2 (logxor inc 6)) ;; 2,4,2,4... - (d 5 (+ d inc))) - ((or (= r 0) (> d q)) (/= r 0)) - (declare (fixnum inc)) - (multiple-value-setq (q r) (truncate x d)))))) + (not (zerop (rem x 3))) + (do ((q 6) + (r 1) + (inc 2 (logxor inc 6)) ;; 2,4,2,4... + (d 5 (+ d inc))) + ((or (= r 0) (> d q)) (/= r 0)) + (declare (fixnum inc)) + (multiple-value-setq (q r) (truncate x d)))))) ;;; Could this object contain other objects? (This is important to ;;; the implementation of things like *PRINT-CIRCLE* and the dumper.) @@ -196,15 +196,15 @@ (defun collect-list-expander (n-value n-tail forms) (let ((n-res (gensym))) `(progn - ,@(mapcar (lambda (form) - `(let ((,n-res (cons ,form nil))) - (cond (,n-tail - (setf (cdr ,n-tail) ,n-res) - (setq ,n-tail ,n-res)) - (t - (setq ,n-tail ,n-res ,n-value ,n-res))))) - forms) - ,n-value)))) + ,@(mapcar (lambda (form) + `(let ((,n-res (cons ,form nil))) + (cond (,n-tail + (setf (cdr ,n-tail) ,n-res) + (setq ,n-tail ,n-res)) + (t + (setq ,n-tail ,n-res ,n-value ,n-res))))) + forms) + ,n-value)))) ;;; Collect some values somehow. Each of the collections specifies a ;;; bunch of things which collected during the evaluation of the body @@ -227,30 +227,30 @@ ;;; in the functional position, including macros and lambdas. (defmacro collect (collections &body body) (let ((macros ()) - (binds ())) + (binds ())) (dolist (spec collections) (unless (proper-list-of-length-p spec 1 3) - (error "malformed collection specifier: ~S" spec)) + (error "malformed collection specifier: ~S" spec)) (let* ((name (first spec)) - (default (second spec)) - (kind (or (third spec) 'collect)) - (n-value (gensym (concatenate 'string - (symbol-name name) - "-N-VALUE-")))) - (push `(,n-value ,default) binds) - (if (eq kind 'collect) - (let ((n-tail (gensym (concatenate 'string - (symbol-name name) - "-N-TAIL-")))) - (if default - (push `(,n-tail (last ,n-value)) binds) - (push n-tail binds)) - (push `(,name (&rest args) - (collect-list-expander ',n-value ',n-tail args)) - macros)) - (push `(,name (&rest args) - (collect-normal-expander ',n-value ',kind args)) - macros)))) + (default (second spec)) + (kind (or (third spec) 'collect)) + (n-value (gensym (concatenate 'string + (symbol-name name) + "-N-VALUE-")))) + (push `(,n-value ,default) binds) + (if (eq kind 'collect) + (let ((n-tail (gensym (concatenate 'string + (symbol-name name) + "-N-TAIL-")))) + (if default + (push `(,n-tail (last ,n-value)) binds) + (push n-tail binds)) + (push `(,name (&rest args) + (collect-list-expander ',n-value ',n-tail args)) + macros)) + (push `(,name (&rest args) + (collect-normal-expander ',n-value ',kind args)) + macros)))) `(macrolet ,macros (let* ,(nreverse binds) ,@body)))) ;;;; some old-fashioned functions. (They're not just for old-fashioned @@ -288,7 +288,7 @@ ;; just define ASSQ explicitly in terms of more primitive ;; operations: (dolist (pair alist) - ;; though it may look more natural to write this as + ;; though it may look more natural to write this as ;; (AND PAIR (EQ (CAR PAIR) ITEM)) ;; the temptation to do so should be resisted, as pointed out by PFD ;; sbcl-devel 2003-08-16, as NIL elements are rare in association @@ -302,13 +302,13 @@ (defun delq (item list) (let ((list list)) (do ((x list (cdr x)) - (splice '())) - ((endp x) list) + (splice '())) + ((endp x) list) (cond ((eq item (car x)) - (if (null splice) - (setq list (cdr x)) - (rplacd splice (cdr x)))) - (t (setq splice x)))))) ; Move splice along to include element. + (if (null splice) + (setq list (cdr x)) + (rplacd splice (cdr x)))) + (t (setq splice x)))))) ; Move splice along to include element. ;;; like (POSITION .. :TEST #'EQ): @@ -358,27 +358,27 @@ ;;; just like DOLIST, but with one-dimensional arrays (defmacro dovector ((elt vector &optional result) &rest forms) (let ((index (gensym)) - (length (gensym)) - (vec (gensym))) + (length (gensym)) + (vec (gensym))) `(let ((,vec ,vector)) (declare (type vector ,vec)) (do ((,index 0 (1+ ,index)) - (,length (length ,vec))) - ((>= ,index ,length) ,result) - (let ((,elt (aref ,vec ,index))) - ,@forms))))) + (,length (length ,vec))) + ((>= ,index ,length) ,result) + (let ((,elt (aref ,vec ,index))) + ,@forms))))) ;;; Iterate over the entries in a HASH-TABLE. (defmacro dohash ((key-var value-var table &optional result) &body body) (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (let ((gen (gensym)) - (n-more (gensym))) + (n-more (gensym))) `(with-hash-table-iterator (,gen ,table) - (loop - (multiple-value-bind (,n-more ,key-var ,value-var) (,gen) - ,@decls - (unless ,n-more (return ,result)) - ,@forms)))))) + (loop + (multiple-value-bind (,n-more ,key-var ,value-var) (,gen) + ,@decls + (unless ,n-more (return ,result)) + ,@forms)))))) ;;;; hash cache utility @@ -425,34 +425,34 @@ ;;; in type system definitions so that caches will be created ;;; before top level forms run.) (defmacro define-hash-cache (name args &key hash-function hash-bits default - (init-wrapper 'progn) - (values 1)) + (init-wrapper 'progn) + (values 1)) (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*")) - (nargs (length args)) - (entry-size (+ nargs values)) - (size (ash 1 hash-bits)) - (total-size (* entry-size size)) - (default-values (if (and (consp default) (eq (car default) 'values)) - (cdr default) - (list default))) - (n-index (gensym)) - (n-cache (gensym))) + (nargs (length args)) + (entry-size (+ nargs values)) + (size (ash 1 hash-bits)) + (total-size (* entry-size size)) + (default-values (if (and (consp default) (eq (car default) 'values)) + (cdr default) + (list default))) + (n-index (gensym)) + (n-cache (gensym))) (unless (= (length default-values) values) (error "The number of default values ~S differs from :VALUES ~W." - default values)) + default values)) (collect ((inlines) - (forms) - (inits) - (tests) - (sets) - (arg-vars) - (values-indices) - (values-names)) + (forms) + (inits) + (tests) + (sets) + (arg-vars) + (values-indices) + (values-names)) (dotimes (i values) - (values-indices `(+ ,n-index ,(+ nargs i))) - (values-names (gensym))) + (values-indices `(+ ,n-index ,(+ nargs i))) + (values-names (gensym))) (let ((n 0)) (dolist (arg args) (unless (= (length arg) 2) @@ -465,119 +465,119 @@ (incf n))) (when *profile-hash-cache* - (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*")) - (n-miss (symbolicate "*" name "-CACHE-MISSES*"))) - (inits `(setq ,n-probe 0)) - (inits `(setq ,n-miss 0)) - (forms `(defvar ,n-probe)) - (forms `(defvar ,n-miss)) - (forms `(declaim (fixnum ,n-miss ,n-probe))))) + (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*")) + (n-miss (symbolicate "*" name "-CACHE-MISSES*"))) + (inits `(setq ,n-probe 0)) + (inits `(setq ,n-miss 0)) + (forms `(defvar ,n-probe)) + (forms `(defvar ,n-miss)) + (forms `(declaim (fixnum ,n-miss ,n-probe))))) (let ((fun-name (symbolicate name "-CACHE-LOOKUP"))) - (inlines fun-name) - (forms - `(defun ,fun-name ,(arg-vars) - ,@(when *profile-hash-cache* - `((incf ,(symbolicate "*" name "-CACHE-PROBES*")))) - (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size)) - (,n-cache ,var-name)) - (declare (type fixnum ,n-index)) - (cond ((and ,@(tests)) - (values ,@(mapcar (lambda (x) `(svref ,n-cache ,x)) - (values-indices)))) - (t - ,@(when *profile-hash-cache* - `((incf ,(symbolicate "*" name "-CACHE-MISSES*")))) - ,default)))))) + (inlines fun-name) + (forms + `(defun ,fun-name ,(arg-vars) + ,@(when *profile-hash-cache* + `((incf ,(symbolicate "*" name "-CACHE-PROBES*")))) + (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size)) + (,n-cache ,var-name)) + (declare (type fixnum ,n-index)) + (cond ((and ,@(tests)) + (values ,@(mapcar (lambda (x) `(svref ,n-cache ,x)) + (values-indices)))) + (t + ,@(when *profile-hash-cache* + `((incf ,(symbolicate "*" name "-CACHE-MISSES*")))) + ,default)))))) (let ((fun-name (symbolicate name "-CACHE-ENTER"))) - (inlines fun-name) - (forms - `(defun ,fun-name (,@(arg-vars) ,@(values-names)) - (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size)) - (,n-cache ,var-name)) - (declare (type fixnum ,n-index)) - ,@(sets) - ,@(mapcar (lambda (i val) - `(setf (svref ,n-cache ,i) ,val)) - (values-indices) - (values-names)) - (values))))) + (inlines fun-name) + (forms + `(defun ,fun-name (,@(arg-vars) ,@(values-names)) + (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size)) + (,n-cache ,var-name)) + (declare (type fixnum ,n-index)) + ,@(sets) + ,@(mapcar (lambda (i val) + `(setf (svref ,n-cache ,i) ,val)) + (values-indices) + (values-names)) + (values))))) (let ((fun-name (symbolicate name "-CACHE-CLEAR"))) - (forms - `(defun ,fun-name () - (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size)) - (,n-cache ,var-name)) - ((minusp ,n-index)) - (declare (type fixnum ,n-index)) - ,@(collect ((arg-sets)) - (dotimes (i nargs) - (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil))) - (arg-sets)) - ,@(mapcar (lambda (i val) - `(setf (svref ,n-cache ,i) ,val)) - (values-indices) - default-values)) - (values))) - (forms `(,fun-name))) + (forms + `(defun ,fun-name () + (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size)) + (,n-cache ,var-name)) + ((minusp ,n-index)) + (declare (type fixnum ,n-index)) + ,@(collect ((arg-sets)) + (dotimes (i nargs) + (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil))) + (arg-sets)) + ,@(mapcar (lambda (i val) + `(setf (svref ,n-cache ,i) ,val)) + (values-indices) + default-values)) + (values))) + (forms `(,fun-name))) (inits `(unless (boundp ',var-name) - (setq ,var-name (make-array ,total-size)))) + (setq ,var-name (make-array ,total-size)))) #!+sb-show (inits `(setq *hash-caches-initialized-p* t)) `(progn - (defvar ,var-name) - (declaim (type (simple-vector ,total-size) ,var-name)) - #!-sb-fluid (declaim (inline ,@(inlines))) - (,init-wrapper ,@(inits)) - ,@(forms) - ',name)))) + (defvar ,var-name) + (declaim (type (simple-vector ,total-size) ,var-name)) + #!-sb-fluid (declaim (inline ,@(inlines))) + (,init-wrapper ,@(inits)) + ,@(forms) + ',name)))) ;;; some syntactic sugar for defining a function whose values are ;;; cached by DEFINE-HASH-CACHE (defmacro defun-cached ((name &rest options &key (values 1) default - &allow-other-keys) - args &body body-decls-doc) + &allow-other-keys) + args &body body-decls-doc) (let ((default-values (if (and (consp default) (eq (car default) 'values)) - (cdr default) - (list default))) - (arg-names (mapcar #'car args))) + (cdr default) + (list default))) + (arg-names (mapcar #'car args))) (collect ((values-names)) (dotimes (i values) - (values-names (gensym))) + (values-names (gensym))) (multiple-value-bind (body decls doc) (parse-body body-decls-doc) - `(progn - (define-hash-cache ,name ,args ,@options) - (defun ,name ,arg-names - ,@decls - ,doc - (cond #!+sb-show - ((not (boundp '*hash-caches-initialized-p*)) - ;; This shouldn't happen, but it did happen to me - ;; when revising the type system, and it's a lot - ;; easier to figure out what what's going on with - ;; that kind of problem if the system can be kept - ;; alive until cold boot is complete. The recovery - ;; mechanism should definitely be conditional on - ;; some debugging feature (e.g. SB-SHOW) because - ;; it's big, duplicating all the BODY code. -- WHN - (/show0 ,name " too early in cold init, uncached") - (/show0 ,(first arg-names) "=..") - (/hexstr ,(first arg-names)) - ,@body) - (t - (multiple-value-bind ,(values-names) - (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names) - (if (and ,@(mapcar (lambda (val def) - `(eq ,val ,def)) - (values-names) default-values)) - (multiple-value-bind ,(values-names) - (progn ,@body) - (,(symbolicate name "-CACHE-ENTER") ,@arg-names - ,@(values-names)) - (values ,@(values-names))) - (values ,@(values-names)))))))))))) + `(progn + (define-hash-cache ,name ,args ,@options) + (defun ,name ,arg-names + ,@decls + ,doc + (cond #!+sb-show + ((not (boundp '*hash-caches-initialized-p*)) + ;; This shouldn't happen, but it did happen to me + ;; when revising the type system, and it's a lot + ;; easier to figure out what what's going on with + ;; that kind of problem if the system can be kept + ;; alive until cold boot is complete. The recovery + ;; mechanism should definitely be conditional on + ;; some debugging feature (e.g. SB-SHOW) because + ;; it's big, duplicating all the BODY code. -- WHN + (/show0 ,name " too early in cold init, uncached") + (/show0 ,(first arg-names) "=..") + (/hexstr ,(first arg-names)) + ,@body) + (t + (multiple-value-bind ,(values-names) + (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names) + (if (and ,@(mapcar (lambda (val def) + `(eq ,val ,def)) + (values-names) default-values)) + (multiple-value-bind ,(values-names) + (progn ,@body) + (,(symbolicate name "-CACHE-ENTER") ,@arg-names + ,@(values-names)) + (values ,@(values-names))) + (values ,@(values-names)))))))))))) (defmacro define-cached-synonym (name &optional (original (symbolicate "%" name))) @@ -609,8 +609,8 @@ ((eql x y) t) ((consp x) (and (consp y) - (eql (car x) (car y)) - (equal-but-no-car-recursion (cdr x) (cdr y)))) + (eql (car x) (car y)) + (equal-but-no-car-recursion (cdr x) (cdr y)))) (t nil))) ;;;; package idioms @@ -622,9 +622,9 @@ (defun %find-package-or-lose (package-designator) (or (find-package package-designator) (error 'sb!kernel:simple-package-error - :package package-designator - :format-control "The name ~S does not designate any package." - :format-arguments (list package-designator)))) + :package package-designator + :format-control "The name ~S does not designate any package." + :format-arguments (list package-designator)))) ;;; ANSI specifies (in the section for FIND-PACKAGE) that the ;;; consequences of most operations on deleted packages are @@ -632,11 +632,11 @@ (defun find-undeleted-package-or-lose (package-designator) (let ((maybe-result (%find-package-or-lose package-designator))) (if (package-name maybe-result) ; if not deleted - maybe-result - (error 'sb!kernel:simple-package-error - :package maybe-result - :format-control "The package ~S has been deleted." - :format-arguments (list maybe-result))))) + maybe-result + (error 'sb!kernel:simple-package-error + :package maybe-result + :format-control "The package ~S has been deleted." + :format-arguments (list maybe-result))))) ;;;; various operations on names @@ -651,10 +651,10 @@ (defun legal-fun-name-or-type-error (name) (unless (legal-fun-name-p name) (error 'simple-type-error - :datum name - :expected-type 'function-name - :format-control "invalid function name: ~S" - :format-arguments (list name)))) + :datum name + :expected-type 'function-name + :format-control "invalid function name: ~S" + :format-arguments (list name)))) ;;; Given a function name, return the symbol embedded in it. ;;; @@ -667,22 +667,22 @@ (declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name)) (defun fun-name-block-name (fun-name) (cond ((symbolp fun-name) - fun-name) - ((consp fun-name) - (multiple-value-bind (legalp block-name) - (valid-function-name-p fun-name) - (if legalp - block-name - (error "not legal as a function name: ~S" fun-name)))) - (t - (error "not legal as a function name: ~S" fun-name)))) + fun-name) + ((consp fun-name) + (multiple-value-bind (legalp block-name) + (valid-function-name-p fun-name) + (if legalp + block-name + (error "not legal as a function name: ~S" fun-name)))) + (t + (error "not legal as a function name: ~S" fun-name)))) (defun looks-like-name-of-special-var-p (x) (and (symbolp x) (let ((name (symbol-name x))) - (and (> (length name) 2) ; to exclude '* and '** - (char= #\* (aref name 0)) - (char= #\* (aref name (1- (length name)))))))) + (and (> (length name) 2) ; to exclude '* and '** + (char= #\* (aref name 0)) + (char= #\* (aref name (1- (length name)))))))) ;;; Some symbols are defined by ANSI to be self-evaluating. Return ;;; non-NIL for such symbols (and make the non-NIL value a traditional @@ -691,13 +691,13 @@ (defun symbol-self-evaluating-p (symbol) (declare (type symbol symbol)) (cond ((eq symbol t) - "Veritas aeterna. (can't change T)") - ((eq symbol nil) - "Nihil ex nihil. (can't change NIL)") - ((keywordp symbol) - "Keyword values can't be changed.") - (t - nil))) + "Veritas aeterna. (can't change T)") + ((eq symbol nil) + "Nihil ex nihil. (can't change NIL)") + ((keywordp symbol) + "Keyword values can't be changed.") + (t + nil))) ;;; This function is to be called just before a change which would ;;; affect the symbol value. (We don't absolutely have to call this @@ -726,12 +726,12 @@ ;;; the linking eventually, so as long as #'FOO and #'BAR aren't ;;; needed until "cold toplevel forms" have executed, it's OK. (defmacro cold-fset (name lambda) - (style-warn + (style-warn "~@" name) ;; We convert the LAMBDA expression to the corresponding NAMED-LAMBDA - ;; expression so that the compiler can use NAME in debug names etc. + ;; expression so that the compiler can use NAME in debug names etc. (destructuring-bind (lambda-symbol &rest lambda-rest) lambda (assert (eql lambda-symbol 'lambda)) ; else dunno how to do conversion `(setf (fdefinition ',name) @@ -755,19 +755,19 @@ ;;; bound to the corresponding temporary variable. (defmacro once-only (specs &body body) (named-let frob ((specs specs) - (body body)) + (body body)) (if (null specs) - `(progn ,@body) - (let ((spec (first specs))) - ;; FIXME: should just be DESTRUCTURING-BIND of SPEC - (unless (proper-list-of-length-p spec 2) - (error "malformed ONCE-ONLY binding spec: ~S" spec)) - (let* ((name (first spec)) - (exp-temp (gensym (symbol-name name)))) - `(let ((,exp-temp ,(second spec)) - (,name (gensym "ONCE-ONLY-"))) - `(let ((,,name ,,exp-temp)) - ,,(frob (rest specs) body)))))))) + `(progn ,@body) + (let ((spec (first specs))) + ;; FIXME: should just be DESTRUCTURING-BIND of SPEC + (unless (proper-list-of-length-p spec 2) + (error "malformed ONCE-ONLY binding spec: ~S" spec)) + (let* ((name (first spec)) + (exp-temp (gensym (symbol-name name)))) + `(let ((,exp-temp ,(second spec)) + (,name (gensym "ONCE-ONLY-"))) + `(let ((,,name ,,exp-temp)) + ,,(frob (rest specs) body)))))))) ;;;; various error-checking utilities @@ -811,8 +811,8 @@ (defun bug (format-control &rest format-arguments) (error 'bug - :format-control format-control - :format-arguments format-arguments)) + :format-control format-control + :format-arguments format-arguments)) (defmacro enforce-type (value type) (once-only ((value value)) @@ -822,11 +822,11 @@ (defun %failed-enforce-type (value type) ;; maybe should be TYPE-BUG, subclass of BUG? If it is changed, ;; check uses of it in user-facing code (e.g. WARN) - (error 'simple-type-error - :datum value - :expected-type type - :format-control "~@<~S ~_is not a ~_~S~:>" - :format-arguments (list value type))) + (error 'simple-type-error + :datum value + :expected-type type + :format-control "~@<~S ~_is not a ~_~S~:>" + :format-arguments (list value type))) ;;; Return a function like FUN, but expecting its (two) arguments in ;;; the opposite order that FUN does. @@ -851,8 +851,8 @@ ;;; some commonly-occuring CONSTANTLY forms (macrolet ((def-constantly-fun (name constant-expr) - `(setf (symbol-function ',name) - (constantly ,constant-expr)))) + `(setf (symbol-function ',name) + (constantly ,constant-expr)))) (def-constantly-fun constantly-t t) (def-constantly-fun constantly-nil nil) (def-constantly-fun constantly-0 0)) @@ -864,8 +864,8 @@ (case (car x) ((:not not) (if (cddr x) - (error "too many subexpressions in feature expression: ~S" x) - (not (featurep (cadr x))))) + (error "too many subexpressions in feature expression: ~S" x) + (not (featurep (cadr x))))) ((:and and) (every #'featurep (cdr x))) ((:or or) (some #'featurep (cdr x))) (t @@ -893,10 +893,10 @@ (declare (type symbol old new)) ;; Walk through RESULT renaming any OLD key argument to NEW. (do ((in-result result (cddr in-result))) - ((null in-result)) - (declare (type list in-result)) - (when (eq (car in-result) old) - (setf (car in-result) new)))))) + ((null in-result)) + (declare (type list in-result)) + (when (eq (car in-result) old) + (setf (car in-result) new)))))) ;;; ANSI Common Lisp's READ-SEQUENCE function, unlike most of the ;;; other ANSI input functions, is defined to communicate end of file @@ -908,9 +908,9 @@ ;; implementation using READ-SEQUENCE #-no-ansi-read-sequence (let ((read-end (read-sequence sequence - stream - :start start - :end end))) + stream + :start start + :end end))) (unless (= read-end end) (error 'end-of-file :stream stream)) (values)) @@ -920,12 +920,12 @@ (aver (<= start end)) (let ((etype (stream-element-type stream))) (cond ((equal etype '(unsigned-byte 8)) - (do ((i start (1+ i))) - ((>= i end) - (values)) - (setf (aref sequence i) - (read-byte stream)))) - (t (error "unsupported element type ~S" etype)))))) + (do ((i start (1+ i))) + ((>= i end) + (values)) + (setf (aref sequence i) + (read-byte stream)))) + (t (error "unsupported element type ~S" etype)))))) ;;;; utilities for two-VALUES predicates @@ -958,24 +958,24 @@ (let ((certain? t)) (dolist (i list (values nil certain?)) (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) - (if sub-certain? - (when sub-value (return (values t t))) - (setf certain? nil)))))) + (if sub-certain? + (when sub-value (return (values t t))) + (setf certain? nil)))))) (defun every/type (op thing list) (declare (type function op)) (let ((certain? t)) (dolist (i list (if certain? (values t t) (values nil nil))) (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) - (if sub-certain? - (unless sub-value (return (values nil t))) - (setf certain? nil)))))) + (if sub-certain? + (unless sub-value (return (values nil t))) + (setf certain? nil)))))) ;;;; DEFPRINTER ;;; These functions are called by the expansion of the DEFPRINTER ;;; macro to do the actual printing. (declaim (ftype (function (symbol t stream) (values)) - defprinter-prin1 defprinter-princ)) + defprinter-prin1 defprinter-princ)) (defun defprinter-prin1 (name value stream) (defprinter-prinx #'prin1 name value stream)) (defun defprinter-princ (name value stream) @@ -1014,57 +1014,57 @@ ;;; The structure being printed is bound to STRUCTURE and the stream ;;; is bound to STREAM. (defmacro defprinter ((name - &key - (conc-name (concatenate 'simple-string - (symbol-name name) - "-")) - identity) - &rest slot-descs) + &key + (conc-name (concatenate 'simple-string + (symbol-name name) + "-")) + identity) + &rest slot-descs) (let ((first? t) - maybe-print-space - (reversed-prints nil) - (stream (gensym "STREAM"))) + maybe-print-space + (reversed-prints nil) + (stream (gensym "STREAM"))) (flet ((sref (slot-name) - `(,(symbolicate conc-name slot-name) structure))) + `(,(symbolicate conc-name slot-name) structure))) (dolist (slot-desc slot-descs) - (if first? - (setf maybe-print-space nil - first? nil) - (setf maybe-print-space `(defprinter-print-space ,stream))) - (cond ((atom slot-desc) - (push maybe-print-space reversed-prints) - (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream) - reversed-prints)) - (t - (let ((sname (first slot-desc)) - (test t)) - (collect ((stuff)) - (do ((option (rest slot-desc) (cddr option))) - ((null option) - (push `(let ((,sname ,(sref sname))) - (when ,test - ,maybe-print-space - ,@(or (stuff) - `((defprinter-prin1 - ',sname ,sname ,stream))))) - reversed-prints)) - (case (first option) - (:prin1 - (stuff `(defprinter-prin1 - ',sname ,(second option) ,stream))) - (:princ - (stuff `(defprinter-princ - ',sname ,(second option) ,stream))) - (:test (setq test (second option))) - (t - (error "bad option: ~S" (first option))))))))))) + (if first? + (setf maybe-print-space nil + first? nil) + (setf maybe-print-space `(defprinter-print-space ,stream))) + (cond ((atom slot-desc) + (push maybe-print-space reversed-prints) + (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream) + reversed-prints)) + (t + (let ((sname (first slot-desc)) + (test t)) + (collect ((stuff)) + (do ((option (rest slot-desc) (cddr option))) + ((null option) + (push `(let ((,sname ,(sref sname))) + (when ,test + ,maybe-print-space + ,@(or (stuff) + `((defprinter-prin1 + ',sname ,sname ,stream))))) + reversed-prints)) + (case (first option) + (:prin1 + (stuff `(defprinter-prin1 + ',sname ,(second option) ,stream))) + (:princ + (stuff `(defprinter-princ + ',sname ,(second option) ,stream))) + (:test (setq test (second option))) + (t + (error "bad option: ~S" (first option))))))))))) `(def!method print-object ((structure ,name) ,stream) (pprint-logical-block (,stream nil) - (print-unreadable-object (structure - ,stream - :type t - :identity ,identity) - ,@(nreverse reversed-prints)))))) + (print-unreadable-object (structure + ,stream + :type t + :identity ,identity) + ,@(nreverse reversed-prints)))))) ;;;; etc. @@ -1076,8 +1076,8 @@ (defun deprecation-warning (bad-name &optional good-name) (warn "using deprecated ~S~@[, should use ~S instead~]" - bad-name - good-name)) + bad-name + good-name)) ;;; Anaphoric macros (defmacro awhen (test &body body) @@ -1150,25 +1150,25 @@ (defun %with-rebound-io-syntax (function) (declare (type function function)) (let ((*package* *package*) - (*print-array* *print-array*) - (*print-base* *print-base*) - (*print-case* *print-case*) - (*print-circle* *print-circle*) - (*print-escape* *print-escape*) - (*print-gensym* *print-gensym*) - (*print-length* *print-length*) - (*print-level* *print-level*) - (*print-lines* *print-lines*) - (*print-miser-width* *print-miser-width*) - (*print-pretty* *print-pretty*) - (*print-radix* *print-radix*) - (*print-readably* *print-readably*) - (*print-right-margin* *print-right-margin*) - (*read-base* *read-base*) - (*read-default-float-format* *read-default-float-format*) - (*read-eval* *read-eval*) - (*read-suppress* *read-suppress*) - (*readtable* *readtable*)) + (*print-array* *print-array*) + (*print-base* *print-base*) + (*print-case* *print-case*) + (*print-circle* *print-circle*) + (*print-escape* *print-escape*) + (*print-gensym* *print-gensym*) + (*print-length* *print-length*) + (*print-level* *print-level*) + (*print-lines* *print-lines*) + (*print-miser-width* *print-miser-width*) + (*print-pretty* *print-pretty*) + (*print-radix* *print-radix*) + (*print-readably* *print-readably*) + (*print-right-margin* *print-right-margin*) + (*read-base* *read-base*) + (*read-default-float-format* *read-default-float-format*) + (*read-eval* *read-eval*) + (*read-suppress* *read-suppress*) + (*readtable* *readtable*)) (funcall function))) ;;; Bind a few "potentially dangerous" printer control variables to diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index d72d5f4..a5aff3d 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -35,38 +35,38 @@ (macrolet ((define-fasl-format-features () (let (;; master value for *F-P-A-F-F* - (fpaff '(:sb-thread :sb-package-locks :sb-unicode))) - `(progn - ;; a list of *(SHEBANG-)FEATURES* flags which affect - ;; binary compatibility, i.e. which must be the same - ;; between the SBCL which compiles the code and the - ;; SBCL which executes the code - ;; - ;; This is a property of SBCL executables in the - ;; abstract, not of this particular SBCL executable, - ;; so any flag in this list may or may not be present - ;; in the *FEATURES* list of this particular build. - (defparameter *features-potentially-affecting-fasl-format* - ',fpaff) - ;; a string representing flags of *F-P-A-F-F* which - ;; are in this particular build - ;; - ;; (A list is the natural logical representation for - ;; this, but we represent it as a string because - ;; that's physically convenient for writing to and - ;; reading from fasl files, and because we don't - ;; need to do anything sophisticated with its - ;; logical structure, just test it for equality.) - (defparameter *features-affecting-fasl-format* - ,(let ((*print-pretty* nil)) - (prin1-to-string - (sort - (copy-seq - (intersection sb-cold:*shebang-features* fpaff)) - #'string< - :key #'symbol-name)))))))) + (fpaff '(:sb-thread :sb-package-locks :sb-unicode))) + `(progn + ;; a list of *(SHEBANG-)FEATURES* flags which affect + ;; binary compatibility, i.e. which must be the same + ;; between the SBCL which compiles the code and the + ;; SBCL which executes the code + ;; + ;; This is a property of SBCL executables in the + ;; abstract, not of this particular SBCL executable, + ;; so any flag in this list may or may not be present + ;; in the *FEATURES* list of this particular build. + (defparameter *features-potentially-affecting-fasl-format* + ',fpaff) + ;; a string representing flags of *F-P-A-F-F* which + ;; are in this particular build + ;; + ;; (A list is the natural logical representation for + ;; this, but we represent it as a string because + ;; that's physically convenient for writing to and + ;; reading from fasl files, and because we don't + ;; need to do anything sophisticated with its + ;; logical structure, just test it for equality.) + (defparameter *features-affecting-fasl-format* + ,(let ((*print-pretty* nil)) + (prin1-to-string + (sort + (copy-seq + (intersection sb-cold:*shebang-features* fpaff)) + #'string< + :key #'symbol-name)))))))) (define-fasl-format-features)) - + ;;; the code for a character which terminates a fasl file header (def!constant +fasl-header-string-stop-char-code+ 255) @@ -95,10 +95,10 @@ ;;; I think I renumbered everything again ;;; simple-array-unsigned-byte-7, probably ;;; (thanks to pfdietz) -;;; 45: (2003-10-02) I (WHN) incremented the version for the 0.8.4 +;;; 45: (2003-10-02) I (WHN) incremented the version for the 0.8.4 ;;; release because I couldn't immediately convince myself that ;;; .fasl files could never possibly ever refer to the SB-C -;;; CONTINUATION-related data types which were changed +;;; CONTINUATION-related data types which were changed ;;; incompatibly in 0.8.3.62. ;;; 46: (2003-11-11) Tim Daly, Jr. (and Christophe Rhodes) reported ;;; .fasl incompatibility on sbcl-devel 2003-11-09. @@ -148,8 +148,8 @@ ;;; which will perform the operation (defvar *fop-funs* (make-array 256 - :initial-element (lambda () - (error "corrupt fasl file: losing FOP")))) + :initial-element (lambda () + (error "corrupt fasl file: losing FOP")))) ;;;; variables diff --git a/src/code/early-float.lisp b/src/code/early-float.lisp index edddac1..8f470ea 100644 --- a/src/code/early-float.lisp +++ b/src/code/early-float.lisp @@ -25,26 +25,26 @@ ;;; special values, etc. (defun single-from-bits (sign exp sig) (declare (type bit sign) (type (unsigned-byte 24) sig) - (type (unsigned-byte 8) exp)) + (type (unsigned-byte 8) exp)) (make-single-float (dpb exp sb!vm:single-float-exponent-byte - (dpb sig sb!vm:single-float-significand-byte - (if (zerop sign) 0 -1))))) + (dpb sig sb!vm:single-float-significand-byte + (if (zerop sign) 0 -1))))) (defun double-from-bits (sign exp sig) (declare (type bit sign) (type (unsigned-byte 53) sig) - (type (unsigned-byte 11) exp)) + (type (unsigned-byte 11) exp)) (make-double-float (dpb exp sb!vm:double-float-exponent-byte - (dpb (ash sig -32) - sb!vm:double-float-significand-byte - (if (zerop sign) 0 -1))) - (ldb (byte 32 0) sig))) + (dpb (ash sig -32) + sb!vm:double-float-significand-byte + (if (zerop sign) 0 -1))) + (ldb (byte 32 0) sig))) #!+(and long-float x86) (defun long-from-bits (sign exp sig) (declare (type bit sign) (type (unsigned-byte 64) sig) - (type (unsigned-byte 15) exp)) + (type (unsigned-byte 15) exp)) (make-long-float (logior (ash sign 15) exp) - (ldb (byte 32 32) sig) - (ldb (byte 32 0) sig))) + (ldb (byte 32 32) sig) + (ldb (byte 32 0) sig))) ) ; EVAL-WHEN @@ -81,7 +81,7 @@ #!+(and long-float x86) (defconstant least-positive-normalized-long-float (long-from-bits 0 sb!vm:long-float-normal-exponent-min - (ash sb!vm:long-float-hidden-bit 32))) + (ash sb!vm:long-float-hidden-bit 32))) (defconstant least-negative-normalized-double-float (double-from-bits 1 sb!vm:double-float-normal-exponent-min 0)) #!-long-float @@ -90,25 +90,25 @@ #!+(and long-float x86) (defconstant least-negative-normalized-long-float (long-from-bits 1 sb!vm:long-float-normal-exponent-min - (ash sb!vm:long-float-hidden-bit 32))) + (ash sb!vm:long-float-hidden-bit 32))) (defconstant most-positive-single-float (single-from-bits 0 sb!vm:single-float-normal-exponent-max - (ldb sb!vm:single-float-significand-byte -1))) + (ldb sb!vm:single-float-significand-byte -1))) (defconstant most-positive-short-float most-positive-single-float) (defconstant most-negative-single-float (single-from-bits 1 sb!vm:single-float-normal-exponent-max - (ldb sb!vm:single-float-significand-byte -1))) + (ldb sb!vm:single-float-significand-byte -1))) (defconstant most-negative-short-float most-negative-single-float) (defconstant most-positive-double-float (double-from-bits 0 sb!vm:double-float-normal-exponent-max - (ldb (byte sb!vm:double-float-digits 0) -1))) + (ldb (byte sb!vm:double-float-digits 0) -1))) (defconstant most-positive-long-float most-positive-double-float) (defconstant most-negative-double-float (double-from-bits 1 sb!vm:double-float-normal-exponent-max - (ldb (byte sb!vm:double-float-digits 0) -1))) + (ldb (byte sb!vm:double-float-digits 0) -1))) (defconstant most-negative-long-float most-negative-double-float) ;;; We don't want to do these DEFCONSTANTs at cross-compilation time, @@ -137,7 +137,7 @@ #!+(and long-float x86) (defconstant long-float-positive-infinity (long-from-bits 0 (1+ sb!vm:long-float-normal-exponent-max) - (ash sb!vm:long-float-hidden-bit 32))) + (ash sb!vm:long-float-hidden-bit 32))) (defconstant double-float-negative-infinity (double-from-bits 1 (1+ sb!vm:double-float-normal-exponent-max) 0)) #!+(not long-float) @@ -146,25 +146,25 @@ #!+(and long-float x86) (defconstant long-float-negative-infinity (long-from-bits 1 (1+ sb!vm:long-float-normal-exponent-max) - (ash sb!vm:long-float-hidden-bit 32))) + (ash sb!vm:long-float-hidden-bit 32))) ) ; LET-to-suppress-possible-EVAL-WHENs (defconstant single-float-epsilon (single-from-bits 0 (- sb!vm:single-float-bias - (1- sb!vm:single-float-digits)) 1)) + (1- sb!vm:single-float-digits)) 1)) (defconstant short-float-epsilon single-float-epsilon) (defconstant single-float-negative-epsilon (single-from-bits 0 (- sb!vm:single-float-bias sb!vm:single-float-digits) 1)) (defconstant short-float-negative-epsilon single-float-negative-epsilon) (defconstant double-float-epsilon (double-from-bits 0 (- sb!vm:double-float-bias - (1- sb!vm:double-float-digits)) 1)) + (1- sb!vm:double-float-digits)) 1)) #!-long-float (defconstant long-float-epsilon double-float-epsilon) #!+(and long-float x86) (defconstant long-float-epsilon (long-from-bits 0 (- sb!vm:long-float-bias (1- sb!vm:long-float-digits)) - (+ 1 (ash sb!vm:long-float-hidden-bit 32)))) + (+ 1 (ash sb!vm:long-float-hidden-bit 32)))) (defconstant double-float-negative-epsilon (double-from-bits 0 (- sb!vm:double-float-bias sb!vm:double-float-digits) 1)) #!-long-float @@ -172,4 +172,4 @@ #!+(and long-float x86) (defconstant long-float-negative-epsilon (long-from-bits 0 (- sb!vm:long-float-bias sb!vm:long-float-digits) - (+ 1 (ash sb!vm:long-float-hidden-bit 32)))) + (+ 1 (ash sb!vm:long-float-hidden-bit 32)))) diff --git a/src/code/early-format.lisp b/src/code/early-format.lisp index 7dbc663..9cd7009 100644 --- a/src/code/early-format.lisp +++ b/src/code/early-format.lisp @@ -11,11 +11,11 @@ (defparameter *format-whitespace-chars* (vector #\space - #\newline - ;; We leave out this non-STANDARD-CHARACTER entry from this table - ;; when we're running in the cross-compilation host, since ANSI - ;; doesn't require the cross-compilation host to know what a tab is. - #-sb-xc-host (code-char tab-char-code))) + #\newline + ;; We leave out this non-STANDARD-CHARACTER entry from this table + ;; when we're running in the cross-compilation host, since ANSI + ;; doesn't require the cross-compilation host to know what a tab is. + #-sb-xc-host (code-char tab-char-code))) (defvar *format-directive-expanders* (make-array base-char-code-limit :initial-element nil)) diff --git a/src/code/early-impl.lisp b/src/code/early-impl.lisp index 21e75b0..2a35b72 100644 --- a/src/code/early-impl.lisp +++ b/src/code/early-impl.lisp @@ -16,38 +16,38 @@ ;;; listed here and then listed separately (and by now, 2001-06-06, ;;; slightly differently) elsewhere. (declaim (special *posix-argv* - *read-only-space-free-pointer* - sb!vm:*static-space-free-pointer* - sb!vm:*initial-dynamic-space-free-pointer* - sb!vm::*current-catch-block* - sb!vm::*current-unwind-protect-block* - sb!vm::*alien-stack* - sb!vm::*control-stack-start* - sb!vm::*control-stack-end* - sb!vm::*binding-stack-start* - ;; FIXME: The pseudo-atomic variable stuff should be - ;; conditional on :SB-PSEUDO-ATOMIC-SYMBOLS, which - ;; should be conditional on :X86, instead of the - ;; pseudo-atomic stuff being directly conditional on - ;; :X86. (Note that non-X86 ports mention - ;; pseudo-atomicity too, but they handle it without - ;; messing with special variables.) - #!+(or x86 x86-64) *pseudo-atomic-atomic* - #!+(or x86 x86-64) *pseudo-atomic-interrupted* - sb!unix::*interrupts-enabled* - sb!unix::*interrupt-pending* - *free-interrupt-context-index* - sb!vm::*allocation-pointer* - sb!vm::*binding-stack-pointer* - sb!vm::*fp-constant-0d0* - sb!vm::*fp-constant-1d0* - sb!vm::*fp-constant-0f0* - sb!vm::*fp-constant-1f0* - sb!vm::*fp-constant-0l0* - sb!vm::*fp-constant-1l0* - sb!vm::*fp-constant-pi* - sb!vm::*fp-constant-l2t* - sb!vm::*fp-constant-l2e* - sb!vm::*fp-constant-lg2* - sb!vm::*fp-constant-ln2* - sb!pcl::..slot-unbound..)) + *read-only-space-free-pointer* + sb!vm:*static-space-free-pointer* + sb!vm:*initial-dynamic-space-free-pointer* + sb!vm::*current-catch-block* + sb!vm::*current-unwind-protect-block* + sb!vm::*alien-stack* + sb!vm::*control-stack-start* + sb!vm::*control-stack-end* + sb!vm::*binding-stack-start* + ;; FIXME: The pseudo-atomic variable stuff should be + ;; conditional on :SB-PSEUDO-ATOMIC-SYMBOLS, which + ;; should be conditional on :X86, instead of the + ;; pseudo-atomic stuff being directly conditional on + ;; :X86. (Note that non-X86 ports mention + ;; pseudo-atomicity too, but they handle it without + ;; messing with special variables.) + #!+(or x86 x86-64) *pseudo-atomic-atomic* + #!+(or x86 x86-64) *pseudo-atomic-interrupted* + sb!unix::*interrupts-enabled* + sb!unix::*interrupt-pending* + *free-interrupt-context-index* + sb!vm::*allocation-pointer* + sb!vm::*binding-stack-pointer* + sb!vm::*fp-constant-0d0* + sb!vm::*fp-constant-1d0* + sb!vm::*fp-constant-0f0* + sb!vm::*fp-constant-1f0* + sb!vm::*fp-constant-0l0* + sb!vm::*fp-constant-1l0* + sb!vm::*fp-constant-pi* + sb!vm::*fp-constant-l2t* + sb!vm::*fp-constant-l2e* + sb!vm::*fp-constant-lg2* + sb!vm::*fp-constant-ln2* + sb!pcl::..slot-unbound..)) diff --git a/src/code/early-package.lisp b/src/code/early-package.lisp index a1f24bb..25c73ff 100644 --- a/src/code/early-package.lisp +++ b/src/code/early-package.lisp @@ -18,13 +18,13 @@ ;;; packages for which locks are ignored, T when locks for ;;; all packages are ignored, and :invalid outside package-lock ;;; context. FIXME: This needs to be rebound for each thread. -(defvar *ignored-package-locks* +(defvar *ignored-package-locks* (error "*IGNORED-PACKAGE-LOCKS* should be set up in cold-init.")) (!cold-init-forms (setf *ignored-package-locks* :invalid)) -(defmacro with-single-package-locked-error ((&optional kind thing &rest format) - &body body) +(defmacro with-single-package-locked-error ((&optional kind thing &rest format) + &body body) #!-sb-package-locks (declare (ignore kind thing format)) #!-sb-package-locks `(progn ,@body) @@ -33,33 +33,33 @@ `(progn (/show0 ,(first format)) (let ((,topmost nil)) - ;; We use assignment and conditional restoration instead of - ;; dynamic binding because we want the ignored locks - ;; to propagate to the topmost context. - (when (eq :invalid *ignored-package-locks*) - (setf *ignored-package-locks* nil - ,topmost t)) - (unwind-protect - (progn - ,@(ecase kind - (:symbol - `((assert-symbol-home-package-unlocked ,thing ,@format))) - (:package - `((assert-package-unlocked - (find-undeleted-package-or-lose ,thing) ,@format))) - ((nil) - `())) - ,@body) - (when ,topmost - (setf *ignored-package-locks* :invalid))))))) + ;; We use assignment and conditional restoration instead of + ;; dynamic binding because we want the ignored locks + ;; to propagate to the topmost context. + (when (eq :invalid *ignored-package-locks*) + (setf *ignored-package-locks* nil + ,topmost t)) + (unwind-protect + (progn + ,@(ecase kind + (:symbol + `((assert-symbol-home-package-unlocked ,thing ,@format))) + (:package + `((assert-package-unlocked + (find-undeleted-package-or-lose ,thing) ,@format))) + ((nil) + `())) + ,@body) + (when ,topmost + (setf *ignored-package-locks* :invalid))))))) (defun compiler-assert-symbol-home-package-unlocked (symbol control) #!-sb-package-locks (declare (ignore symbol control)) #!+sb-package-locks (flet ((resignal (condition) - ;; Signal the condition to give user defined handlers a chance, - ;; if they decline convert to compiler-error. + ;; Signal the condition to give user defined handlers a chance, + ;; if they decline convert to compiler-error. (signal condition) (sb!c:compiler-error condition))) (handler-bind ((package-lock-violation #'resignal)) @@ -69,7 +69,7 @@ (defmacro without-package-locks (&body body) #!+sb-doc "Ignores all runtime package lock violations during the execution of -body. Body can begin with declarations." +body. Body can begin with declarations." `(let (#!+sb-package-locks (*ignored-package-locks* t)) ,@body)) diff --git a/src/code/early-pcounter.lisp b/src/code/early-pcounter.lisp index a23f618..c14f30e 100644 --- a/src/code/early-pcounter.lisp +++ b/src/code/early-pcounter.lisp @@ -3,7 +3,7 @@ ;;;; a PCOUNTER is used to represent an unsigned integer quantity which ;;;; can grow bigger than a fixnum, but typically does so, if at all, ;;;; in many small steps, where we don't want to cons on every step. -;;;; Such quantities typically arise in profiling, e.g. +;;;; Such quantities typically arise in profiling, e.g. ;;;; total system consing, time spent in a profiled function, and ;;;; bytes consed in a profiled function are all examples of such ;;;; quantities. The name is an abbreviation for "Profiling COUNTER". diff --git a/src/code/early-pprint.lisp b/src/code/early-pprint.lisp index 59392d2..e620d16 100644 --- a/src/code/early-pprint.lisp +++ b/src/code/early-pprint.lisp @@ -14,29 +14,29 @@ ;;;; utilities (defmacro with-pretty-stream ((stream-var - &optional (stream-expression stream-var)) - &body body) + &optional (stream-expression stream-var)) + &body body) (let ((flet-name (gensym "WITH-PRETTY-STREAM-"))) `(flet ((,flet-name (,stream-var) - ,@body)) + ,@body)) (let ((stream ,stream-expression)) - (if (pretty-stream-p stream) - (,flet-name stream) - (catch 'line-limit-abbreviation-happened - (let ((stream (make-pretty-stream stream))) - (,flet-name stream) - (force-pretty-output stream))))) + (if (pretty-stream-p stream) + (,flet-name stream) + (catch 'line-limit-abbreviation-happened + (let ((stream (make-pretty-stream stream))) + (,flet-name stream) + (force-pretty-output stream))))) nil))) ;;;; user interface to the pretty printer (defmacro pprint-logical-block ((stream-symbol - object - &key - (prefix nil prefixp) - (per-line-prefix nil per-line-prefix-p) - (suffix "" suffixp)) - &body body + object + &key + (prefix nil prefixp) + (per-line-prefix nil per-line-prefix-p) + (suffix "" suffixp)) + &body body &environment env) #!+sb-doc "Group some output into a logical block. STREAM-SYMBOL should be either a @@ -46,108 +46,108 @@ (error "cannot specify values for both PREFIX and PER-LINE-PREFIX.")) (multiple-value-bind (stream-var stream-expression) (case stream-symbol - ((nil) - (values '*standard-output* '*standard-output*)) - ((t) - (values '*terminal-io* '*terminal-io*)) - (t - (values stream-symbol - (once-only ((stream stream-symbol)) - `(case ,stream - ((nil) *standard-output*) - ((t) *terminal-io*) - (t ,stream)))))) + ((nil) + (values '*standard-output* '*standard-output*)) + ((t) + (values '*terminal-io* '*terminal-io*)) + (t + (values stream-symbol + (once-only ((stream stream-symbol)) + `(case ,stream + ((nil) *standard-output*) + ((t) *terminal-io*) + (t ,stream)))))) (let* ((object-var (if object (gensym) nil)) - (block-name (gensym "PPRINT-LOGICAL-BLOCK-")) - (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-")) - (pp-pop-name (gensym "PPRINT-POP-")) - (body - ;; FIXME: It looks as though PPRINT-LOGICAL-BLOCK might - ;; expand into a boatload of code, since DESCEND-INTO is a - ;; macro too. It might be worth looking at this to make - ;; sure it's not too bloated, since PPRINT-LOGICAL-BLOCK - ;; is called many times from system pretty-printing code. - ;; - ;; FIXME: I think pprint-logical-block is broken wrt - ;; argument order, multiple evaluation, etc. of its - ;; keyword (:PREFIX, :PER-LINE-PREFIX and :SUFFIX) - ;; arguments. Dunno if that's legal. - `(descend-into (,stream-var) - (let ((,count-name 0)) - (declare (type index ,count-name) (ignorable ,count-name)) - ,@(when (and (or prefixp per-line-prefix-p) + (block-name (gensym "PPRINT-LOGICAL-BLOCK-")) + (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-")) + (pp-pop-name (gensym "PPRINT-POP-")) + (body + ;; FIXME: It looks as though PPRINT-LOGICAL-BLOCK might + ;; expand into a boatload of code, since DESCEND-INTO is a + ;; macro too. It might be worth looking at this to make + ;; sure it's not too bloated, since PPRINT-LOGICAL-BLOCK + ;; is called many times from system pretty-printing code. + ;; + ;; FIXME: I think pprint-logical-block is broken wrt + ;; argument order, multiple evaluation, etc. of its + ;; keyword (:PREFIX, :PER-LINE-PREFIX and :SUFFIX) + ;; arguments. Dunno if that's legal. + `(descend-into (,stream-var) + (let ((,count-name 0)) + (declare (type index ,count-name) (ignorable ,count-name)) + ,@(when (and (or prefixp per-line-prefix-p) (not (and (sb!xc:constantp (or prefix per-line-prefix) env) ;; KLUDGE: EVAL-IN-ENV would ;; be useful here. (typep (eval (or prefix per-line-prefix)) 'string)))) - `((unless (typep ,(or prefix per-line-prefix) 'string) - (error 'type-error - :datum ,(or prefix per-line-prefix) - :expected-type 'string)))) - ,@(when (and suffixp + `((unless (typep ,(or prefix per-line-prefix) 'string) + (error 'type-error + :datum ,(or prefix per-line-prefix) + :expected-type 'string)))) + ,@(when (and suffixp (not (and (sb!xc:constantp suffix env) (typep (eval suffix) 'string)))) - `((unless (typep ,suffix 'string) - (error 'type-error - :datum ,suffix - :expected-type 'string)))) - (start-logical-block ,stream-var - ,(if (or prefixp per-line-prefix-p) - (or prefix per-line-prefix) - nil) - ,(if per-line-prefix-p t nil) - ,suffix) - (block ,block-name - (flet ((,pp-pop-name () - ,@(when object - `((unless (listp ,object-var) - (write-string ". " ,stream-var) - (output-object ,object-var ,stream-var) - (return-from ,block-name nil)))) - (when (and (not *print-readably*) - (eql ,count-name *print-length*)) - (write-string "..." ,stream-var) - (return-from ,block-name nil)) - ,@(when object - `((when (and ,object-var - (plusp ,count-name) - (check-for-circularity - ,object-var + `((unless (typep ,suffix 'string) + (error 'type-error + :datum ,suffix + :expected-type 'string)))) + (start-logical-block ,stream-var + ,(if (or prefixp per-line-prefix-p) + (or prefix per-line-prefix) + nil) + ,(if per-line-prefix-p t nil) + ,suffix) + (block ,block-name + (flet ((,pp-pop-name () + ,@(when object + `((unless (listp ,object-var) + (write-string ". " ,stream-var) + (output-object ,object-var ,stream-var) + (return-from ,block-name nil)))) + (when (and (not *print-readably*) + (eql ,count-name *print-length*)) + (write-string "..." ,stream-var) + (return-from ,block-name nil)) + ,@(when object + `((when (and ,object-var + (plusp ,count-name) + (check-for-circularity + ,object-var nil - :logical-block)) - (write-string ". " ,stream-var) - (output-object ,object-var ,stream-var) - (return-from ,block-name nil)))) - (incf ,count-name) - ,@(if object + :logical-block)) + (write-string ". " ,stream-var) + (output-object ,object-var ,stream-var) + (return-from ,block-name nil)))) + (incf ,count-name) + ,@(if object `((pop ,object-var)) `(nil)))) (declare (ignorable (function ,pp-pop-name))) - (locally - (declare (disable-package-locks - pprint-pop pprint-exit-if-list-exhausted)) - (macrolet ((pprint-pop () - '(,pp-pop-name)) - (pprint-exit-if-list-exhausted () - ,(if object - `'(when (null ,object-var) - (return-from ,block-name nil)) - `'(return-from ,block-name nil)))) - (declare (enable-package-locks - pprint-pop pprint-exit-if-list-exhausted)) - ,@body)))) - ;; FIXME: Don't we need UNWIND-PROTECT to ensure this - ;; always gets executed? - (end-logical-block ,stream-var))))) + (locally + (declare (disable-package-locks + pprint-pop pprint-exit-if-list-exhausted)) + (macrolet ((pprint-pop () + '(,pp-pop-name)) + (pprint-exit-if-list-exhausted () + ,(if object + `'(when (null ,object-var) + (return-from ,block-name nil)) + `'(return-from ,block-name nil)))) + (declare (enable-package-locks + pprint-pop pprint-exit-if-list-exhausted)) + ,@body)))) + ;; FIXME: Don't we need UNWIND-PROTECT to ensure this + ;; always gets executed? + (end-logical-block ,stream-var))))) (when object - (setf body - `(let ((,object-var ,object)) - (if (listp ,object-var) - (with-circularity-detection (,object-var ,stream-var) - ,body) - (output-object ,object-var ,stream-var))))) + (setf body + `(let ((,object-var ,object)) + (if (listp ,object-var) + (with-circularity-detection (,object-var ,stream-var) + ,body) + (output-object ,object-var ,stream-var))))) `(with-pretty-stream (,stream-var ,stream-expression) - ,body)))) + ,body)))) (defmacro pprint-exit-if-list-exhausted () #!+sb-doc diff --git a/src/code/early-print.lisp b/src/code/early-print.lisp index 8b770f5..ea2c24b 100644 --- a/src/code/early-print.lisp +++ b/src/code/early-print.lisp @@ -23,22 +23,22 @@ (defmacro descend-into ((stream) &body body) (let ((flet-name (gensym))) `(flet ((,flet-name () - ,@body)) + ,@body)) (cond ((and (null *print-readably*) - *print-level* - (>= *current-level-in-print* *print-level*)) - (write-char #\# ,stream)) - (t - (let ((*current-level-in-print* (1+ *current-level-in-print*))) - (,flet-name))))))) + *print-level* + (>= *current-level-in-print* *print-level*)) + (write-char #\# ,stream)) + (t + (let ((*current-level-in-print* (1+ *current-level-in-print*))) + (,flet-name))))))) ;;; Punt if INDEX is equal or larger then *PRINT-LENGTH* (and ;;; *PRINT-READABLY* is NIL) by outputting \"...\" and returning from ;;; the block named NIL. (defmacro punt-print-if-too-long (index stream) `(when (and (not *print-readably*) - *print-length* - (>= ,index *print-length*)) + *print-length* + (>= ,index *print-length*)) (write-string "..." ,stream) (return))) @@ -73,7 +73,7 @@ ;;; you need to initiate the circularity detection noise, e.g. bind ;;; *CIRCULARITY-HASH-TABLE* and *CIRCULARITY-COUNTER* to suitable values ;;; (see #'OUTPUT-OBJECT for an example). -;;; +;;; ;;; Circularity detection is done in two places, OUTPUT-OBJECT and ;;; WITH-CIRCULARITY-DETECTION (which is used from PPRINT-LOGICAL-BLOCK). ;;; These checks aren't really redundant (at least I can't really see @@ -85,51 +85,51 @@ ;;; correcting this problem. (defun check-for-circularity (object &optional assign (mode t)) (cond ((null *print-circle*) - ;; Don't bother, nobody cares. - nil) - ((null *circularity-hash-table*) + ;; Don't bother, nobody cares. + nil) + ((null *circularity-hash-table*) (values nil :initiate)) - ((null *circularity-counter*) - (ecase (gethash object *circularity-hash-table*) - ((nil) - ;; first encounter - (setf (gethash object *circularity-hash-table*) mode) - ;; We need to keep looking. - nil) - ((:logical-block) - (setf (gethash object *circularity-hash-table*) + ((null *circularity-counter*) + (ecase (gethash object *circularity-hash-table*) + ((nil) + ;; first encounter + (setf (gethash object *circularity-hash-table*) mode) + ;; We need to keep looking. + nil) + ((:logical-block) + (setf (gethash object *circularity-hash-table*) :logical-block-circular) - t) - ((t) - (cond ((eq mode :logical-block) - ;; We've seen the object before in output-object, and now - ;; a second time in a PPRINT-LOGICAL-BLOCK (for example - ;; via pprint-dispatch). Don't mark it as circular yet. - (setf (gethash object *circularity-hash-table*) - :logical-block) - nil) - (t - ;; second encounter - (setf (gethash object *circularity-hash-table*) 0) - ;; It's a circular reference. - t))) - ((0 :logical-block-circular) - ;; It's a circular reference. - t))) - (t - (let ((value (gethash object *circularity-hash-table*))) - (case value - ((nil t :logical-block) - ;; If NIL, we found an object that wasn't there the - ;; first time around. If T or :LOGICAL-BLOCK, this - ;; object appears exactly once. Either way, just print - ;; the thing without any special processing. Note: you - ;; might argue that finding a new object means that - ;; something is broken, but this can happen. If someone - ;; uses the ~@<...~:> format directive, it conses a new - ;; list each time though format (i.e. the &REST list), - ;; so we will have different cdrs. - nil) + t) + ((t) + (cond ((eq mode :logical-block) + ;; We've seen the object before in output-object, and now + ;; a second time in a PPRINT-LOGICAL-BLOCK (for example + ;; via pprint-dispatch). Don't mark it as circular yet. + (setf (gethash object *circularity-hash-table*) + :logical-block) + nil) + (t + ;; second encounter + (setf (gethash object *circularity-hash-table*) 0) + ;; It's a circular reference. + t))) + ((0 :logical-block-circular) + ;; It's a circular reference. + t))) + (t + (let ((value (gethash object *circularity-hash-table*))) + (case value + ((nil t :logical-block) + ;; If NIL, we found an object that wasn't there the + ;; first time around. If T or :LOGICAL-BLOCK, this + ;; object appears exactly once. Either way, just print + ;; the thing without any special processing. Note: you + ;; might argue that finding a new object means that + ;; something is broken, but this can happen. If someone + ;; uses the ~@<...~:> format directive, it conses a new + ;; list each time though format (i.e. the &REST list), + ;; so we will have different cdrs. + nil) ;; A circular reference to something that will be printed ;; as a logical block. Wait until we're called from ;; PPRINT-LOGICAL-BLOCK with ASSIGN true before assigning the @@ -139,28 +139,28 @@ ;; to indicate that this object is circular, but don't assign ;; it a number yet. This is neccessary for cases like ;; #1=(#2=(#2# . #3=(#1# . #3#))))). - (:logical-block-circular - (cond ((and (not assign) + (:logical-block-circular + (cond ((and (not assign) (eq mode :logical-block)) t) - ((and assign + ((and assign (eq mode :logical-block)) (let ((value (incf *circularity-counter*))) ;; first occurrence of this object: Set the counter. (setf (gethash object *circularity-hash-table*) value) value)) - (t - nil))) - (0 - (if (eq assign t) - (let ((value (incf *circularity-counter*))) - ;; first occurrence of this object: Set the counter. - (setf (gethash object *circularity-hash-table*) value) - value) - t)) - (t - ;; second or later occurrence - (- value))))))) + (t + nil))) + (0 + (if (eq assign t) + (let ((value (incf *circularity-counter*))) + ;; first occurrence of this object: Set the counter. + (setf (gethash object *circularity-hash-table*) value) + value) + t)) + (t + ;; second or later occurrence + (- value))))))) ;;; Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then ;;; you should go ahead and print the object. If it returns NIL, then @@ -180,13 +180,13 @@ (write-char #\# stream) (let ((*print-base* 10) (*print-radix* nil)) (cond ((minusp marker) - (output-integer (- marker) stream) - (write-char #\# stream) - nil) - (t - (output-integer marker stream) - (write-char #\= stream) - t)))))) + (output-integer (- marker) stream) + (write-char #\# stream) + nil) + (t + (output-integer marker stream) + (write-char #\= stream) + t)))))) (defmacro with-circularity-detection ((object stream) &body body) (let ((marker (gensym "WITH-CIRCULARITY-DETECTION-")) @@ -210,4 +210,4 @@ (when ,marker (handle-circularity ,marker ,stream))) (,body-name)))))))) - + diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index e829b6a..c55cf6a 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -37,38 +37,38 @@ for the new values, the setting function, and the accessing function." (let (temp) (cond ((symbolp form) - (multiple-value-bind (expansion expanded) - (sb!xc:macroexpand-1 form environment) - (if expanded - (sb!xc:get-setf-expansion expansion environment) - (let ((new-var (gensym))) - (values nil nil (list new-var) - `(setq ,form ,new-var) form))))) - ;; Local functions inhibit global SETF methods. - ((and environment - (let ((name (car form))) - (dolist (x (sb!c::lexenv-funs environment)) - (when (and (eq (car x) name) - (not (sb!c::defined-fun-p (cdr x)))) - (return t))))) - (expand-or-get-setf-inverse form environment)) - ((setq temp (info :setf :inverse (car form))) - (get-setf-method-inverse form `(,temp) nil)) - ((setq temp (info :setf :expander (car form))) - ;; KLUDGE: It may seem as though this should go through - ;; *MACROEXPAND-HOOK*, but the ANSI spec seems fairly explicit - ;; that *MACROEXPAND-HOOK* is a hook for MACROEXPAND-1, not - ;; for macroexpansion in general. -- WHN 19991128 - (funcall temp - form - ;; As near as I can tell from the ANSI spec, - ;; macroexpanders have a right to expect an actual - ;; lexical environment, not just a NIL which is to - ;; be interpreted as a null lexical environment. - ;; -- WHN 19991128 - (coerce-to-lexenv environment))) - (t - (expand-or-get-setf-inverse form environment))))) + (multiple-value-bind (expansion expanded) + (sb!xc:macroexpand-1 form environment) + (if expanded + (sb!xc:get-setf-expansion expansion environment) + (let ((new-var (gensym))) + (values nil nil (list new-var) + `(setq ,form ,new-var) form))))) + ;; Local functions inhibit global SETF methods. + ((and environment + (let ((name (car form))) + (dolist (x (sb!c::lexenv-funs environment)) + (when (and (eq (car x) name) + (not (sb!c::defined-fun-p (cdr x)))) + (return t))))) + (expand-or-get-setf-inverse form environment)) + ((setq temp (info :setf :inverse (car form))) + (get-setf-method-inverse form `(,temp) nil)) + ((setq temp (info :setf :expander (car form))) + ;; KLUDGE: It may seem as though this should go through + ;; *MACROEXPAND-HOOK*, but the ANSI spec seems fairly explicit + ;; that *MACROEXPAND-HOOK* is a hook for MACROEXPAND-1, not + ;; for macroexpansion in general. -- WHN 19991128 + (funcall temp + form + ;; As near as I can tell from the ANSI spec, + ;; macroexpanders have a right to expect an actual + ;; lexical environment, not just a NIL which is to + ;; be interpreted as a null lexical environment. + ;; -- WHN 19991128 + (coerce-to-lexenv environment))) + (t + (expand-or-get-setf-inverse form environment))))) ;;; GET-SETF-METHOD existed in pre-ANSI Common Lisp, and various code inherited ;;; from CMU CL uses it repeatedly, so rather than rewrite a lot of code to not @@ -86,35 +86,35 @@ GET-SETF-EXPANSION directly." (when (cdr store-vars) (error "GET-SETF-METHOD used for a form with multiple store ~ variables:~% ~S" - form)) + form)) (values temps value-forms store-vars store-form access-form))) ;;; If a macro, expand one level and try again. If not, go for the ;;; SETF function. (declaim (ftype (function (t (or null sb!c::lexenv))) - expand-or-get-setf-inverse)) + expand-or-get-setf-inverse)) (defun expand-or-get-setf-inverse (form environment) (multiple-value-bind (expansion expanded) (sb!xc:macroexpand-1 form environment) (if expanded - (sb!xc:get-setf-expansion expansion environment) - (get-setf-method-inverse form - `(funcall #'(setf ,(car form))) - t)))) + (sb!xc:get-setf-expansion expansion environment) + (get-setf-method-inverse form + `(funcall #'(setf ,(car form))) + t)))) (defun get-setf-method-inverse (form inverse setf-fun) (let ((new-var (gensym)) - (vars nil) - (vals nil)) + (vars nil) + (vals nil)) (dolist (x (cdr form)) (push (gensym) vars) (push x vals)) (setq vals (nreverse vals)) (values vars vals (list new-var) - (if setf-fun - `(,@inverse ,new-var ,@vars) - `(,@inverse ,@vars ,new-var)) - `(,(car form) ,@vars)))) + (if setf-fun + `(,@inverse ,new-var ,@vars) + `(,@inverse ,@vars ,new-var)) + `(,(car form) ,@vars)))) ;;;; SETF itself @@ -134,26 +134,26 @@ GET-SETF-EXPANSION directly." (cond ((= nargs 2) (let ((place (first args)) - (value-form (second args))) - (if (atom place) - `(setq ,place ,value-form) - (multiple-value-bind (dummies vals newval setter getter) - (sb!xc:get-setf-expansion place env) - (declare (ignore getter)) - (let ((inverse (info :setf :inverse (car place)))) - (if (and inverse (eq inverse (car setter))) - `(,inverse ,@(cdr place) ,value-form) - `(let* (,@(mapcar #'list dummies vals)) - (multiple-value-bind ,newval ,value-form - ,setter)))))))) + (value-form (second args))) + (if (atom place) + `(setq ,place ,value-form) + (multiple-value-bind (dummies vals newval setter getter) + (sb!xc:get-setf-expansion place env) + (declare (ignore getter)) + (let ((inverse (info :setf :inverse (car place)))) + (if (and inverse (eq inverse (car setter))) + `(,inverse ,@(cdr place) ,value-form) + `(let* (,@(mapcar #'list dummies vals)) + (multiple-value-bind ,newval ,value-form + ,setter)))))))) ((oddp nargs) (error "odd number of args to SETF")) (t (do ((a args (cddr a)) - (reversed-setfs nil)) - ((null a) - `(progn ,@(nreverse reversed-setfs))) - (push (list 'setf (car a) (cadr a)) reversed-setfs)))))) + (reversed-setfs nil)) + ((null a) + `(progn ,@(nreverse reversed-setfs))) + (push (list 'setf (car a) (cadr a)) reversed-setfs)))))) ;;;; various SETF-related macros @@ -168,36 +168,36 @@ GET-SETF-EXPANSION directly." (let (let*-bindings mv-bindings setters getters) (dolist (arg (butlast args)) (multiple-value-bind (temps subforms store-vars setter getter) - (sb!xc:get-setf-expansion arg env) - (mapc (lambda (tmp form) - (push `(,tmp ,form) let*-bindings)) - temps - subforms) - (push store-vars mv-bindings) - (push setter setters) - (push getter getters))) + (sb!xc:get-setf-expansion arg env) + (mapc (lambda (tmp form) + (push `(,tmp ,form) let*-bindings)) + temps + subforms) + (push store-vars mv-bindings) + (push setter setters) + (push getter getters))) ;; Handle the last arg specially here. The getter is just the last ;; arg itself. (push (car (last args)) getters) ;; Reverse the collected lists so last bit looks nicer. (setf let*-bindings (nreverse let*-bindings) - mv-bindings (nreverse mv-bindings) - setters (nreverse setters) - getters (nreverse getters)) + mv-bindings (nreverse mv-bindings) + setters (nreverse setters) + getters (nreverse getters)) (labels ((thunk (mv-bindings getters) - (if mv-bindings - `((multiple-value-bind - ,(car mv-bindings) - ,(car getters) - ,@(thunk (cdr mv-bindings) (cdr getters)))) - `(,@setters)))) + (if mv-bindings + `((multiple-value-bind + ,(car mv-bindings) + ,(car getters) + ,@(thunk (cdr mv-bindings) (cdr getters)))) + `(,@setters)))) `(let ,let*-bindings - (multiple-value-bind ,(car mv-bindings) - ,(car getters) - ,@(thunk mv-bindings (cdr getters)) - (values ,@(car mv-bindings))))))) + (multiple-value-bind ,(car mv-bindings) + ,(car getters) + ,@(thunk mv-bindings (cdr getters)) + (values ,@(car mv-bindings))))))) (defmacro-mundanely push (obj place &environment env) #!+sb-doc @@ -251,28 +251,28 @@ GET-SETF-EXPANSION directly." (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) (do* ((d dummies (cdr d)) - (v vals (cdr v)) - (let-list nil) - (ind-temp (gensym)) - (local1 (gensym)) - (local2 (gensym))) - ((null d) + (v vals (cdr v)) + (let-list nil) + (ind-temp (gensym)) + (local1 (gensym)) + (local2 (gensym))) + ((null d) ;; See ANSI 5.1.3 for why we do out-of-order evaluation - (push (list ind-temp indicator) let-list) - (push (list (car newval) getter) let-list) - `(let* ,(nreverse let-list) - (do ((,local1 ,(car newval) (cddr ,local1)) - (,local2 nil ,local1)) - ((atom ,local1) nil) - (cond ((atom (cdr ,local1)) - (error "Odd-length property list in REMF.")) - ((eq (car ,local1) ,ind-temp) - (cond (,local2 - (rplacd (cdr ,local2) (cddr ,local1)) - (return t)) - (t (setq ,(car newval) (cddr ,(car newval))) - ,setter - (return t)))))))) + (push (list ind-temp indicator) let-list) + (push (list (car newval) getter) let-list) + `(let* ,(nreverse let-list) + (do ((,local1 ,(car newval) (cddr ,local1)) + (,local2 nil ,local1)) + ((atom ,local1) nil) + (cond ((atom (cdr ,local1)) + (error "Odd-length property list in REMF.")) + ((eq (car ,local1) ,ind-temp) + (cond (,local2 + (rplacd (cdr ,local2) (cddr ,local1)) + (return t)) + (t (setq ,(car newval) (cddr ,(car newval))) + ,setter + (return t)))))))) (push (list (car d) (car v)) let-list)))) ;;; we can't use DEFINE-MODIFY-MACRO because of ANSI 5.1.3 @@ -306,47 +306,47 @@ GET-SETF-EXPANSION directly." #!+sb-doc "Creates a new read-modify-write macro like PUSH or INCF." (let ((other-args nil) - (rest-arg nil) - (env (gensym)) - (reference (gensym))) + (rest-arg nil) + (env (gensym)) + (reference (gensym))) ;; Parse out the variable names and &REST arg from the lambda list. (do ((ll lambda-list (cdr ll)) - (arg nil)) - ((null ll)) + (arg nil)) + ((null ll)) (setq arg (car ll)) (cond ((eq arg '&optional)) - ((eq arg '&rest) - (if (symbolp (cadr ll)) - (setq rest-arg (cadr ll)) - (error "Non-symbol &REST argument in definition of ~S." name)) - (if (null (cddr ll)) - (return nil) - (error "Illegal stuff after &REST argument."))) - ((memq arg '(&key &allow-other-keys &aux)) - (error "~S not allowed in DEFINE-MODIFY-MACRO lambda list." arg)) - ((symbolp arg) - (push arg other-args)) - ((and (listp arg) (symbolp (car arg))) - (push (car arg) other-args)) - (t (error "Illegal stuff in lambda list.")))) + ((eq arg '&rest) + (if (symbolp (cadr ll)) + (setq rest-arg (cadr ll)) + (error "Non-symbol &REST argument in definition of ~S." name)) + (if (null (cddr ll)) + (return nil) + (error "Illegal stuff after &REST argument."))) + ((memq arg '(&key &allow-other-keys &aux)) + (error "~S not allowed in DEFINE-MODIFY-MACRO lambda list." arg)) + ((symbolp arg) + (push arg other-args)) + ((and (listp arg) (symbolp (car arg))) + (push (car arg) other-args)) + (t (error "Illegal stuff in lambda list.")))) (setq other-args (nreverse other-args)) `(#-sb-xc-host sb!xc:defmacro #+sb-xc-host defmacro-mundanely - ,name (,reference ,@lambda-list &environment ,env) + ,name (,reference ,@lambda-list &environment ,env) ,doc-string (multiple-value-bind (dummies vals newval setter getter) - (get-setf-method ,reference ,env) - (do ((d dummies (cdr d)) - (v vals (cdr v)) - (let-list nil (cons (list (car d) (car v)) let-list))) - ((null d) - (push (list (car newval) - ,(if rest-arg - `(list* ',function getter ,@other-args ,rest-arg) - `(list ',function getter ,@other-args))) - let-list) - `(let* ,(nreverse let-list) - ,setter))))))) + (get-setf-method ,reference ,env) + (do ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil (cons (list (car d) (car v)) let-list))) + ((null d) + (push (list (car newval) + ,(if rest-arg + `(list* ',function getter ,@other-args ,rest-arg) + `(list ',function getter ,@other-args))) + let-list) + `(let* ,(nreverse let-list) + ,setter))))))) ;;;; DEFSETF @@ -354,19 +354,19 @@ GET-SETF-EXPANSION directly." ;;; Assign SETF macro information for NAME, making all appropriate checks. (defun assign-setf-macro (name expander inverse doc) (with-single-package-locked-error - (:symbol name "defining a setf-expander for ~A")) + (:symbol name "defining a setf-expander for ~A")) (cond ((gethash name sb!c:*setf-assumed-fboundp*) - (warn - "defining setf macro for ~S when ~S was previously ~ + (warn + "defining setf macro for ~S when ~S was previously ~ treated as a function" - name - `(setf ,name))) - ((not (fboundp `(setf ,name))) - ;; All is well, we don't need any warnings. - (values)) - ((not (eq (symbol-package name) (symbol-package 'aref))) - (style-warn "defining setf macro for ~S when ~S is fbound" - name `(setf ,name)))) + name + `(setf ,name))) + ((not (fboundp `(setf ,name))) + ;; All is well, we don't need any warnings. + (values)) + ((not (eq (symbol-package name) (symbol-package 'aref))) + (style-warn "defining setf macro for ~S when ~S is fbound" + name `(setf ,name)))) (remhash name sb!c:*setf-assumed-fboundp*) ;; FIXME: It's probably possible to join these checks into one form which ;; is appropriate both on the cross-compilation host and on the target. @@ -383,61 +383,61 @@ GET-SETF-EXPANSION directly." "Associates a SETF update function or macro with the specified access function or macro. The format is complex. See the manual for details." (cond ((not (listp (car rest))) - `(eval-when (:load-toplevel :compile-toplevel :execute) - (assign-setf-macro ',access-fn - nil - ',(car rest) - ,(when (and (car rest) (stringp (cadr rest))) - `',(cadr rest))))) - ((and (cdr rest) (listp (cadr rest))) - (destructuring-bind - (lambda-list (&rest store-variables) &body body) - rest - (let ((arglist-var (gensym "ARGS-")) - (access-form-var (gensym "ACCESS-FORM-")) - (env-var (gensym "ENVIRONMENT-"))) - (multiple-value-bind (body local-decs doc) - (parse-defmacro `(,lambda-list ,@store-variables) - arglist-var body access-fn 'defsetf - :anonymousp t) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (assign-setf-macro - ',access-fn - (lambda (,access-form-var ,env-var) - (declare (ignore ,env-var)) - (%defsetf ,access-form-var ,(length store-variables) - (lambda (,arglist-var) - ,@local-decs + `(eval-when (:load-toplevel :compile-toplevel :execute) + (assign-setf-macro ',access-fn + nil + ',(car rest) + ,(when (and (car rest) (stringp (cadr rest))) + `',(cadr rest))))) + ((and (cdr rest) (listp (cadr rest))) + (destructuring-bind + (lambda-list (&rest store-variables) &body body) + rest + (let ((arglist-var (gensym "ARGS-")) + (access-form-var (gensym "ACCESS-FORM-")) + (env-var (gensym "ENVIRONMENT-"))) + (multiple-value-bind (body local-decs doc) + (parse-defmacro `(,lambda-list ,@store-variables) + arglist-var body access-fn 'defsetf + :anonymousp t) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (assign-setf-macro + ',access-fn + (lambda (,access-form-var ,env-var) + (declare (ignore ,env-var)) + (%defsetf ,access-form-var ,(length store-variables) + (lambda (,arglist-var) + ,@local-decs ,body))) - nil - ',doc)))))) - (t - (error "ill-formed DEFSETF for ~S" access-fn)))) + nil + ',doc)))))) + (t + (error "ill-formed DEFSETF for ~S" access-fn)))) (defun %defsetf (orig-access-form num-store-vars expander) (declare (type function expander)) (let (subforms - subform-vars - subform-exprs - store-vars) + subform-vars + subform-exprs + store-vars) (dolist (subform (cdr orig-access-form)) (if (constantp subform) - (push subform subforms) - (let ((var (gensym))) - (push var subforms) - (push var subform-vars) - (push subform subform-exprs)))) + (push subform subforms) + (let ((var (gensym))) + (push var subforms) + (push var subform-vars) + (push subform subform-exprs)))) (dotimes (i num-store-vars) (push (gensym) store-vars)) (let ((r-subforms (nreverse subforms)) - (r-subform-vars (nreverse subform-vars)) - (r-subform-exprs (nreverse subform-exprs)) - (r-store-vars (nreverse store-vars))) + (r-subform-vars (nreverse subform-vars)) + (r-subform-exprs (nreverse subform-exprs)) + (r-store-vars (nreverse store-vars))) (values r-subform-vars - r-subform-exprs - r-store-vars - (funcall expander (cons r-subforms r-store-vars)) - `(,(car orig-access-form) ,@r-subforms))))) + r-subform-exprs + r-store-vars + (funcall expander (cons r-subforms r-store-vars)) + `(,(car orig-access-form) ,@r-subforms))))) ;;;; DEFMACRO DEFINE-SETF-EXPANDER and various DEFINE-SETF-EXPANDERs @@ -451,50 +451,50 @@ GET-SETF-EXPANSION directly." 'sb!xc:define-setf-expander access-fn)) (with-unique-names (whole environment) (multiple-value-bind (body local-decs doc) - (parse-defmacro lambda-list whole body access-fn - 'sb!xc:define-setf-expander - :environment environment) + (parse-defmacro lambda-list whole body access-fn + 'sb!xc:define-setf-expander + :environment environment) `(eval-when (:compile-toplevel :load-toplevel :execute) - (assign-setf-macro ',access-fn - (lambda (,whole ,environment) - ,@local-decs - ,body) - nil - ',doc))))) + (assign-setf-macro ',access-fn + (lambda (,whole ,environment) + ,@local-decs + ,body) + nil + ',doc))))) (sb!xc:define-setf-expander getf (place prop - &optional default - &environment env) + &optional default + &environment env) (declare (type sb!c::lexenv env)) (multiple-value-bind (temps values stores set get) (get-setf-method place env) (let ((newval (gensym)) - (ptemp (gensym)) - (def-temp (if default (gensym)))) + (ptemp (gensym)) + (def-temp (if default (gensym)))) (values `(,@temps ,ptemp ,@(if default `(,def-temp))) - `(,@values ,prop ,@(if default `(,default))) - `(,newval) - `(let ((,(car stores) (%putf ,get ,ptemp ,newval))) - ,set - ,newval) - `(getf ,get ,ptemp ,@(if default `(,def-temp))))))) + `(,@values ,prop ,@(if default `(,default))) + `(,newval) + `(let ((,(car stores) (%putf ,get ,ptemp ,newval))) + ,set + ,newval) + `(getf ,get ,ptemp ,@(if default `(,def-temp))))))) (sb!xc:define-setf-expander get (symbol prop &optional default) (let ((symbol-temp (gensym)) - (prop-temp (gensym)) - (def-temp (gensym)) - (newval (gensym))) + (prop-temp (gensym)) + (def-temp (gensym)) + (newval (gensym))) (values `(,symbol-temp ,prop-temp ,@(if default `(,def-temp))) - `(,symbol ,prop ,@(if default `(,default))) - (list newval) - `(%put ,symbol-temp ,prop-temp ,newval) - `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp)))))) + `(,symbol ,prop ,@(if default `(,default))) + (list newval) + `(%put ,symbol-temp ,prop-temp ,newval) + `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp)))))) (sb!xc:define-setf-expander gethash (key hashtable &optional default) (let ((key-temp (gensym)) - (hashtable-temp (gensym)) - (default-temp (gensym)) - (new-value-temp (gensym))) + (hashtable-temp (gensym)) + (default-temp (gensym)) + (new-value-temp (gensym))) (values `(,key-temp ,hashtable-temp ,@(if default `(,default-temp))) `(,key ,hashtable ,@(if default `(,default))) @@ -507,17 +507,17 @@ GET-SETF-EXPANSION directly." (multiple-value-bind (temps vals stores store-form access-form) (get-setf-method int env) (let ((ind (gensym)) - (store (gensym)) - (stemp (first stores))) + (store (gensym)) + (stemp (first stores))) (values `(,ind ,@temps) - `(,index - ,@vals) - (list store) - `(let ((,stemp - (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form))) - ,store-form - ,store) - `(logbitp ,ind ,access-form))))) + `(,index + ,@vals) + (list store) + `(let ((,stemp + (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form))) + ,store-form + ,store) + `(logbitp ,ind ,access-form))))) ;;; CMU CL had a comment here that: ;;; Evil hack invented by the gnomes of Vassar Street (though not as evil as @@ -530,16 +530,16 @@ GET-SETF-EXPANSION directly." ;;; ANSI has some place for SETF APPLY. -- WHN 19990604 (sb!xc:define-setf-expander apply (functionoid &rest args) (unless (and (listp functionoid) - (= (length functionoid) 2) - (eq (first functionoid) 'function) - (symbolp (second functionoid))) + (= (length functionoid) 2) + (eq (first functionoid) 'function) + (symbolp (second functionoid))) (error "SETF of APPLY is only defined for function args like #'SYMBOL.")) (let ((function (second functionoid)) - (new-var (gensym)) - (vars (make-gensym-list (length args)))) + (new-var (gensym)) + (vars (make-gensym-list (length args)))) (values vars args (list new-var) - `(apply #'(setf ,function) ,new-var ,@vars) - `(apply #',function ,@vars)))) + `(apply #'(setf ,function) ,new-var ,@vars) + `(apply #',function ,@vars)))) ;;; Special-case a BYTE bytespec so that the compiler can recognize it. (sb!xc:define-setf-expander ldb (bytespec place &environment env) @@ -551,26 +551,26 @@ GET-SETF-EXPANSION directly." (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) (if (and (consp bytespec) (eq (car bytespec) 'byte)) - (let ((n-size (gensym)) - (n-pos (gensym)) - (n-new (gensym))) - (values (list* n-size n-pos dummies) - (list* (second bytespec) (third bytespec) vals) - (list n-new) - `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos) - ,getter))) - ,setter - ,n-new) - `(ldb (byte ,n-size ,n-pos) ,getter))) - (let ((btemp (gensym)) - (gnuval (gensym))) - (values (cons btemp dummies) - (cons bytespec vals) - (list gnuval) - `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter))) - ,setter - ,gnuval) - `(ldb ,btemp ,getter)))))) + (let ((n-size (gensym)) + (n-pos (gensym)) + (n-new (gensym))) + (values (list* n-size n-pos dummies) + (list* (second bytespec) (third bytespec) vals) + (list n-new) + `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos) + ,getter))) + ,setter + ,n-new) + `(ldb (byte ,n-size ,n-pos) ,getter))) + (let ((btemp (gensym)) + (gnuval (gensym))) + (values (cons btemp dummies) + (cons bytespec vals) + (list gnuval) + `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter))) + ,setter + ,gnuval) + `(ldb ,btemp ,getter)))))) (sb!xc:define-setf-expander mask-field (bytespec place &environment env) #!+sb-doc @@ -581,14 +581,14 @@ GET-SETF-EXPANSION directly." (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) (let ((btemp (gensym)) - (gnuval (gensym))) + (gnuval (gensym))) (values (cons btemp dummies) - (cons bytespec vals) - (list gnuval) - `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter))) - ,setter - ,gnuval) - `(mask-field ,btemp ,getter))))) + (cons bytespec vals) + (list gnuval) + `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter))) + ,setter + ,gnuval) + `(mask-field ,btemp ,getter))))) (sb!xc:define-setf-expander the (type place &environment env) (declare (type sb!c::lexenv env)) diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 16404c7..b338ad7 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -18,11 +18,11 @@ ;;; and unreasonably complicated types involving AND. We just remember ;;; the original type spec. (defstruct (hairy-type (:include ctype - (class-info (type-class-or-lose 'hairy)) - (enumerable t) - (might-contain-other-types-p t)) - (:copier nil) - #!+cmu (:pure nil)) + (class-info (type-class-or-lose 'hairy)) + (enumerable t) + (might-contain-other-types-p t)) + (:copier nil) + #!+cmu (:pure nil)) ;; the Common Lisp type-specifier of the type we represent (specifier nil :type t)) @@ -32,16 +32,16 @@ ;;; defined). We make this distinction since we don't want to complain ;;; about types that are hairy but defined. (defstruct (unknown-type (:include hairy-type) - (:copier nil))) + (:copier nil))) (defstruct (negation-type (:include ctype - (class-info (type-class-or-lose 'negation)) - ;; FIXME: is this right? It's - ;; what they had before, anyway - (enumerable t) - (might-contain-other-types-p t)) - (:copier nil) - #!+cmu (:pure nil)) + (class-info (type-class-or-lose 'negation)) + ;; FIXME: is this right? It's + ;; what they had before, anyway + (enumerable t) + (might-contain-other-types-p t)) + (:copier nil) + #!+cmu (:pure nil)) (type (missing-arg) :type ctype)) (!define-type-class negation) @@ -49,8 +49,8 @@ ;;; ARGS-TYPE objects are used both to represent VALUES types and ;;; to represent FUNCTION types. (defstruct (args-type (:include ctype) - (:constructor nil) - (:copier nil)) + (:constructor nil) + (:copier nil)) ;; Lists of the type for each required and optional argument. (required nil :type list) (optional nil :type list) @@ -82,38 +82,38 @@ (defun args-types (lambda-list-like-thing) (multiple-value-bind - (required optional restp rest keyp keys allowp auxp aux + (required optional restp rest keyp keys allowp auxp aux morep more-context more-count llk-p) (parse-lambda-list-like-thing lambda-list-like-thing) (declare (ignore aux morep more-context more-count)) (when auxp (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list-like-thing)) (let ((required (mapcar #'single-value-specifier-type required)) - (optional (mapcar #'single-value-specifier-type optional)) - (rest (when restp (single-value-specifier-type rest))) - (keywords - (collect ((key-info)) - (dolist (key keys) - (unless (proper-list-of-length-p key 2) - (error "Keyword type description is not a two-list: ~S." key)) - (let ((kwd (first key))) - (when (find kwd (key-info) :key #'key-info-name) - (error "~@" - kwd lambda-list-like-thing)) - (key-info - (make-key-info - :name kwd - :type (single-value-specifier-type (second key)))))) - (key-info)))) + (optional (mapcar #'single-value-specifier-type optional)) + (rest (when restp (single-value-specifier-type rest))) + (keywords + (collect ((key-info)) + (dolist (key keys) + (unless (proper-list-of-length-p key 2) + (error "Keyword type description is not a two-list: ~S." key)) + (let ((kwd (first key))) + (when (find kwd (key-info) :key #'key-info-name) + (error "~@" + kwd lambda-list-like-thing)) + (key-info + (make-key-info + :name kwd + :type (single-value-specifier-type (second key)))))) + (key-info)))) (multiple-value-bind (required optional rest) - (canonicalize-args-type-args required optional rest) - (values required optional rest keyp keywords allowp llk-p))))) + (canonicalize-args-type-args required optional rest) + (values required optional rest keyp keywords allowp llk-p))))) (defstruct (values-type - (:include args-type - (class-info (type-class-or-lose 'values))) + (:include args-type + (class-info (type-class-or-lose 'values))) (:constructor %make-values-type) - (:copier nil))) + (:copier nil))) (defun-cached (make-values-type-cached :hash-bits 8 @@ -139,10 +139,10 @@ required optional rest allowp) (if argsp (if (eq args '*) - *wild-type* - (multiple-value-bind (required optional rest keyp keywords allowp + *wild-type* + (multiple-value-bind (required optional rest keyp keywords allowp llk-p) - (args-types args) + (args-types args) (declare (ignore keywords)) (when keyp (error "&KEY appeared in a VALUES type specifier ~S." @@ -168,7 +168,7 @@ ;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes (defstruct (fun-type (:include args-type - (class-info (type-class-or-lose 'function))) + (class-info (type-class-or-lose 'function))) (:constructor %make-fun-type (&key required optional rest keyp keywords allowp @@ -183,28 +183,28 @@ ;; when multiple values were specified for the return. (returns (missing-arg) :type ctype)) (defun make-fun-type (&rest initargs - &key (args nil argsp) returns &allow-other-keys) + &key (args nil argsp) returns &allow-other-keys) (if argsp (if (eq args '*) - (if (eq returns *wild-type*) - (specifier-type 'function) - (%make-fun-type :wild-args t :returns returns)) - (multiple-value-bind (required optional rest keyp keywords allowp) - (args-types args) - (if (and (null required) - (null optional) - (eq rest *universal-type*) - (not keyp)) - (if (eq returns *wild-type*) - (specifier-type 'function) - (%make-fun-type :wild-args t :returns returns)) - (%make-fun-type :required required - :optional optional - :rest rest - :keyp keyp - :keywords keywords - :allowp allowp - :returns returns)))) + (if (eq returns *wild-type*) + (specifier-type 'function) + (%make-fun-type :wild-args t :returns returns)) + (multiple-value-bind (required optional rest keyp keywords allowp) + (args-types args) + (if (and (null required) + (null optional) + (eq rest *universal-type*) + (not keyp)) + (if (eq returns *wild-type*) + (specifier-type 'function) + (%make-fun-type :wild-args t :returns returns)) + (%make-fun-type :required required + :optional optional + :rest rest + :keyp keyp + :keywords keywords + :allowp allowp + :returns returns)))) ;; FIXME: are we really sure that we won't make something that ;; looks like a completely wild function here? (apply #'%make-fun-type initargs))) @@ -214,9 +214,9 @@ ;;; type specifiers used within the compiler. (It represents something ;;; that the compiler knows to be a constant.) (defstruct (constant-type - (:include ctype - (class-info (type-class-or-lose 'constant))) - (:copier nil)) + (:include ctype + (class-info (type-class-or-lose 'constant))) + (:copier nil)) ;; The type which the argument must be a constant instance of for this type ;; specifier to win. (type (missing-arg) :type ctype)) @@ -226,8 +226,8 @@ ;;; NIL aren't classes anyway, so it wouldn't make much sense to make ;;; them built-in classes. (defstruct (named-type (:include ctype - (class-info (type-class-or-lose 'named))) - (:copier nil)) + (class-info (type-class-or-lose 'named))) + (:copier nil)) (name nil :type symbol)) ;;; a list of all the float "formats" (i.e. internal representations; @@ -242,9 +242,9 @@ ;;; A NUMERIC-TYPE represents any numeric type, including things ;;; such as FIXNUM. (defstruct (numeric-type (:include ctype - (class-info (type-class-or-lose 'number))) - (:constructor %make-numeric-type) - (:copier nil)) + (class-info (type-class-or-lose 'number))) + (:constructor %make-numeric-type) + (:copier nil)) ;; the kind of numeric type we have, or NIL if not specified (just ;; NUMBER or COMPLEX) ;; @@ -281,54 +281,54 @@ ;;; cases, despite the name, we return *EMPTY-TYPE* instead of a ;;; NUMERIC-TYPE. (defun make-numeric-type (&key class format (complexp :real) low high - enumerable) + enumerable) ;; if interval is empty (if (and low - high - (if (or (consp low) (consp high)) ; if either bound is exclusive - (>= (type-bound-number low) (type-bound-number high)) - (> low high))) + high + (if (or (consp low) (consp high)) ; if either bound is exclusive + (>= (type-bound-number low) (type-bound-number high)) + (> low high))) *empty-type* (multiple-value-bind (canonical-low canonical-high) - (case class - (integer - ;; INTEGER types always have their LOW and HIGH bounds - ;; represented as inclusive, not exclusive values. - (values (if (consp low) - (1+ (type-bound-number low)) - low) - (if (consp high) - (1- (type-bound-number high)) - high))) - (t - ;; no canonicalization necessary - (values low high))) - (when (and (eq class 'rational) - (integerp canonical-low) - (integerp canonical-high) - (= canonical-low canonical-high)) - (setf class 'integer)) - (%make-numeric-type :class class - :format format - :complexp complexp - :low canonical-low - :high canonical-high - :enumerable enumerable)))) + (case class + (integer + ;; INTEGER types always have their LOW and HIGH bounds + ;; represented as inclusive, not exclusive values. + (values (if (consp low) + (1+ (type-bound-number low)) + low) + (if (consp high) + (1- (type-bound-number high)) + high))) + (t + ;; no canonicalization necessary + (values low high))) + (when (and (eq class 'rational) + (integerp canonical-low) + (integerp canonical-high) + (= canonical-low canonical-high)) + (setf class 'integer)) + (%make-numeric-type :class class + :format format + :complexp complexp + :low canonical-low + :high canonical-high + :enumerable enumerable)))) (defun modified-numeric-type (base - &key - (class (numeric-type-class base)) - (format (numeric-type-format base)) - (complexp (numeric-type-complexp base)) - (low (numeric-type-low base)) - (high (numeric-type-high base)) - (enumerable (numeric-type-enumerable base))) + &key + (class (numeric-type-class base)) + (format (numeric-type-format base)) + (complexp (numeric-type-complexp base)) + (low (numeric-type-low base)) + (high (numeric-type-high base)) + (enumerable (numeric-type-enumerable base))) (make-numeric-type :class class - :format format - :complexp complexp - :low low - :high high - :enumerable enumerable)) + :format format + :complexp complexp + :low low + :high high + :enumerable enumerable)) (defstruct (character-set-type (:include ctype @@ -361,9 +361,9 @@ ;;; An ARRAY-TYPE is used to represent any array type, including ;;; things such as SIMPLE-BASE-STRING. (defstruct (array-type (:include ctype - (class-info (type-class-or-lose 'array))) + (class-info (type-class-or-lose 'array))) (:constructor %make-array-type) - (:copier nil)) + (:copier nil)) ;; the dimensions of the array, or * if unspecified. If a dimension ;; is unspecified, it is *. (dimensions '* :type (or list (member *))) @@ -379,11 +379,11 @@ ;;; bother with this at this level because MEMBER types are fairly ;;; important and union and intersection are well defined. (defstruct (member-type (:include ctype - (class-info (type-class-or-lose 'member)) - (enumerable t)) - (:copier nil) - (:constructor %make-member-type (members)) - #-sb-xc-host (:pure nil)) + (class-info (type-class-or-lose 'member)) + (enumerable t)) + (:copier nil) + (:constructor %make-member-type (members)) + #-sb-xc-host (:pure nil)) ;; the things in the set, with no duplications (members nil :type list)) (defun make-member-type (&key members) @@ -395,35 +395,35 @@ ;; ranges are compared by arithmetic operators (while MEMBERship is ;; compared by EQL). -- CSR, 2003-04-23 (let ((singlep (subsetp `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members)) - (doublep (subsetp `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members)) - #!+long-float - (longp (subsetp `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members))) + (doublep (subsetp `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members)) + #!+long-float + (longp (subsetp `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members))) (if (or singlep doublep #!+long-float longp) - (let (union-types) - (when singlep - (push (ctype-of 0.0f0) union-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0)))) - (when doublep - (push (ctype-of 0.0d0) union-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0)))) - #!+long-float - (when longp - (push (ctype-of 0.0l0) union-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0)))) - (aver (not (null union-types))) - (make-union-type t - (if (null members) - union-types - (cons (%make-member-type members) - union-types)))) - (%make-member-type members)))) + (let (union-types) + (when singlep + (push (ctype-of 0.0f0) union-types) + (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0)))) + (when doublep + (push (ctype-of 0.0d0) union-types) + (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0)))) + #!+long-float + (when longp + (push (ctype-of 0.0l0) union-types) + (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0)))) + (aver (not (null union-types))) + (make-union-type t + (if (null members) + union-types + (cons (%make-member-type members) + union-types)))) + (%make-member-type members)))) ;;; A COMPOUND-TYPE is a type defined out of a set of types, the ;;; common parent of UNION-TYPE and INTERSECTION-TYPE. (defstruct (compound-type (:include ctype - (might-contain-other-types-p t)) - (:constructor nil) - (:copier nil)) + (might-contain-other-types-p t)) + (:constructor nil) + (:copier nil)) (types nil :type list :read-only t)) ;;; A UNION-TYPE represents a use of the OR type specifier which we @@ -434,9 +434,9 @@ ;;; this hadn't been fully implemented yet. ;;; 2. There are never any UNION-TYPE components. (defstruct (union-type (:include compound-type - (class-info (type-class-or-lose 'union))) - (:constructor %make-union-type (enumerable types)) - (:copier nil))) + (class-info (type-class-or-lose 'union))) + (:constructor %make-union-type (enumerable types)) + (:copier nil))) (define-cached-synonym make-union-type) ;;; An INTERSECTION-TYPE represents a use of the AND type specifier @@ -451,11 +451,11 @@ ;;; unions contain intersections and not vice versa, or we ;;; should just punt to using a HAIRY-TYPE. (defstruct (intersection-type (:include compound-type - (class-info (type-class-or-lose - 'intersection))) - (:constructor %make-intersection-type - (enumerable types)) - (:copier nil))) + (class-info (type-class-or-lose + 'intersection))) + (:constructor %make-intersection-type + (enumerable types)) + (:copier nil))) ;;; Return TYPE converted to canonical form for a situation where the ;;; "type" '* (which SBCL still represents as a type even though ANSI @@ -468,10 +468,10 @@ ;;; A CONS-TYPE is used to represent a CONS type. (defstruct (cons-type (:include ctype (class-info (type-class-or-lose 'cons))) - (:constructor - %make-cons-type (car-type - cdr-type)) - (:copier nil)) + (:constructor + %make-cons-type (car-type + cdr-type)) + (:copier nil)) ;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types) ;; ;; FIXME: Most or all other type structure slots could also be :READ-ONLY. @@ -481,7 +481,7 @@ (aver (not (or (eq car-type *wild-type*) (eq cdr-type *wild-type*)))) (if (or (eq car-type *empty-type*) - (eq cdr-type *empty-type*)) + (eq cdr-type *empty-type*)) *empty-type* (%make-cons-type car-type cdr-type))) @@ -491,17 +491,17 @@ (cdr (cons-type-cdr-type type) (cons-type-cdr-type cdr))) ((not (cons-type-p cdr)) (cond - ((csubtypep cdr (specifier-type 'null)) - (values min t)) - ((csubtypep *universal-type* cdr) - (values min nil)) - ((type/= (type-intersection (specifier-type 'cons) cdr) *empty-type*) - (values min nil)) - ((type/= (type-intersection (specifier-type 'null) cdr) *empty-type*) - (values min t)) - (t (values min :maybe)))) + ((csubtypep cdr (specifier-type 'null)) + (values min t)) + ((csubtypep *universal-type* cdr) + (values min nil)) + ((type/= (type-intersection (specifier-type 'cons) cdr) *empty-type*) + (values min nil)) + ((type/= (type-intersection (specifier-type 'null) cdr) *empty-type*) + (values min t)) + (t (values min :maybe)))) ())) - + ;;;; type utilities @@ -511,49 +511,49 @@ ;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a ;;; type is defined (or redefined). (defun-cached (values-specifier-type - :hash-function (lambda (x) + :hash-function (lambda (x) (logand (sxhash x) #x3FF)) - :hash-bits 10 - :init-wrapper !cold-init-forms) - ((orig equal-but-no-car-recursion)) + :hash-bits 10 + :init-wrapper !cold-init-forms) + ((orig equal-but-no-car-recursion)) (let ((u (uncross orig))) (or (info :type :builtin u) - (let ((spec (type-expand u))) - (cond - ((and (not (eq spec u)) - (info :type :builtin spec))) - ((eq (info :type :kind spec) :instance) - (find-classoid spec)) - ((typep spec 'classoid) - ;; There doesn't seem to be any way to translate - ;; (TYPEP SPEC 'BUILT-IN-CLASS) into something which can be - ;; executed on the host Common Lisp at cross-compilation time. - #+sb-xc-host (error - "stub: (TYPEP SPEC 'BUILT-IN-CLASS) on xc host") - (if (typep spec 'built-in-classoid) - (or (built-in-classoid-translation spec) spec) - spec)) - (t - (when (and (atom spec) - (member spec '(and or not member eql satisfies values))) - (error "The symbol ~S is not valid as a type specifier." spec)) - (let* ((lspec (if (atom spec) (list spec) spec)) - (fun (info :type :translator (car lspec)))) - (cond (fun - (funcall fun lspec)) - ((or (and (consp spec) (symbolp (car spec)) - (not (info :type :builtin (car spec)))) - (and (symbolp spec) (not (info :type :builtin spec)))) - (when (and *type-system-initialized* + (let ((spec (type-expand u))) + (cond + ((and (not (eq spec u)) + (info :type :builtin spec))) + ((eq (info :type :kind spec) :instance) + (find-classoid spec)) + ((typep spec 'classoid) + ;; There doesn't seem to be any way to translate + ;; (TYPEP SPEC 'BUILT-IN-CLASS) into something which can be + ;; executed on the host Common Lisp at cross-compilation time. + #+sb-xc-host (error + "stub: (TYPEP SPEC 'BUILT-IN-CLASS) on xc host") + (if (typep spec 'built-in-classoid) + (or (built-in-classoid-translation spec) spec) + spec)) + (t + (when (and (atom spec) + (member spec '(and or not member eql satisfies values))) + (error "The symbol ~S is not valid as a type specifier." spec)) + (let* ((lspec (if (atom spec) (list spec) spec)) + (fun (info :type :translator (car lspec)))) + (cond (fun + (funcall fun lspec)) + ((or (and (consp spec) (symbolp (car spec)) + (not (info :type :builtin (car spec)))) + (and (symbolp spec) (not (info :type :builtin spec)))) + (when (and *type-system-initialized* (not (eq (info :type :kind spec) :forthcoming-defclass-type))) - (signal 'parse-unknown-type :specifier spec)) - ;; (The RETURN-FROM here inhibits caching.) - (return-from values-specifier-type - (make-unknown-type :specifier spec))) - (t - (error "bad thing to be a type specifier: ~S" - spec)))))))))) + (signal 'parse-unknown-type :specifier spec)) + ;; (The RETURN-FROM here inhibits caching.) + (return-from values-specifier-type + (make-unknown-type :specifier spec))) + (t + (error "bad thing to be a type specifier: ~S" + spec)))))))))) ;;; This is like VALUES-SPECIFIER-TYPE, except that we guarantee to ;;; never return a VALUES type. @@ -577,7 +577,7 @@ (let ((def (cond ((symbolp form) (info :type :expander form)) ((and (consp form) (symbolp (car form))) - (info :type :expander (car form))) + (info :type :expander (car form))) (t nil)))) (if def (type-expand (funcall def (if (consp form) form (list form)))) diff --git a/src/code/error-error.lisp b/src/code/error-error.lisp index f76b5b8..5d3be6f 100644 --- a/src/code/error-error.lisp +++ b/src/code/error-error.lisp @@ -33,12 +33,12 @@ (with-standard-io-syntax (let ((*print-readably* nil)) - (dolist (item messages) - (princ item *terminal-io*)) + (dolist (item messages) + (princ item *terminal-io*)) (terpri *terminal-io*) (sb!debug:backtrace most-positive-fixnum *terminal-io*) (force-output *terminal-io*) - (invoke-debugger + (invoke-debugger (coerce-to-condition "Maximum error nesting depth exceeded" nil 'simple-error 'error)))))) diff --git a/src/code/error.lisp b/src/code/error.lisp index 9d8082b..522df87 100644 --- a/src/code/error.lisp +++ b/src/code/error.lisp @@ -27,7 +27,7 @@ ;;; single argument that's directly usable by all the other routines. (defun coerce-to-condition (datum arguments default-type fun-name) (cond ((typep datum 'condition) - (when (and arguments (not (eq fun-name 'cerror))) + (when (and arguments (not (eq fun-name 'cerror))) (cerror "Ignore the additional arguments." 'simple-type-error :datum arguments @@ -35,30 +35,30 @@ :format-control "You may not supply additional arguments ~ when giving ~S to ~S." :format-arguments (list datum fun-name))) - datum) - ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION) - (apply #'make-condition datum arguments)) - ((or (stringp datum) (functionp datum)) - (make-condition default-type - :format-control datum - :format-arguments arguments)) - (t - (error 'simple-type-error - :datum datum - :expected-type '(or symbol string) - :format-control "bad argument to ~S: ~S" - :format-arguments (list fun-name datum))))) + datum) + ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION) + (apply #'make-condition datum arguments)) + ((or (stringp datum) (functionp datum)) + (make-condition default-type + :format-control datum + :format-arguments arguments)) + (t + (error 'simple-type-error + :datum datum + :expected-type '(or symbol string) + :format-control "bad argument to ~S: ~S" + :format-arguments (list fun-name datum))))) (define-condition layout-invalid (type-error) () (:report (lambda (condition stream) (format stream - "~@" - (classoid-proper-name (type-error-expected-type condition)) - (type-error-datum condition))))) + (classoid-proper-name (type-error-expected-type condition)) + (type-error-datum condition))))) (define-condition case-failure (type-error) ((name :reader case-failure-name :initarg :name) @@ -67,19 +67,19 @@ (lambda (condition stream) (format stream "~@<~S fell through ~S expression. ~ ~:_Wanted one of ~:S.~:>" - (type-error-datum condition) - (case-failure-name condition) - (case-failure-possibilities condition))))) + (type-error-datum condition) + (case-failure-name condition) + (case-failure-possibilities condition))))) (define-condition compiled-program-error (program-error) ((message :initarg :message :reader program-error-message) (source :initarg :source :reader program-error-source)) (:report (lambda (condition stream) - (format stream "Execution of a form compiled with errors.~%~ + (format stream "Execution of a form compiled with errors.~%~ Form:~% ~A~%~ Compile-time-error:~% ~A" - (program-error-source condition) - (program-error-message condition))))) + (program-error-source condition) + (program-error-message condition))))) (define-condition simple-control-error (simple-condition control-error) ()) (define-condition simple-file-error (simple-condition file-error) ()) diff --git a/src/code/eucjp.lisp b/src/code/eucjp.lisp index fd7277c..e5e493a 100644 --- a/src/code/eucjp.lisp +++ b/src/code/eucjp.lisp @@ -2,13091 +2,13091 @@ (let ((ucs-to-eucjp-table (make-hash-table)) (eucjp-to-ucs-table (make-hash-table))) - (let ((ucs<->eucjp ; bi-directional table UCS <-> EUC-JP - ;; based on eucJP-ascii in - ;; - '((#x00A1 . #x8FA2C2) - (#x00A2 . #xA1F1) - (#x00A3 . #xA1F2) - (#x00A4 . #x8FA2F0) - (#x00A5 . #xA1EF) - (#x00A6 . #x8FA2C3) - (#x00A7 . #xA1F8) - (#x00A8 . #xA1AF) - (#x00A9 . #x8FA2ED) - (#x00AA . #x8FA2EC) - (#x00AC . #xA2CC) - (#x00AE . #x8FA2EE) - (#x00AF . #x8FA2B4) - (#x00B0 . #xA1EB) - (#x00B1 . #xA1DE) - (#x00B4 . #xA1AD) - (#x00B6 . #xA2F9) - (#x00B8 . #x8FA2B1) - (#x00BA . #x8FA2EB) - (#x00BF . #x8FA2C4) - (#x00C0 . #x8FAAA2) - (#x00C1 . #x8FAAA1) - (#x00C2 . #x8FAAA4) - (#x00C3 . #x8FAAAA) - (#x00C4 . #x8FAAA3) - (#x00C5 . #x8FAAA9) - (#x00C6 . #x8FA9A1) - (#x00C7 . #x8FAAAE) - (#x00C8 . #x8FAAB2) - (#x00C9 . #x8FAAB1) - (#x00CA . #x8FAAB4) - (#x00CB . #x8FAAB3) - (#x00CC . #x8FAAC0) - (#x00CD . #x8FAABF) - (#x00CE . #x8FAAC2) - (#x00CF . #x8FAAC1) - (#x00D1 . #x8FAAD0) - (#x00D2 . #x8FAAD2) - (#x00D3 . #x8FAAD1) - (#x00D4 . #x8FAAD4) - (#x00D5 . #x8FAAD8) - (#x00D6 . #x8FAAD3) - (#x00D7 . #xA1DF) - (#x00D8 . #x8FA9AC) - (#x00D9 . #x8FAAE3) - (#x00DA . #x8FAAE2) - (#x00DB . #x8FAAE5) - (#x00DC . #x8FAAE4) - (#x00DD . #x8FAAF2) - (#x00DE . #x8FA9B0) - (#x00DF . #x8FA9CE) - (#x00E0 . #x8FABA2) - (#x00E1 . #x8FABA1) - (#x00E2 . #x8FABA4) - (#x00E3 . #x8FABAA) - (#x00E4 . #x8FABA3) - (#x00E5 . #x8FABA9) - (#x00E6 . #x8FA9C1) - (#x00E7 . #x8FABAE) - (#x00E8 . #x8FABB2) - (#x00E9 . #x8FABB1) - (#x00EA . #x8FABB4) - (#x00EB . #x8FABB3) - (#x00EC . #x8FABC0) - (#x00ED . #x8FABBF) - (#x00EE . #x8FABC2) - (#x00EF . #x8FABC1) - (#x00F0 . #x8FA9C3) - (#x00F1 . #x8FABD0) - (#x00F2 . #x8FABD2) - (#x00F3 . #x8FABD1) - (#x00F4 . #x8FABD4) - (#x00F5 . #x8FABD8) - (#x00F6 . #x8FABD3) - (#x00F7 . #xA1E0) - (#x00F8 . #x8FA9CC) - (#x00F9 . #x8FABE3) - (#x00FA . #x8FABE2) - (#x00FB . #x8FABE5) - (#x00FC . #x8FABE4) - (#x00FD . #x8FABF2) - (#x00FE . #x8FA9D0) - (#x00FF . #x8FABF3) - (#x0100 . #x8FAAA7) - (#x0101 . #x8FABA7) - (#x0102 . #x8FAAA5) - (#x0103 . #x8FABA5) - (#x0104 . #x8FAAA8) - (#x0105 . #x8FABA8) - (#x0106 . #x8FAAAB) - (#x0107 . #x8FABAB) - (#x0108 . #x8FAAAC) - (#x0109 . #x8FABAC) - (#x010A . #x8FAAAF) - (#x010B . #x8FABAF) - (#x010C . #x8FAAAD) - (#x010D . #x8FABAD) - (#x010E . #x8FAAB0) - (#x010F . #x8FABB0) - (#x0110 . #x8FA9A2) - (#x0111 . #x8FA9C2) - (#x0112 . #x8FAAB7) - (#x0113 . #x8FABB7) - (#x0116 . #x8FAAB6) - (#x0117 . #x8FABB6) - (#x0118 . #x8FAAB8) - (#x0119 . #x8FABB8) - (#x011A . #x8FAAB5) - (#x011B . #x8FABB5) - (#x011C . #x8FAABA) - (#x011D . #x8FABBA) - (#x011E . #x8FAABB) - (#x011F . #x8FABBB) - (#x0120 . #x8FAABD) - (#x0121 . #x8FABBD) - (#x0122 . #x8FAABC) - (#x0124 . #x8FAABE) - (#x0125 . #x8FABBE) - (#x0126 . #x8FA9A4) - (#x0127 . #x8FA9C4) - (#x0128 . #x8FAAC7) - (#x0129 . #x8FABC7) - (#x012A . #x8FAAC5) - (#x012B . #x8FABC5) - (#x012E . #x8FAAC6) - (#x012F . #x8FABC6) - (#x0130 . #x8FAAC4) - (#x0131 . #x8FA9C5) - (#x0132 . #x8FA9A6) - (#x0133 . #x8FA9C6) - (#x0134 . #x8FAAC8) - (#x0135 . #x8FABC8) - (#x0136 . #x8FAAC9) - (#x0137 . #x8FABC9) - (#x0138 . #x8FA9C7) - (#x0139 . #x8FAACA) - (#x013A . #x8FABCA) - (#x013B . #x8FAACC) - (#x013C . #x8FABCC) - (#x013D . #x8FAACB) - (#x013E . #x8FABCB) - (#x013F . #x8FA9A9) - (#x0140 . #x8FA9C9) - (#x0141 . #x8FA9A8) - (#x0142 . #x8FA9C8) - (#x0143 . #x8FAACD) - (#x0144 . #x8FABCD) - (#x0145 . #x8FAACF) - (#x0146 . #x8FABCF) - (#x0147 . #x8FAACE) - (#x0148 . #x8FABCE) - (#x0149 . #x8FA9CA) - (#x014A . #x8FA9AB) - (#x014B . #x8FA9CB) - (#x014C . #x8FAAD7) - (#x014D . #x8FABD7) - (#x0150 . #x8FAAD6) - (#x0151 . #x8FABD6) - (#x0152 . #x8FA9AD) - (#x0153 . #x8FA9CD) - (#x0154 . #x8FAAD9) - (#x0155 . #x8FABD9) - (#x0156 . #x8FAADB) - (#x0157 . #x8FABDB) - (#x0158 . #x8FAADA) - (#x0159 . #x8FABDA) - (#x015A . #x8FAADC) - (#x015B . #x8FABDC) - (#x015C . #x8FAADD) - (#x015D . #x8FABDD) - (#x015E . #x8FAADF) - (#x015F . #x8FABDF) - (#x0160 . #x8FAADE) - (#x0161 . #x8FABDE) - (#x0162 . #x8FAAE1) - (#x0163 . #x8FABE1) - (#x0164 . #x8FAAE0) - (#x0165 . #x8FABE0) - (#x0166 . #x8FA9AF) - (#x0167 . #x8FA9CF) - (#x0168 . #x8FAAEC) - (#x0169 . #x8FABEC) - (#x016A . #x8FAAE9) - (#x016B . #x8FABE9) - (#x016C . #x8FAAE6) - (#x016D . #x8FABE6) - (#x016E . #x8FAAEB) - (#x016F . #x8FABEB) - (#x0170 . #x8FAAE8) - (#x0171 . #x8FABE8) - (#x0172 . #x8FAAEA) - (#x0173 . #x8FABEA) - (#x0174 . #x8FAAF1) - (#x0175 . #x8FABF1) - (#x0176 . #x8FAAF4) - (#x0177 . #x8FABF4) - (#x0178 . #x8FAAF3) - (#x0179 . #x8FAAF5) - (#x017A . #x8FABF5) - (#x017B . #x8FAAF7) - (#x017C . #x8FABF7) - (#x017D . #x8FAAF6) - (#x017E . #x8FABF6) - (#x01CD . #x8FAAA6) - (#x01CE . #x8FABA6) - (#x01CF . #x8FAAC3) - (#x01D0 . #x8FABC3) - (#x01D1 . #x8FAAD5) - (#x01D2 . #x8FABD5) - (#x01D3 . #x8FAAE7) - (#x01D4 . #x8FABE7) - (#x01D5 . #x8FAAF0) - (#x01D6 . #x8FABF0) - (#x01D7 . #x8FAAED) - (#x01D8 . #x8FABED) - (#x01D9 . #x8FAAEF) - (#x01DA . #x8FABEF) - (#x01DB . #x8FAAEE) - (#x01DC . #x8FABEE) - (#x01F5 . #x8FABB9) - (#x02C7 . #x8FA2B0) - (#x02D8 . #x8FA2AF) - (#x02D9 . #x8FA2B2) - (#x02DA . #x8FA2B6) - (#x02DB . #x8FA2B5) - (#x02DD . #x8FA2B3) - (#x0384 . #x8FA2B8) - (#x0385 . #x8FA2B9) - (#x0386 . #x8FA6E1) - (#x0388 . #x8FA6E2) - (#x0389 . #x8FA6E3) - (#x038A . #x8FA6E4) - (#x038C . #x8FA6E7) - (#x038E . #x8FA6E9) - (#x038F . #x8FA6EC) - (#x0390 . #x8FA6F6) - (#x0391 . #xA6A1) - (#x0392 . #xA6A2) - (#x0393 . #xA6A3) - (#x0394 . #xA6A4) - (#x0395 . #xA6A5) - (#x0396 . #xA6A6) - (#x0397 . #xA6A7) - (#x0398 . #xA6A8) - (#x0399 . #xA6A9) - (#x039A . #xA6AA) - (#x039B . #xA6AB) - (#x039C . #xA6AC) - (#x039D . #xA6AD) - (#x039E . #xA6AE) - (#x039F . #xA6AF) - (#x03A0 . #xA6B0) - (#x03A1 . #xA6B1) - (#x03A3 . #xA6B2) - (#x03A4 . #xA6B3) - (#x03A5 . #xA6B4) - (#x03A6 . #xA6B5) - (#x03A7 . #xA6B6) - (#x03A8 . #xA6B7) - (#x03A9 . #xA6B8) - (#x03AA . #x8FA6E5) - (#x03AB . #x8FA6EA) - (#x03AC . #x8FA6F1) - (#x03AD . #x8FA6F2) - (#x03AE . #x8FA6F3) - (#x03AF . #x8FA6F4) - (#x03B0 . #x8FA6FB) - (#x03B1 . #xA6C1) - (#x03B2 . #xA6C2) - (#x03B3 . #xA6C3) - (#x03B4 . #xA6C4) - (#x03B5 . #xA6C5) - (#x03B6 . #xA6C6) - (#x03B7 . #xA6C7) - (#x03B8 . #xA6C8) - (#x03B9 . #xA6C9) - (#x03BA . #xA6CA) - (#x03BB . #xA6CB) - (#x03BC . #xA6CC) - (#x03BD . #xA6CD) - (#x03BE . #xA6CE) - (#x03BF . #xA6CF) - (#x03C0 . #xA6D0) - (#x03C1 . #xA6D1) - (#x03C2 . #x8FA6F8) - (#x03C3 . #xA6D2) - (#x03C4 . #xA6D3) - (#x03C5 . #xA6D4) - (#x03C6 . #xA6D5) - (#x03C7 . #xA6D6) - (#x03C8 . #xA6D7) - (#x03C9 . #xA6D8) - (#x03CA . #x8FA6F5) - (#x03CB . #x8FA6FA) - (#x03CC . #x8FA6F7) - (#x03CD . #x8FA6F9) - (#x03CE . #x8FA6FC) - (#x0401 . #xA7A7) - (#x0402 . #x8FA7C2) - (#x0403 . #x8FA7C3) - (#x0404 . #x8FA7C4) - (#x0405 . #x8FA7C5) - (#x0406 . #x8FA7C6) - (#x0407 . #x8FA7C7) - (#x0408 . #x8FA7C8) - (#x0409 . #x8FA7C9) - (#x040A . #x8FA7CA) - (#x040B . #x8FA7CB) - (#x040C . #x8FA7CC) - (#x040E . #x8FA7CD) - (#x040F . #x8FA7CE) - (#x0410 . #xA7A1) - (#x0411 . #xA7A2) - (#x0412 . #xA7A3) - (#x0413 . #xA7A4) - (#x0414 . #xA7A5) - (#x0415 . #xA7A6) - (#x0416 . #xA7A8) - (#x0417 . #xA7A9) - (#x0418 . #xA7AA) - (#x0419 . #xA7AB) - (#x041A . #xA7AC) - (#x041B . #xA7AD) - (#x041C . #xA7AE) - (#x041D . #xA7AF) - (#x041E . #xA7B0) - (#x041F . #xA7B1) - (#x0420 . #xA7B2) - (#x0421 . #xA7B3) - (#x0422 . #xA7B4) - (#x0423 . #xA7B5) - (#x0424 . #xA7B6) - (#x0425 . #xA7B7) - (#x0426 . #xA7B8) - (#x0427 . #xA7B9) - (#x0428 . #xA7BA) - (#x0429 . #xA7BB) - (#x042A . #xA7BC) - (#x042B . #xA7BD) - (#x042C . #xA7BE) - (#x042D . #xA7BF) - (#x042E . #xA7C0) - (#x042F . #xA7C1) - (#x0430 . #xA7D1) - (#x0431 . #xA7D2) - (#x0432 . #xA7D3) - (#x0433 . #xA7D4) - (#x0434 . #xA7D5) - (#x0435 . #xA7D6) - (#x0436 . #xA7D8) - (#x0437 . #xA7D9) - (#x0438 . #xA7DA) - (#x0439 . #xA7DB) - (#x043A . #xA7DC) - (#x043B . #xA7DD) - (#x043C . #xA7DE) - (#x043D . #xA7DF) - (#x043E . #xA7E0) - (#x043F . #xA7E1) - (#x0440 . #xA7E2) - (#x0441 . #xA7E3) - (#x0442 . #xA7E4) - (#x0443 . #xA7E5) - (#x0444 . #xA7E6) - (#x0445 . #xA7E7) - (#x0446 . #xA7E8) - (#x0447 . #xA7E9) - (#x0448 . #xA7EA) - (#x0449 . #xA7EB) - (#x044A . #xA7EC) - (#x044B . #xA7ED) - (#x044C . #xA7EE) - (#x044D . #xA7EF) - (#x044E . #xA7F0) - (#x044F . #xA7F1) - (#x0451 . #xA7D7) - (#x0452 . #x8FA7F2) - (#x0453 . #x8FA7F3) - (#x0454 . #x8FA7F4) - (#x0455 . #x8FA7F5) - (#x0456 . #x8FA7F6) - (#x0457 . #x8FA7F7) - (#x0458 . #x8FA7F8) - (#x0459 . #x8FA7F9) - (#x045A . #x8FA7FA) - (#x045B . #x8FA7FB) - (#x045C . #x8FA7FC) - (#x045E . #x8FA7FD) - (#x045F . #x8FA7FE) - (#x2010 . #xA1BE) - (#x2014 . #xA1BD) - (#x2016 . #xA1C2) - (#x2018 . #xA1C6) - (#x2019 . #xA1C7) - (#x201C . #xA1C8) - (#x201D . #xA1C9) - (#x2020 . #xA2F7) - (#x2021 . #xA2F8) - (#x2025 . #xA1C5) - (#x2026 . #xA1C4) - (#x2030 . #xA2F3) - (#x2032 . #xA1EC) - (#x2033 . #xA1ED) - (#x203B . #xA2A8) - (#x203E . #xA1B1) - (#x2103 . #xA1EE) - (#x2116 . #x8FA2F1) - (#x2122 . #x8FA2EF) - (#x212B . #xA2F2) - (#x2190 . #xA2AB) - (#x2191 . #xA2AC) - (#x2192 . #xA2AA) - (#x2193 . #xA2AD) - (#x21D2 . #xA2CD) - (#x21D4 . #xA2CE) - (#x2200 . #xA2CF) - (#x2202 . #xA2DF) - (#x2203 . #xA2D0) - (#x2207 . #xA2E0) - (#x2208 . #xA2BA) - (#x220B . #xA2BB) - (#x2212 . #xA1DD) - (#x221A . #xA2E5) - (#x221D . #xA2E7) - (#x221E . #xA1E7) - (#x2220 . #xA2DC) - (#x2227 . #xA2CA) - (#x2228 . #xA2CB) - (#x2229 . #xA2C1) - (#x222A . #xA2C0) - (#x222B . #xA2E9) - (#x222C . #xA2EA) - (#x2234 . #xA1E8) - (#x2235 . #xA2E8) - (#x223D . #xA2E6) - (#x2252 . #xA2E2) - (#x2260 . #xA1E2) - (#x2261 . #xA2E1) - (#x2266 . #xA1E5) - (#x2267 . #xA1E6) - (#x226A . #xA2E3) - (#x226B . #xA2E4) - (#x2282 . #xA2BE) - (#x2283 . #xA2BF) - (#x2286 . #xA2BC) - (#x2287 . #xA2BD) - (#x22A5 . #xA2DD) - (#x2312 . #xA2DE) - (#x2500 . #xA8A1) - (#x2501 . #xA8AC) - (#x2502 . #xA8A2) - (#x2503 . #xA8AD) - (#x250C . #xA8A3) - (#x250F . #xA8AE) - (#x2510 . #xA8A4) - (#x2513 . #xA8AF) - (#x2514 . #xA8A6) - (#x2517 . #xA8B1) - (#x2518 . #xA8A5) - (#x251B . #xA8B0) - (#x251C . #xA8A7) - (#x251D . #xA8BC) - (#x2520 . #xA8B7) - (#x2523 . #xA8B2) - (#x2524 . #xA8A9) - (#x2525 . #xA8BE) - (#x2528 . #xA8B9) - (#x252B . #xA8B4) - (#x252C . #xA8A8) - (#x252F . #xA8B8) - (#x2530 . #xA8BD) - (#x2533 . #xA8B3) - (#x2534 . #xA8AA) - (#x2537 . #xA8BA) - (#x2538 . #xA8BF) - (#x253B . #xA8B5) - (#x253C . #xA8AB) - (#x253F . #xA8BB) - (#x2542 . #xA8C0) - (#x254B . #xA8B6) - (#x25A0 . #xA2A3) - (#x25A1 . #xA2A2) - (#x25B2 . #xA2A5) - (#x25B3 . #xA2A4) - (#x25BC . #xA2A7) - (#x25BD . #xA2A6) - (#x25C6 . #xA2A1) - (#x25C7 . #xA1FE) - (#x25CB . #xA1FB) - (#x25CE . #xA1FD) - (#x25CF . #xA1FC) - (#x25EF . #xA2FE) - (#x2605 . #xA1FA) - (#x2606 . #xA1F9) - (#x2640 . #xA1EA) - (#x2642 . #xA1E9) - (#x266A . #xA2F6) - (#x266D . #xA2F5) - (#x266F . #xA2F4) - (#x3000 . #xA1A1) - (#x3001 . #xA1A2) - (#x3002 . #xA1A3) - (#x3003 . #xA1B7) - (#x3005 . #xA1B9) - (#x3006 . #xA1BA) - (#x3007 . #xA1BB) - (#x3008 . #xA1D2) - (#x3009 . #xA1D3) - (#x300A . #xA1D4) - (#x300B . #xA1D5) - (#x300C . #xA1D6) - (#x300D . #xA1D7) - (#x300E . #xA1D8) - (#x300F . #xA1D9) - (#x3010 . #xA1DA) - (#x3011 . #xA1DB) - (#x3012 . #xA2A9) - (#x3013 . #xA2AE) - (#x3014 . #xA1CC) - (#x3015 . #xA1CD) - (#x301C . #xA1C1) - (#x3041 . #xA4A1) - (#x3042 . #xA4A2) - (#x3043 . #xA4A3) - (#x3044 . #xA4A4) - (#x3045 . #xA4A5) - (#x3046 . #xA4A6) - (#x3047 . #xA4A7) - (#x3048 . #xA4A8) - (#x3049 . #xA4A9) - (#x304A . #xA4AA) - (#x304B . #xA4AB) - (#x304C . #xA4AC) - (#x304D . #xA4AD) - (#x304E . #xA4AE) - (#x304F . #xA4AF) - (#x3050 . #xA4B0) - (#x3051 . #xA4B1) - (#x3052 . #xA4B2) - (#x3053 . #xA4B3) - (#x3054 . #xA4B4) - (#x3055 . #xA4B5) - (#x3056 . #xA4B6) - (#x3057 . #xA4B7) - (#x3058 . #xA4B8) - (#x3059 . #xA4B9) - (#x305A . #xA4BA) - (#x305B . #xA4BB) - (#x305C . #xA4BC) - (#x305D . #xA4BD) - (#x305E . #xA4BE) - (#x305F . #xA4BF) - (#x3060 . #xA4C0) - (#x3061 . #xA4C1) - (#x3062 . #xA4C2) - (#x3063 . #xA4C3) - (#x3064 . #xA4C4) - (#x3065 . #xA4C5) - (#x3066 . #xA4C6) - (#x3067 . #xA4C7) - (#x3068 . #xA4C8) - (#x3069 . #xA4C9) - (#x306A . #xA4CA) - (#x306B . #xA4CB) - (#x306C . #xA4CC) - (#x306D . #xA4CD) - (#x306E . #xA4CE) - (#x306F . #xA4CF) - (#x3070 . #xA4D0) - (#x3071 . #xA4D1) - (#x3072 . #xA4D2) - (#x3073 . #xA4D3) - (#x3074 . #xA4D4) - (#x3075 . #xA4D5) - (#x3076 . #xA4D6) - (#x3077 . #xA4D7) - (#x3078 . #xA4D8) - (#x3079 . #xA4D9) - (#x307A . #xA4DA) - (#x307B . #xA4DB) - (#x307C . #xA4DC) - (#x307D . #xA4DD) - (#x307E . #xA4DE) - (#x307F . #xA4DF) - (#x3080 . #xA4E0) - (#x3081 . #xA4E1) - (#x3082 . #xA4E2) - (#x3083 . #xA4E3) - (#x3084 . #xA4E4) - (#x3085 . #xA4E5) - (#x3086 . #xA4E6) - (#x3087 . #xA4E7) - (#x3088 . #xA4E8) - (#x3089 . #xA4E9) - (#x308A . #xA4EA) - (#x308B . #xA4EB) - (#x308C . #xA4EC) - (#x308D . #xA4ED) - (#x308E . #xA4EE) - (#x308F . #xA4EF) - (#x3090 . #xA4F0) - (#x3091 . #xA4F1) - (#x3092 . #xA4F2) - (#x3093 . #xA4F3) - (#x309B . #xA1AB) - (#x309C . #xA1AC) - (#x309D . #xA1B5) - (#x309E . #xA1B6) - (#x30A1 . #xA5A1) - (#x30A2 . #xA5A2) - (#x30A3 . #xA5A3) - (#x30A4 . #xA5A4) - (#x30A5 . #xA5A5) - (#x30A6 . #xA5A6) - (#x30A7 . #xA5A7) - (#x30A8 . #xA5A8) - (#x30A9 . #xA5A9) - (#x30AA . #xA5AA) - (#x30AB . #xA5AB) - (#x30AC . #xA5AC) - (#x30AD . #xA5AD) - (#x30AE . #xA5AE) - (#x30AF . #xA5AF) - (#x30B0 . #xA5B0) - (#x30B1 . #xA5B1) - (#x30B2 . #xA5B2) - (#x30B3 . #xA5B3) - (#x30B4 . #xA5B4) - (#x30B5 . #xA5B5) - (#x30B6 . #xA5B6) - (#x30B7 . #xA5B7) - (#x30B8 . #xA5B8) - (#x30B9 . #xA5B9) - (#x30BA . #xA5BA) - (#x30BB . #xA5BB) - (#x30BC . #xA5BC) - (#x30BD . #xA5BD) - (#x30BE . #xA5BE) - (#x30BF . #xA5BF) - (#x30C0 . #xA5C0) - (#x30C1 . #xA5C1) - (#x30C2 . #xA5C2) - (#x30C3 . #xA5C3) - (#x30C4 . #xA5C4) - (#x30C5 . #xA5C5) - (#x30C6 . #xA5C6) - (#x30C7 . #xA5C7) - (#x30C8 . #xA5C8) - (#x30C9 . #xA5C9) - (#x30CA . #xA5CA) - (#x30CB . #xA5CB) - (#x30CC . #xA5CC) - (#x30CD . #xA5CD) - (#x30CE . #xA5CE) - (#x30CF . #xA5CF) - (#x30D0 . #xA5D0) - (#x30D1 . #xA5D1) - (#x30D2 . #xA5D2) - (#x30D3 . #xA5D3) - (#x30D4 . #xA5D4) - (#x30D5 . #xA5D5) - (#x30D6 . #xA5D6) - (#x30D7 . #xA5D7) - (#x30D8 . #xA5D8) - (#x30D9 . #xA5D9) - (#x30DA . #xA5DA) - (#x30DB . #xA5DB) - (#x30DC . #xA5DC) - (#x30DD . #xA5DD) - (#x30DE . #xA5DE) - (#x30DF . #xA5DF) - (#x30E0 . #xA5E0) - (#x30E1 . #xA5E1) - (#x30E2 . #xA5E2) - (#x30E3 . #xA5E3) - (#x30E4 . #xA5E4) - (#x30E5 . #xA5E5) - (#x30E6 . #xA5E6) - (#x30E7 . #xA5E7) - (#x30E8 . #xA5E8) - (#x30E9 . #xA5E9) - (#x30EA . #xA5EA) - (#x30EB . #xA5EB) - (#x30EC . #xA5EC) - (#x30ED . #xA5ED) - (#x30EE . #xA5EE) - (#x30EF . #xA5EF) - (#x30F0 . #xA5F0) - (#x30F1 . #xA5F1) - (#x30F2 . #xA5F2) - (#x30F3 . #xA5F3) - (#x30F4 . #xA5F4) - (#x30F5 . #xA5F5) - (#x30F6 . #xA5F6) - (#x30FB . #xA1A6) - (#x30FC . #xA1BC) - (#x30FD . #xA1B3) - (#x30FE . #xA1B4) - (#x4E00 . #xB0EC) - (#x4E01 . #xC3FA) - (#x4E02 . #x8FB0A1) - (#x4E03 . #xBCB7) - (#x4E04 . #x8FB0A2) - (#x4E05 . #x8FB0A3) - (#x4E07 . #xCBFC) - (#x4E08 . #xBEE6) - (#x4E09 . #xBBB0) - (#x4E0A . #xBEE5) - (#x4E0B . #xB2BC) - (#x4E0C . #x8FB0A4) - (#x4E0D . #xC9D4) - (#x4E0E . #xCDBF) - (#x4E10 . #xD0A2) - (#x4E11 . #xB1AF) - (#x4E12 . #x8FB0A5) - (#x4E14 . #xB3EE) - (#x4E15 . #xD0A3) - (#x4E16 . #xC0A4) - (#x4E17 . #xD2C2) - (#x4E18 . #xB5D6) - (#x4E19 . #xCABA) - (#x4E1E . #xBEE7) - (#x4E1F . #x8FB0A6) - (#x4E21 . #xCEBE) - (#x4E23 . #x8FB0A7) - (#x4E24 . #x8FB0A8) - (#x4E26 . #xCAC2) - (#x4E28 . #x8FB0A9) - (#x4E2A . #xD0A4) - (#x4E2B . #x8FB0AA) - (#x4E2D . #xC3E6) - (#x4E2E . #x8FB0AB) - (#x4E2F . #x8FB0AC) - (#x4E30 . #x8FB0AD) - (#x4E31 . #xD0A5) - (#x4E32 . #xB6FA) - (#x4E35 . #x8FB0AE) - (#x4E36 . #xD0A6) - (#x4E38 . #xB4DD) - (#x4E39 . #xC3B0) - (#x4E3B . #xBCE7) - (#x4E3C . #xD0A7) - (#x4E3F . #xD0A8) - (#x4E40 . #x8FB0AF) - (#x4E41 . #x8FB0B0) - (#x4E42 . #xD0A9) - (#x4E43 . #xC7B5) - (#x4E44 . #x8FB0B1) - (#x4E45 . #xB5D7) - (#x4E47 . #x8FB0B2) - (#x4E4B . #xC7B7) - (#x4E4D . #xC6E3) - (#x4E4E . #xB8C3) - (#x4E4F . #xCBB3) - (#x4E51 . #x8FB0B3) - (#x4E55 . #xE9C9) - (#x4E56 . #xD0AA) - (#x4E57 . #xBEE8) - (#x4E58 . #xD0AB) - (#x4E59 . #xB2B5) - (#x4E5A . #x8FB0B4) - (#x4E5C . #x8FB0B5) - (#x4E5D . #xB6E5) - (#x4E5E . #xB8F0) - (#x4E5F . #xCCE9) - (#x4E62 . #xD6A6) - (#x4E63 . #x8FB0B6) - (#x4E68 . #x8FB0B7) - (#x4E69 . #x8FB0B8) - (#x4E71 . #xCDF0) - (#x4E73 . #xC6FD) - (#x4E74 . #x8FB0B9) - (#x4E75 . #x8FB0BA) - (#x4E79 . #x8FB0BB) - (#x4E7E . #xB4A5) - (#x4E7F . #x8FB0BC) - (#x4E80 . #xB5B5) - (#x4E82 . #xD0AC) - (#x4E85 . #xD0AD) - (#x4E86 . #xCEBB) - (#x4E88 . #xCDBD) - (#x4E89 . #xC1E8) - (#x4E8A . #xD0AF) - (#x4E8B . #xBBF6) - (#x4E8C . #xC6F3) - (#x4E8D . #x8FB0BD) - (#x4E8E . #xD0B2) - (#x4E91 . #xB1BE) - (#x4E92 . #xB8DF) - (#x4E94 . #xB8DE) - (#x4E95 . #xB0E6) - (#x4E96 . #x8FB0BE) - (#x4E97 . #x8FB0BF) - (#x4E98 . #xCFCB) - (#x4E99 . #xCFCA) - (#x4E9B . #xBAB3) - (#x4E9C . #xB0A1) - (#x4E9D . #x8FB0C0) - (#x4E9E . #xD0B3) - (#x4E9F . #xD0B4) - (#x4EA0 . #xD0B5) - (#x4EA1 . #xCBB4) - (#x4EA2 . #xD0B6) - (#x4EA4 . #xB8F2) - (#x4EA5 . #xB0E7) - (#x4EA6 . #xCBF2) - (#x4EA8 . #xB5FC) - (#x4EAB . #xB5FD) - (#x4EAC . #xB5FE) - (#x4EAD . #xC4E2) - (#x4EAE . #xCEBC) - (#x4EAF . #x8FB0C1) - (#x4EB0 . #xD0B7) - (#x4EB3 . #xD0B8) - (#x4EB6 . #xD0B9) - (#x4EB9 . #x8FB0C2) - (#x4EBA . #xBFCD) - (#x4EC0 . #xBDBA) - (#x4EC1 . #xBFCE) - (#x4EC2 . #xD0BE) - (#x4EC3 . #x8FB0C3) - (#x4EC4 . #xD0BC) - (#x4EC6 . #xD0BD) - (#x4EC7 . #xB5D8) - (#x4ECA . #xBAA3) - (#x4ECB . #xB2F0) - (#x4ECD . #xD0BB) - (#x4ECE . #xD0BA) - (#x4ECF . #xCAA9) - (#x4ED0 . #x8FB0C4) - (#x4ED4 . #xBBC6) - (#x4ED5 . #xBBC5) - (#x4ED6 . #xC2BE) - (#x4ED7 . #xD0BF) - (#x4ED8 . #xC9D5) - (#x4ED9 . #xC0E7) - (#x4EDA . #x8FB0C5) - (#x4EDB . #x8FB0C6) - (#x4EDD . #xA1B8) - (#x4EDE . #xD0C0) - (#x4EDF . #xD0C2) - (#x4EE0 . #x8FB0C7) - (#x4EE1 . #x8FB0C8) - (#x4EE2 . #x8FB0C9) - (#x4EE3 . #xC2E5) - (#x4EE4 . #xCEE1) - (#x4EE5 . #xB0CA) - (#x4EE8 . #x8FB0CA) - (#x4EED . #xD0C1) - (#x4EEE . #xB2BE) - (#x4EEF . #x8FB0CB) - (#x4EF0 . #xB6C4) - (#x4EF1 . #x8FB0CC) - (#x4EF2 . #xC3E7) - (#x4EF3 . #x8FB0CD) - (#x4EF5 . #x8FB0CE) - (#x4EF6 . #xB7EF) - (#x4EF7 . #xD0C3) - (#x4EFB . #xC7A4) - (#x4EFD . #x8FB0CF) - (#x4EFE . #x8FB0D0) - (#x4EFF . #x8FB0D1) - (#x4F00 . #x8FB0D2) - (#x4F01 . #xB4EB) - (#x4F02 . #x8FB0D3) - (#x4F03 . #x8FB0D4) - (#x4F08 . #x8FB0D5) - (#x4F09 . #xD0C4) - (#x4F0A . #xB0CB) - (#x4F0B . #x8FB0D6) - (#x4F0C . #x8FB0D7) - (#x4F0D . #xB8E0) - (#x4F0E . #xB4EC) - (#x4F0F . #xC9FA) - (#x4F10 . #xC8B2) - (#x4F11 . #xB5D9) - (#x4F12 . #x8FB0D8) - (#x4F15 . #x8FB0D9) - (#x4F16 . #x8FB0DA) - (#x4F17 . #x8FB0DB) - (#x4F19 . #x8FB0DC) - (#x4F1A . #xB2F1) - (#x4F1C . #xD0E7) - (#x4F1D . #xC5C1) - (#x4F2E . #x8FB0DD) - (#x4F2F . #xC7EC) - (#x4F30 . #xD0C6) - (#x4F31 . #x8FB0DE) - (#x4F33 . #x8FB0E0) - (#x4F34 . #xC8BC) - (#x4F35 . #x8FB0E1) - (#x4F36 . #xCEE2) - (#x4F37 . #x8FB0E2) - (#x4F38 . #xBFAD) - (#x4F39 . #x8FB0E3) - (#x4F3A . #xBBC7) - (#x4F3B . #x8FB0E4) - (#x4F3C . #xBBF7) - (#x4F3D . #xB2C0) - (#x4F3E . #x8FB0E5) - (#x4F40 . #x8FB0E6) - (#x4F42 . #x8FB0E7) - (#x4F43 . #xC4D1) - (#x4F46 . #xC3A2) - (#x4F47 . #xD0CA) - (#x4F48 . #x8FB0E8) - (#x4F49 . #x8FB0E9) - (#x4F4B . #x8FB0EA) - (#x4F4C . #x8FB0EB) - (#x4F4D . #xB0CC) - (#x4F4E . #xC4E3) - (#x4F4F . #xBDBB) - (#x4F50 . #xBAB4) - (#x4F51 . #xCDA4) - (#x4F52 . #x8FB0EC) - (#x4F53 . #xC2CE) - (#x4F54 . #x8FB0ED) - (#x4F55 . #xB2BF) - (#x4F56 . #x8FB0EE) - (#x4F57 . #xD0C9) - (#x4F58 . #x8FB0EF) - (#x4F59 . #xCDBE) - (#x4F5A . #xD0C5) - (#x4F5B . #xD0C7) - (#x4F5C . #xBAEE) - (#x4F5D . #xD0C8) - (#x4F5E . #xD5A4) - (#x4F5F . #x8FB0F0) - (#x4F60 . #x8FB0DF) - (#x4F63 . #x8FB0F1) - (#x4F69 . #xD0D0) - (#x4F6A . #x8FB0F2) - (#x4F6C . #x8FB0F3) - (#x4F6E . #x8FB0F4) - (#x4F6F . #xD0D3) - (#x4F70 . #xD0D1) - (#x4F71 . #x8FB0F5) - (#x4F73 . #xB2C2) - (#x4F75 . #xCABB) - (#x4F76 . #xD0CB) - (#x4F77 . #x8FB0F6) - (#x4F78 . #x8FB0F7) - (#x4F79 . #x8FB0F8) - (#x4F7A . #x8FB0F9) - (#x4F7B . #xD0CF) - (#x4F7C . #xB8F3) - (#x4F7D . #x8FB0FA) - (#x4F7E . #x8FB0FB) - (#x4F7F . #xBBC8) - (#x4F81 . #x8FB0FC) - (#x4F82 . #x8FB0FD) - (#x4F83 . #xB4A6) - (#x4F84 . #x8FB0FE) - (#x4F85 . #x8FB1A1) - (#x4F86 . #xD0D4) - (#x4F88 . #xD0CC) - (#x4F89 . #x8FB1A2) - (#x4F8A . #x8FB1A3) - (#x4F8B . #xCEE3) - (#x4F8C . #x8FB1A4) - (#x4F8D . #xBBF8) - (#x4F8E . #x8FB1A5) - (#x4F8F . #xD0CD) - (#x4F90 . #x8FB1A6) - (#x4F91 . #xD0D2) - (#x4F92 . #x8FB1A7) - (#x4F93 . #x8FB1A8) - (#x4F94 . #x8FB1A9) - (#x4F96 . #xD0D5) - (#x4F97 . #x8FB1AA) - (#x4F98 . #xD0CE) - (#x4F99 . #x8FB1AB) - (#x4F9A . #x8FB1AC) - (#x4F9B . #xB6A1) - (#x4F9D . #xB0CD) - (#x4F9E . #x8FB1AD) - (#x4F9F . #x8FB1AE) - (#x4FA0 . #xB6A2) - (#x4FA1 . #xB2C1) - (#x4FAB . #xD5A5) - (#x4FAD . #xCBF9) - (#x4FAE . #xC9EE) - (#x4FAF . #xB8F4) - (#x4FB2 . #x8FB1AF) - (#x4FB5 . #xBFAF) - (#x4FB6 . #xCEB7) - (#x4FB7 . #x8FB1B0) - (#x4FB9 . #x8FB1B1) - (#x4FBB . #x8FB1B2) - (#x4FBC . #x8FB1B3) - (#x4FBD . #x8FB1B4) - (#x4FBE . #x8FB1B5) - (#x4FBF . #xCAD8) - (#x4FC0 . #x8FB1B6) - (#x4FC1 . #x8FB1B7) - (#x4FC2 . #xB7B8) - (#x4FC3 . #xC2A5) - (#x4FC4 . #xB2E4) - (#x4FC5 . #x8FB1B8) - (#x4FC6 . #x8FB1B9) - (#x4FC8 . #x8FB1BA) - (#x4FC9 . #x8FB1BB) - (#x4FCA . #xBDD3) - (#x4FCB . #x8FB1BC) - (#x4FCC . #x8FB1BD) - (#x4FCD . #x8FB1BE) - (#x4FCE . #xD0D9) - (#x4FCF . #x8FB1BF) - (#x4FD0 . #xD0DE) - (#x4FD1 . #xD0DC) - (#x4FD2 . #x8FB1C0) - (#x4FD4 . #xD0D7) - (#x4FD7 . #xC2AF) - (#x4FD8 . #xD0DA) - (#x4FDA . #xD0DD) - (#x4FDB . #xD0DB) - (#x4FDC . #x8FB1C1) - (#x4FDD . #xCADD) - (#x4FDF . #xD0D8) - (#x4FE0 . #x8FB1C2) - (#x4FE1 . #xBFAE) - (#x4FE2 . #x8FB1C3) - (#x4FE3 . #xCBF3) - (#x4FE4 . #xD0DF) - (#x4FE5 . #xD0E0) - (#x4FEE . #xBDA4) - (#x4FEF . #xD0ED) - (#x4FF0 . #x8FB1C4) - (#x4FF2 . #x8FB1C5) - (#x4FF3 . #xC7D0) - (#x4FF5 . #xC9B6) - (#x4FF6 . #xD0E8) - (#x4FF8 . #xCAF0) - (#x4FFA . #xB2B6) - (#x4FFC . #x8FB1C6) - (#x4FFD . #x8FB1C7) - (#x4FFE . #xD0EC) - (#x4FFF . #x8FB1C8) - (#x5000 . #x8FB1C9) - (#x5001 . #x8FB1CA) - (#x5004 . #x8FB1CB) - (#x5005 . #xD0E6) - (#x5006 . #xD0EF) - (#x5007 . #x8FB1CC) - (#x5009 . #xC1D2) - (#x500A . #x8FB1CD) - (#x500B . #xB8C4) - (#x500C . #x8FB1CE) - (#x500D . #xC7DC) - (#x500E . #x8FB1CF) - (#x500F . #xE0C7) - (#x5010 . #x8FB1D0) - (#x5011 . #xD0EE) - (#x5012 . #xC5DD) - (#x5013 . #x8FB1D1) - (#x5014 . #xD0E3) - (#x5016 . #xB8F6) - (#x5017 . #x8FB1D2) - (#x5018 . #x8FB1D3) - (#x5019 . #xB8F5) - (#x501A . #xD0E1) - (#x501B . #x8FB1D4) - (#x501C . #x8FB1D5) - (#x501D . #x8FB1D6) - (#x501E . #x8FB1D7) - (#x501F . #xBCDA) - (#x5021 . #xD0E9) - (#x5022 . #x8FB1D8) - (#x5023 . #xCAEF) - (#x5024 . #xC3CD) - (#x5025 . #xD0E5) - (#x5026 . #xB7F1) - (#x5027 . #x8FB1D9) - (#x5028 . #xD0E2) - (#x5029 . #xD0EA) - (#x502A . #xD0E4) - (#x502B . #xCED1) - (#x502C . #xD0EB) - (#x502D . #xCFC1) - (#x502E . #x8FB1DA) - (#x5030 . #x8FB1DB) - (#x5032 . #x8FB1DC) - (#x5033 . #x8FB1DD) - (#x5035 . #x8FB1DE) - (#x5036 . #xB6E6) - (#x5039 . #xB7F0) - (#x503B . #x8FB1F6) - (#x5040 . #x8FB1DF) - (#x5041 . #x8FB1E0) - (#x5042 . #x8FB1E1) - (#x5043 . #xD0F0) - (#x5045 . #x8FB1E2) - (#x5046 . #x8FB1E3) - (#x5047 . #xD0F1) - (#x5048 . #xD0F5) - (#x5049 . #xB0CE) - (#x504A . #x8FB1E4) - (#x504C . #x8FB1E5) - (#x504E . #x8FB1E6) - (#x504F . #xCAD0) - (#x5050 . #xD0F4) - (#x5051 . #x8FB1E7) - (#x5052 . #x8FB1E8) - (#x5053 . #x8FB1E9) - (#x5055 . #xD0F3) - (#x5056 . #xD0F7) - (#x5057 . #x8FB1EA) - (#x5059 . #x8FB1EB) - (#x505A . #xD0F6) - (#x505C . #xC4E4) - (#x505F . #x8FB1EC) - (#x5060 . #x8FB1ED) - (#x5062 . #x8FB1EE) - (#x5063 . #x8FB1EF) - (#x5065 . #xB7F2) - (#x5066 . #x8FB1F0) - (#x5067 . #x8FB1F1) - (#x506A . #x8FB1F2) - (#x506C . #xD0F8) - (#x506D . #x8FB1F3) - (#x5070 . #x8FB1F4) - (#x5071 . #x8FB1F5) - (#x5072 . #xBCC5) - (#x5074 . #xC2A6) - (#x5075 . #xC4E5) - (#x5076 . #xB6F6) - (#x5078 . #xD0F9) - (#x507D . #xB5B6) - (#x5080 . #xD0FA) - (#x5081 . #x8FB1F7) - (#x5083 . #x8FB1F8) - (#x5084 . #x8FB1F9) - (#x5085 . #xD0FC) - (#x5086 . #x8FB1FA) - (#x508A . #x8FB1FB) - (#x508D . #xCBB5) - (#x508E . #x8FB1FC) - (#x508F . #x8FB1FD) - (#x5090 . #x8FB1FE) - (#x5091 . #xB7E6) - (#x5092 . #x8FB2A1) - (#x5093 . #x8FB2A2) - (#x5094 . #x8FB2A3) - (#x5096 . #x8FB2A4) - (#x5098 . #xBBB1) - (#x5099 . #xC8F7) - (#x509A . #xD0FB) - (#x509B . #x8FB2A5) - (#x509C . #x8FB2A6) - (#x509E . #x8FB2A7) - (#x509F . #x8FB2A8) - (#x50A0 . #x8FB2A9) - (#x50A1 . #x8FB2AA) - (#x50A2 . #x8FB2AB) - (#x50AA . #x8FB2AC) - (#x50AC . #xBAC5) - (#x50AD . #xCDC3) - (#x50AF . #x8FB2AD) - (#x50B0 . #x8FB2AE) - (#x50B2 . #xD0FE) - (#x50B3 . #xD1A3) - (#x50B4 . #xD0FD) - (#x50B5 . #xBAC4) - (#x50B7 . #xBDFD) - (#x50B9 . #x8FB2AF) - (#x50BA . #x8FB2B0) - (#x50BD . #x8FB2B1) - (#x50BE . #xB7B9) - (#x50C0 . #x8FB2B2) - (#x50C2 . #xD1A4) - (#x50C3 . #x8FB2B3) - (#x50C4 . #x8FB2B4) - (#x50C5 . #xB6CF) - (#x50C7 . #x8FB2B5) - (#x50C9 . #xD1A1) - (#x50CA . #xD1A2) - (#x50CC . #x8FB2B6) - (#x50CD . #xC6AF) - (#x50CE . #x8FB2B7) - (#x50CF . #xC1FC) - (#x50D0 . #x8FB2B8) - (#x50D1 . #xB6A3) - (#x50D3 . #x8FB2B9) - (#x50D4 . #x8FB2BA) - (#x50D5 . #xCBCD) - (#x50D6 . #xD1A5) - (#x50D8 . #x8FB2BB) - (#x50DA . #xCEBD) - (#x50DC . #x8FB2BC) - (#x50DD . #x8FB2BD) - (#x50DE . #xD1A6) - (#x50DF . #x8FB2BE) - (#x50E2 . #x8FB2BF) - (#x50E3 . #xD1A9) - (#x50E4 . #x8FB2C0) - (#x50E5 . #xD1A7) - (#x50E6 . #x8FB2C1) - (#x50E7 . #xC1CE) - (#x50E8 . #x8FB2C2) - (#x50E9 . #x8FB2C3) - (#x50ED . #xD1A8) - (#x50EE . #xD1AA) - (#x50EF . #x8FB2C4) - (#x50F1 . #x8FB2C5) - (#x50F2 . #x8FB2D1) - (#x50F5 . #xD1AC) - (#x50F6 . #x8FB2C6) - (#x50F9 . #xD1AB) - (#x50FA . #x8FB2C7) - (#x50FB . #xCAC8) - (#x50FE . #x8FB2C8) - (#x5100 . #xB5B7) - (#x5101 . #xD1AE) - (#x5102 . #xD1AF) - (#x5103 . #x8FB2C9) - (#x5104 . #xB2AF) - (#x5106 . #x8FB2CA) - (#x5107 . #x8FB2CB) - (#x5108 . #x8FB2CC) - (#x5109 . #xD1AD) - (#x510B . #x8FB2CD) - (#x510C . #x8FB2CE) - (#x510D . #x8FB2CF) - (#x510E . #x8FB2D0) - (#x5110 . #x8FB2D2) - (#x5112 . #xBCF4) - (#x5114 . #xD1B2) - (#x5115 . #xD1B1) - (#x5116 . #xD1B0) - (#x5117 . #x8FB2D3) - (#x5118 . #xD0D6) - (#x5119 . #x8FB2D4) - (#x511A . #xD1B3) - (#x511B . #x8FB2D5) - (#x511C . #x8FB2D6) - (#x511D . #x8FB2D7) - (#x511E . #x8FB2D8) - (#x511F . #xBDFE) - (#x5121 . #xD1B4) - (#x5123 . #x8FB2D9) - (#x5127 . #x8FB2DA) - (#x5128 . #x8FB2DB) - (#x512A . #xCDA5) - (#x512C . #x8FB2DC) - (#x512D . #x8FB2DD) - (#x512F . #x8FB2DE) - (#x5131 . #x8FB2DF) - (#x5132 . #xCCD9) - (#x5133 . #x8FB2E0) - (#x5134 . #x8FB2E1) - (#x5135 . #x8FB2E2) - (#x5137 . #xD1B6) - (#x5138 . #x8FB2E3) - (#x5139 . #x8FB2E4) - (#x513A . #xD1B5) - (#x513B . #xD1B8) - (#x513C . #xD1B7) - (#x513F . #xD1B9) - (#x5140 . #xD1BA) - (#x5141 . #xB0F4) - (#x5142 . #x8FB2E5) - (#x5143 . #xB8B5) - (#x5144 . #xB7BB) - (#x5145 . #xBDBC) - (#x5146 . #xC3FB) - (#x5147 . #xB6A4) - (#x5148 . #xC0E8) - (#x5149 . #xB8F7) - (#x514A . #x8FB2E6) - (#x514B . #xB9EE) - (#x514C . #xD1BC) - (#x514D . #xCCC8) - (#x514E . #xC5C6) - (#x514F . #x8FB2E7) - (#x5150 . #xBBF9) - (#x5152 . #xD1BB) - (#x5153 . #x8FB2E8) - (#x5154 . #xD1BD) - (#x5155 . #x8FB2E9) - (#x5157 . #x8FB2EA) - (#x5158 . #x8FB2EB) - (#x515A . #xC5DE) - (#x515C . #xB3F5) - (#x515F . #x8FB2EC) - (#x5162 . #xD1BE) - (#x5164 . #x8FB2ED) - (#x5165 . #xC6FE) - (#x5166 . #x8FB2EE) - (#x5168 . #xC1B4) - (#x5169 . #xD1C0) - (#x516A . #xD1C1) - (#x516B . #xC8AC) - (#x516C . #xB8F8) - (#x516D . #xCFBB) - (#x516E . #xD1C2) - (#x5171 . #xB6A6) - (#x5175 . #xCABC) - (#x5176 . #xC2B6) - (#x5177 . #xB6F1) - (#x5178 . #xC5B5) - (#x517C . #xB7F3) - (#x517E . #x8FB2EF) - (#x5180 . #xD1C3) - (#x5182 . #xD1C4) - (#x5183 . #x8FB2F0) - (#x5184 . #x8FB2F1) - (#x5185 . #xC6E2) - (#x5186 . #xB1DF) - (#x5189 . #xD1C7) - (#x518A . #xBAFD) - (#x518B . #x8FB2F2) - (#x518C . #xD1C6) - (#x518D . #xBAC6) - (#x518E . #x8FB2F3) - (#x518F . #xD1C8) - (#x5190 . #xE6EE) - (#x5191 . #xD1C9) - (#x5192 . #xCBC1) - (#x5193 . #xD1CA) - (#x5195 . #xD1CB) - (#x5196 . #xD1CC) - (#x5197 . #xBEE9) - (#x5198 . #x8FB2F4) - (#x5199 . #xBCCC) - (#x519D . #x8FB2F5) - (#x51A0 . #xB4A7) - (#x51A1 . #x8FB2F6) - (#x51A2 . #xD1CF) - (#x51A3 . #x8FB2F7) - (#x51A4 . #xD1CD) - (#x51A5 . #xCCBD) - (#x51A6 . #xD1CE) - (#x51A8 . #xC9DA) - (#x51A9 . #xD1D0) - (#x51AA . #xD1D1) - (#x51AB . #xD1D2) - (#x51AC . #xC5DF) - (#x51AD . #x8FB2F8) - (#x51B0 . #xD1D6) - (#x51B1 . #xD1D4) - (#x51B2 . #xD1D5) - (#x51B3 . #xD1D3) - (#x51B4 . #xBAE3) - (#x51B5 . #xD1D7) - (#x51B6 . #xCCEA) - (#x51B7 . #xCEE4) - (#x51B8 . #x8FB2F9) - (#x51BA . #x8FB2FA) - (#x51BC . #x8FB2FB) - (#x51BD . #xD1D8) - (#x51BE . #x8FB2FC) - (#x51BF . #x8FB2FD) - (#x51C2 . #x8FB2FE) - (#x51C4 . #xC0A8) - (#x51C5 . #xD1D9) - (#x51C6 . #xBDDA) - (#x51C8 . #x8FB3A1) - (#x51C9 . #xD1DA) - (#x51CB . #xC3FC) - (#x51CC . #xCEBF) - (#x51CD . #xC5E0) - (#x51CF . #x8FB3A2) - (#x51D1 . #x8FB3A3) - (#x51D2 . #x8FB3A4) - (#x51D3 . #x8FB3A5) - (#x51D5 . #x8FB3A6) - (#x51D6 . #xD2C5) - (#x51D8 . #x8FB3A7) - (#x51DB . #xD1DB) - (#x51DC . #xF4A5) - (#x51DD . #xB6C5) - (#x51DE . #x8FB3A8) - (#x51E0 . #xD1DC) - (#x51E1 . #xCBDE) - (#x51E2 . #x8FB3A9) - (#x51E5 . #x8FB3AA) - (#x51E6 . #xBDE8) - (#x51E7 . #xC2FC) - (#x51E9 . #xD1DE) - (#x51EA . #xC6E4) - (#x51ED . #xD1DF) - (#x51EE . #x8FB3AB) - (#x51F0 . #xD1E0) - (#x51F1 . #xB3AE) - (#x51F2 . #x8FB3AC) - (#x51F3 . #x8FB3AD) - (#x51F4 . #x8FB3AE) - (#x51F5 . #xD1E1) - (#x51F6 . #xB6A7) - (#x51F7 . #x8FB3AF) - (#x51F8 . #xC6CC) - (#x51F9 . #xB1FA) - (#x51FA . #xBDD0) - (#x51FD . #xC8A1) - (#x51FE . #xD1E2) - (#x5200 . #xC5E1) - (#x5201 . #x8FB3B0) - (#x5202 . #x8FB3B1) - (#x5203 . #xBFCF) - (#x5204 . #xD1E3) - (#x5205 . #x8FB3B2) - (#x5206 . #xCAAC) - (#x5207 . #xC0DA) - (#x5208 . #xB4A2) - (#x520A . #xB4A9) - (#x520B . #xD1E4) - (#x520E . #xD1E6) - (#x5211 . #xB7BA) - (#x5212 . #x8FB3B3) - (#x5213 . #x8FB3B4) - (#x5214 . #xD1E5) - (#x5215 . #x8FB3B5) - (#x5216 . #x8FB3B6) - (#x5217 . #xCEF3) - (#x5218 . #x8FB3B7) - (#x521D . #xBDE9) - (#x5222 . #x8FB3B8) - (#x5224 . #xC8BD) - (#x5225 . #xCACC) - (#x5227 . #xD1E7) - (#x5228 . #x8FB3B9) - (#x5229 . #xCDF8) - (#x522A . #xD1E8) - (#x522E . #xD1E9) - (#x5230 . #xC5FE) - (#x5231 . #x8FB3BA) - (#x5232 . #x8FB3BB) - (#x5233 . #xD1EA) - (#x5235 . #x8FB3BC) - (#x5236 . #xC0A9) - (#x5237 . #xBAFE) - (#x5238 . #xB7F4) - (#x5239 . #xD1EB) - (#x523A . #xBBC9) - (#x523B . #xB9EF) - (#x523C . #x8FB3BD) - (#x5243 . #xC4E6) - (#x5244 . #xD1ED) - (#x5245 . #x8FB3BE) - (#x5247 . #xC2A7) - (#x5249 . #x8FB3BF) - (#x524A . #xBAEF) - (#x524B . #xD1EE) - (#x524C . #xD1EF) - (#x524D . #xC1B0) - (#x524F . #xD1EC) - (#x5254 . #xD1F1) - (#x5255 . #x8FB3C0) - (#x5256 . #xCBB6) - (#x5257 . #x8FB3C1) - (#x5258 . #x8FB3C2) - (#x525A . #x8FB3C3) - (#x525B . #xB9E4) - (#x525C . #x8FB3C4) - (#x525E . #xD1F0) - (#x525F . #x8FB3C5) - (#x5260 . #x8FB3C6) - (#x5261 . #x8FB3C7) - (#x5263 . #xB7F5) - (#x5264 . #xBADE) - (#x5265 . #xC7ED) - (#x5266 . #x8FB3C8) - (#x5269 . #xD1F4) - (#x526A . #xD1F2) - (#x526E . #x8FB3C9) - (#x526F . #xC9FB) - (#x5270 . #xBEEA) - (#x5271 . #xD1FB) - (#x5272 . #xB3E4) - (#x5273 . #xD1F5) - (#x5274 . #xD1F3) - (#x5275 . #xC1CF) - (#x5277 . #x8FB3CA) - (#x5278 . #x8FB3CB) - (#x5279 . #x8FB3CC) - (#x527D . #xD1F7) - (#x527F . #xD1F6) - (#x5280 . #x8FB3CD) - (#x5282 . #x8FB3CE) - (#x5283 . #xB3C4) - (#x5285 . #x8FB3CF) - (#x5287 . #xB7E0) - (#x5288 . #xD1FC) - (#x5289 . #xCEAD) - (#x528A . #x8FB3D0) - (#x528C . #x8FB3D1) - (#x528D . #xD1F8) - (#x5291 . #xD1FD) - (#x5292 . #xD1FA) - (#x5293 . #x8FB3D2) - (#x5294 . #xD1F9) - (#x5295 . #x8FB3D3) - (#x5296 . #x8FB3D4) - (#x5297 . #x8FB3D5) - (#x5298 . #x8FB3D6) - (#x529A . #x8FB3D7) - (#x529B . #xCECF) - (#x529C . #x8FB3D8) - (#x529F . #xB8F9) - (#x52A0 . #xB2C3) - (#x52A3 . #xCEF4) - (#x52A4 . #x8FB3D9) - (#x52A5 . #x8FB3DA) - (#x52A6 . #x8FB3DB) - (#x52A7 . #x8FB3DC) - (#x52A9 . #xBDF5) - (#x52AA . #xC5D8) - (#x52AB . #xB9E5) - (#x52AC . #xD2A2) - (#x52AD . #xD2A3) - (#x52AF . #x8FB3DD) - (#x52B0 . #x8FB3DE) - (#x52B1 . #xCEE5) - (#x52B4 . #xCFAB) - (#x52B5 . #xD2A5) - (#x52B6 . #x8FB3DF) - (#x52B7 . #x8FB3E0) - (#x52B8 . #x8FB3E1) - (#x52B9 . #xB8FA) - (#x52BA . #x8FB3E2) - (#x52BB . #x8FB3E3) - (#x52BC . #xD2A4) - (#x52BD . #x8FB3E4) - (#x52BE . #xB3AF) - (#x52C0 . #x8FB3E5) - (#x52C1 . #xD2A6) - (#x52C3 . #xCBD6) - (#x52C4 . #x8FB3E6) - (#x52C5 . #xC4BC) - (#x52C6 . #x8FB3E7) - (#x52C7 . #xCDA6) - (#x52C8 . #x8FB3E8) - (#x52C9 . #xCAD9) - (#x52CC . #x8FB3E9) - (#x52CD . #xD2A7) - (#x52CF . #x8FB3EA) - (#x52D1 . #x8FB3EB) - (#x52D2 . #xF0D5) - (#x52D4 . #x8FB3EC) - (#x52D5 . #xC6B0) - (#x52D6 . #x8FB3ED) - (#x52D7 . #xD2A8) - (#x52D8 . #xB4AA) - (#x52D9 . #xCCB3) - (#x52DB . #x8FB3EE) - (#x52DC . #x8FB3EF) - (#x52DD . #xBEA1) - (#x52DE . #xD2A9) - (#x52DF . #xCAE7) - (#x52E0 . #xD2AD) - (#x52E1 . #x8FB3F0) - (#x52E2 . #xC0AA) - (#x52E3 . #xD2AA) - (#x52E4 . #xB6D0) - (#x52E5 . #x8FB3F1) - (#x52E6 . #xD2AB) - (#x52E7 . #xB4AB) - (#x52E8 . #x8FB3F2) - (#x52E9 . #x8FB3F3) - (#x52EA . #x8FB3F4) - (#x52EC . #x8FB3F5) - (#x52F0 . #x8FB3F6) - (#x52F1 . #x8FB3F7) - (#x52F2 . #xB7AE) - (#x52F3 . #xD2AE) - (#x52F4 . #x8FB3F8) - (#x52F5 . #xD2AF) - (#x52F6 . #x8FB3F9) - (#x52F7 . #x8FB3FA) - (#x52F8 . #xD2B0) - (#x52F9 . #xD2B1) - (#x52FA . #xBCDB) - (#x52FE . #xB8FB) - (#x52FF . #xCCDE) - (#x5300 . #x8FB3FB) - (#x5301 . #xCCE8) - (#x5302 . #xC6F7) - (#x5303 . #x8FB3FC) - (#x5305 . #xCAF1) - (#x5306 . #xD2B2) - (#x5308 . #xD2B3) - (#x530A . #x8FB3FD) - (#x530B . #x8FB3FE) - (#x530C . #x8FB4A1) - (#x530D . #xD2B5) - (#x530F . #xD2B7) - (#x5310 . #xD2B6) - (#x5311 . #x8FB4A2) - (#x5313 . #x8FB4A3) - (#x5315 . #xD2B8) - (#x5316 . #xB2BD) - (#x5317 . #xCBCC) - (#x5318 . #x8FB4A4) - (#x5319 . #xBAFC) - (#x531A . #xD2B9) - (#x531B . #x8FB4A5) - (#x531C . #x8FB4A6) - (#x531D . #xC1D9) - (#x531E . #x8FB4A7) - (#x531F . #x8FB4A8) - (#x5320 . #xBEA2) - (#x5321 . #xB6A9) - (#x5323 . #xD2BA) - (#x5325 . #x8FB4A9) - (#x5327 . #x8FB4AA) - (#x5328 . #x8FB4AB) - (#x5329 . #x8FB4AC) - (#x532A . #xC8DB) - (#x532B . #x8FB4AD) - (#x532C . #x8FB4AE) - (#x532D . #x8FB4AF) - (#x532F . #xD2BB) - (#x5330 . #x8FB4B0) - (#x5331 . #xD2BC) - (#x5332 . #x8FB4B1) - (#x5333 . #xD2BD) - (#x5335 . #x8FB4B2) - (#x5338 . #xD2BE) - (#x5339 . #xC9A4) - (#x533A . #xB6E8) - (#x533B . #xB0E5) - (#x533C . #x8FB4B3) - (#x533D . #x8FB4B4) - (#x533E . #x8FB4B5) - (#x533F . #xC6BF) - (#x5340 . #xD2BF) - (#x5341 . #xBDBD) - (#x5342 . #x8FB4B6) - (#x5343 . #xC0E9) - (#x5345 . #xD2C1) - (#x5346 . #xD2C0) - (#x5347 . #xBEA3) - (#x5348 . #xB8E1) - (#x5349 . #xD2C3) - (#x534A . #xC8BE) - (#x534B . #x8FB4B8) - (#x534C . #x8FB4B7) - (#x534D . #xD2C4) - (#x5351 . #xC8DC) - (#x5352 . #xC2B4) - (#x5353 . #xC2EE) - (#x5354 . #xB6A8) - (#x5357 . #xC6EE) - (#x5358 . #xC3B1) - (#x5359 . #x8FB4B9) - (#x535A . #xC7EE) - (#x535B . #x8FB4BA) - (#x535C . #xCBCE) - (#x535E . #xD2C6) - (#x5360 . #xC0EA) - (#x5361 . #x8FB4BB) - (#x5363 . #x8FB4BC) - (#x5365 . #x8FB4BD) - (#x5366 . #xB7B5) - (#x5369 . #xD2C7) - (#x536C . #x8FB4BE) - (#x536D . #x8FB4BF) - (#x536E . #xD2C8) - (#x536F . #xB1AC) - (#x5370 . #xB0F5) - (#x5371 . #xB4ED) - (#x5372 . #x8FB4C0) - (#x5373 . #xC2A8) - (#x5374 . #xB5D1) - (#x5375 . #xCDF1) - (#x5377 . #xD2CB) - (#x5378 . #xB2B7) - (#x5379 . #x8FB4C1) - (#x537B . #xD2CA) - (#x537E . #x8FB4C2) - (#x537F . #xB6AA) - (#x5382 . #xD2CC) - (#x5383 . #x8FB4C3) - (#x5384 . #xCCF1) - (#x5387 . #x8FB4C4) - (#x5388 . #x8FB4C5) - (#x538E . #x8FB4C6) - (#x5393 . #x8FB4C7) - (#x5394 . #x8FB4C8) - (#x5396 . #xD2CD) - (#x5398 . #xCED2) - (#x5399 . #x8FB4C9) - (#x539A . #xB8FC) - (#x539D . #x8FB4CA) - (#x539F . #xB8B6) - (#x53A0 . #xD2CE) - (#x53A1 . #x8FB4CB) - (#x53A4 . #x8FB4CC) - (#x53A5 . #xD2D0) - (#x53A6 . #xD2CF) - (#x53A8 . #xBFDF) - (#x53A9 . #xB1B9) - (#x53AA . #x8FB4CD) - (#x53AB . #x8FB4CE) - (#x53AD . #xB1DE) - (#x53AE . #xD2D1) - (#x53AF . #x8FB4CF) - (#x53B0 . #xD2D2) - (#x53B2 . #x8FB4D0) - (#x53B3 . #xB8B7) - (#x53B4 . #x8FB4D1) - (#x53B5 . #x8FB4D2) - (#x53B6 . #xD2D3) - (#x53B7 . #x8FB4D3) - (#x53B8 . #x8FB4D4) - (#x53BA . #x8FB4D5) - (#x53BB . #xB5EE) - (#x53BD . #x8FB4D6) - (#x53C0 . #x8FB4D7) - (#x53C2 . #xBBB2) - (#x53C3 . #xD2D4) - (#x53C5 . #x8FB4D8) - (#x53C8 . #xCBF4) - (#x53C9 . #xBAB5) - (#x53CA . #xB5DA) - (#x53CB . #xCDA7) - (#x53CC . #xC1D0) - (#x53CD . #xC8BF) - (#x53CE . #xBCFD) - (#x53CF . #x8FB4D9) - (#x53D2 . #x8FB4DA) - (#x53D3 . #x8FB4DB) - (#x53D4 . #xBDC7) - (#x53D5 . #x8FB4DC) - (#x53D6 . #xBCE8) - (#x53D7 . #xBCF5) - (#x53D9 . #xBDF6) - (#x53DA . #x8FB4DD) - (#x53DB . #xC8C0) - (#x53DD . #x8FB4DE) - (#x53DE . #x8FB4DF) - (#x53DF . #xD2D7) - (#x53E0 . #x8FB4E0) - (#x53E1 . #xB1C3) - (#x53E2 . #xC1D1) - (#x53E3 . #xB8FD) - (#x53E4 . #xB8C5) - (#x53E5 . #xB6E7) - (#x53E6 . #x8FB4E1) - (#x53E7 . #x8FB4E2) - (#x53E8 . #xD2DB) - (#x53E9 . #xC3A1) - (#x53EA . #xC2FE) - (#x53EB . #xB6AB) - (#x53EC . #xBEA4) - (#x53ED . #xD2DC) - (#x53EE . #xD2DA) - (#x53EF . #xB2C4) - (#x53F0 . #xC2E6) - (#x53F1 . #xBCB8) - (#x53F2 . #xBBCB) - (#x53F3 . #xB1A6) - (#x53F5 . #x8FB4E3) - (#x53F6 . #xB3F0) - (#x53F7 . #xB9E6) - (#x53F8 . #xBBCA) - (#x53FA . #xD2DD) - (#x5401 . #xD2DE) - (#x5402 . #x8FB4E4) - (#x5403 . #xB5C9) - (#x5404 . #xB3C6) - (#x5408 . #xB9E7) - (#x5409 . #xB5C8) - (#x540A . #xC4DF) - (#x540B . #xB1A5) - (#x540C . #xC6B1) - (#x540D . #xCCBE) - (#x540E . #xB9A1) - (#x540F . #xCDF9) - (#x5410 . #xC5C7) - (#x5411 . #xB8FE) - (#x5413 . #x8FB4E5) - (#x541A . #x8FB4E6) - (#x541B . #xB7AF) - (#x541D . #xD2E7) - (#x541F . #xB6E3) - (#x5420 . #xCBCA) - (#x5421 . #x8FB4E7) - (#x5426 . #xC8DD) - (#x5427 . #x8FB4E8) - (#x5428 . #x8FB4E9) - (#x5429 . #xD2E6) - (#x542A . #x8FB4EA) - (#x542B . #xB4DE) - (#x542C . #xD2E1) - (#x542D . #xD2E2) - (#x542E . #xD2E4) - (#x542F . #x8FB4EB) - (#x5431 . #x8FB4EC) - (#x5434 . #x8FB4ED) - (#x5435 . #x8FB4EE) - (#x5436 . #xD2E5) - (#x5438 . #xB5DB) - (#x5439 . #xBFE1) - (#x543B . #xCAAD) - (#x543C . #xD2E3) - (#x543D . #xD2DF) - (#x543E . #xB8E3) - (#x5440 . #xD2E0) - (#x5442 . #xCFA4) - (#x5443 . #x8FB4EF) - (#x5444 . #x8FB4F0) - (#x5446 . #xCAF2) - (#x5447 . #x8FB4F1) - (#x5448 . #xC4E8) - (#x5449 . #xB8E2) - (#x544A . #xB9F0) - (#x544D . #x8FB4F2) - (#x544E . #xD2E8) - (#x544F . #x8FB4F3) - (#x5451 . #xC6DD) - (#x545E . #x8FB4F4) - (#x545F . #xD2EC) - (#x5462 . #x8FB4F5) - (#x5464 . #x8FB4F6) - (#x5466 . #x8FB4F7) - (#x5467 . #x8FB4F8) - (#x5468 . #xBCFE) - (#x5469 . #x8FB4F9) - (#x546A . #xBCF6) - (#x546B . #x8FB4FA) - (#x546D . #x8FB4FB) - (#x546E . #x8FB4FC) - (#x5470 . #xD2EF) - (#x5471 . #xD2ED) - (#x5473 . #xCCA3) - (#x5474 . #x8FB4FD) - (#x5475 . #xD2EA) - (#x5476 . #xD2F3) - (#x5477 . #xD2EE) - (#x547B . #xD2F1) - (#x547C . #xB8C6) - (#x547D . #xCCBF) - (#x547F . #x8FB4FE) - (#x5480 . #xD2F2) - (#x5481 . #x8FB5A1) - (#x5483 . #x8FB5A2) - (#x5484 . #xD2F4) - (#x5485 . #x8FB5A3) - (#x5486 . #xD2F6) - (#x5488 . #x8FB5A4) - (#x5489 . #x8FB5A5) - (#x548B . #xBAF0) - (#x548C . #xCFC2) - (#x548D . #x8FB5A6) - (#x548E . #xD2EB) - (#x548F . #xD2E9) - (#x5490 . #xD2F5) - (#x5491 . #x8FB5A7) - (#x5492 . #xD2F0) - (#x5495 . #x8FB5A8) - (#x5496 . #x8FB5A9) - (#x549C . #x8FB5AA) - (#x549F . #x8FB5AB) - (#x54A1 . #x8FB5AC) - (#x54A2 . #xD2F8) - (#x54A4 . #xD3A3) - (#x54A5 . #xD2FA) - (#x54A6 . #x8FB5AD) - (#x54A7 . #x8FB5AE) - (#x54A8 . #xD2FE) - (#x54A9 . #x8FB5AF) - (#x54AA . #x8FB5B0) - (#x54AB . #xD3A1) - (#x54AC . #xD2FB) - (#x54AD . #x8FB5B1) - (#x54AE . #x8FB5B2) - (#x54AF . #xD3BE) - (#x54B1 . #x8FB5B3) - (#x54B2 . #xBAE9) - (#x54B3 . #xB3B1) - (#x54B7 . #x8FB5B4) - (#x54B8 . #xD2F9) - (#x54B9 . #x8FB5B5) - (#x54BA . #x8FB5B6) - (#x54BB . #x8FB5B7) - (#x54BC . #xD3A5) - (#x54BD . #xB0F6) - (#x54BE . #xD3A4) - (#x54BF . #x8FB5B8) - (#x54C0 . #xB0A5) - (#x54C1 . #xC9CA) - (#x54C2 . #xD3A2) - (#x54C4 . #xD2FC) - (#x54C6 . #x8FB5B9) - (#x54C7 . #xD2F7) - (#x54C8 . #xD2FD) - (#x54C9 . #xBAC8) - (#x54CA . #x8FB5BA) - (#x54CD . #x8FB5BB) - (#x54CE . #x8FB5BC) - (#x54D8 . #xD3A6) - (#x54E0 . #x8FB5BD) - (#x54E1 . #xB0F7) - (#x54E2 . #xD3AF) - (#x54E5 . #xD3A7) - (#x54E6 . #xD3A8) - (#x54E8 . #xBEA5) - (#x54E9 . #xCBE9) - (#x54EA . #x8FB5BE) - (#x54EC . #x8FB5BF) - (#x54ED . #xD3AD) - (#x54EE . #xD3AC) - (#x54EF . #x8FB5C0) - (#x54F2 . #xC5AF) - (#x54F6 . #x8FB5C1) - (#x54FA . #xD3AE) - (#x54FC . #x8FB5C2) - (#x54FD . #xD3AB) - (#x54FE . #x8FB5C3) - (#x54FF . #x8FB5C4) - (#x5500 . #x8FB5C5) - (#x5501 . #x8FB5C6) - (#x5504 . #xB1B4) - (#x5505 . #x8FB5C7) - (#x5506 . #xBAB6) - (#x5507 . #xBFB0) - (#x5508 . #x8FB5C8) - (#x5509 . #x8FB5C9) - (#x550C . #x8FB5CA) - (#x550D . #x8FB5CB) - (#x550E . #x8FB5CC) - (#x550F . #xD3A9) - (#x5510 . #xC5E2) - (#x5514 . #xD3AA) - (#x5515 . #x8FB5CD) - (#x5516 . #xB0A2) - (#x552A . #x8FB5CE) - (#x552B . #x8FB5CF) - (#x552E . #xD3B4) - (#x552F . #xCDA3) - (#x5531 . #xBEA7) - (#x5532 . #x8FB5D0) - (#x5533 . #xD3BA) - (#x5535 . #x8FB5D1) - (#x5536 . #x8FB5D2) - (#x5538 . #xD3B9) - (#x5539 . #xD3B0) - (#x553B . #x8FB5D3) - (#x553C . #x8FB5D4) - (#x553D . #x8FB5D5) - (#x553E . #xC2C3) - (#x5540 . #xD3B1) - (#x5541 . #x8FB5D6) - (#x5544 . #xC2EF) - (#x5545 . #xD3B6) - (#x5546 . #xBEA6) - (#x5547 . #x8FB5D7) - (#x5549 . #x8FB5D8) - (#x554A . #x8FB5D9) - (#x554C . #xD3B3) - (#x554D . #x8FB5DA) - (#x554F . #xCCE4) - (#x5550 . #x8FB5DB) - (#x5551 . #x8FB5DC) - (#x5553 . #xB7BC) - (#x5556 . #xD3B7) - (#x5557 . #xD3B8) - (#x5558 . #x8FB5DD) - (#x555A . #x8FB5DE) - (#x555B . #x8FB5DF) - (#x555C . #xD3B5) - (#x555D . #xD3BB) - (#x555E . #x8FB5E0) - (#x5560 . #x8FB5E1) - (#x5561 . #x8FB5E2) - (#x5563 . #xD3B2) - (#x5564 . #x8FB5E3) - (#x5566 . #x8FB5E4) - (#x557B . #xD3C1) - (#x557C . #xD3C6) - (#x557E . #xD3C2) - (#x557F . #x8FB5E5) - (#x5580 . #xD3BD) - (#x5581 . #x8FB5E6) - (#x5582 . #x8FB5E7) - (#x5583 . #xD3C7) - (#x5584 . #xC1B1) - (#x5586 . #x8FB5E8) - (#x5587 . #xD3C9) - (#x5588 . #x8FB5E9) - (#x5589 . #xB9A2) - (#x558A . #xD3BF) - (#x558B . #xC3FD) - (#x558E . #x8FB5EA) - (#x558F . #x8FB5EB) - (#x5591 . #x8FB5EC) - (#x5592 . #x8FB5ED) - (#x5593 . #x8FB5EE) - (#x5594 . #x8FB5EF) - (#x5597 . #x8FB5F0) - (#x5598 . #xD3C3) - (#x5599 . #xD3BC) - (#x559A . #xB4AD) - (#x559C . #xB4EE) - (#x559D . #xB3E5) - (#x559E . #xD3C4) - (#x559F . #xD3C0) - (#x55A3 . #x8FB5F1) - (#x55A4 . #x8FB5F2) - (#x55A7 . #xB7F6) - (#x55A8 . #xD3CA) - (#x55A9 . #xD3C8) - (#x55AA . #xC1D3) - (#x55AB . #xB5CA) - (#x55AC . #xB6AC) - (#x55AD . #x8FB5F3) - (#x55AE . #xD3C5) - (#x55B0 . #xB6F4) - (#x55B2 . #x8FB5F4) - (#x55B6 . #xB1C4) - (#x55BF . #x8FB5F5) - (#x55C1 . #x8FB5F6) - (#x55C3 . #x8FB5F7) - (#x55C4 . #xD3CE) - (#x55C5 . #xD3CC) - (#x55C6 . #x8FB5F8) - (#x55C7 . #xD4A7) - (#x55C9 . #x8FB5F9) - (#x55CB . #x8FB5FA) - (#x55CC . #x8FB5FB) - (#x55CE . #x8FB5FC) - (#x55D1 . #x8FB5FD) - (#x55D2 . #x8FB5FE) - (#x55D3 . #x8FB6A1) - (#x55D4 . #xD3D1) - (#x55D7 . #x8FB6A2) - (#x55D8 . #x8FB6A3) - (#x55DA . #xD3CB) - (#x55DB . #x8FB6A4) - (#x55DC . #xD3CF) - (#x55DE . #x8FB6A5) - (#x55DF . #xD3CD) - (#x55E2 . #x8FB6A6) - (#x55E3 . #xBBCC) - (#x55E4 . #xD3D0) - (#x55E9 . #x8FB6A7) - (#x55F6 . #x8FB6A8) - (#x55F7 . #xD3D3) - (#x55F9 . #xD3D8) - (#x55FD . #xD3D6) - (#x55FE . #xD3D5) - (#x55FF . #x8FB6A9) - (#x5605 . #x8FB6AA) - (#x5606 . #xC3B2) - (#x5608 . #x8FB6AB) - (#x5609 . #xB2C5) - (#x560A . #x8FB6AC) - (#x560D . #x8FB6AD) - (#x560E . #x8FB6AE) - (#x560F . #x8FB6AF) - (#x5610 . #x8FB6B0) - (#x5611 . #x8FB6B1) - (#x5612 . #x8FB6B2) - (#x5614 . #xD3D2) - (#x5616 . #xD3D4) - (#x5617 . #xBEA8) - (#x5618 . #xB1B3) - (#x5619 . #x8FB6B3) - (#x561B . #xD3D7) - (#x5629 . #xB2DE) - (#x562C . #x8FB6B4) - (#x562F . #xD3E2) - (#x5630 . #x8FB6B5) - (#x5631 . #xBEFC) - (#x5632 . #xD3DE) - (#x5633 . #x8FB6B6) - (#x5634 . #xD3DC) - (#x5635 . #x8FB6B7) - (#x5636 . #xD3DD) - (#x5637 . #x8FB6B8) - (#x5638 . #xD3DF) - (#x5639 . #x8FB6B9) - (#x563B . #x8FB6BA) - (#x563C . #x8FB6BB) - (#x563D . #x8FB6BC) - (#x563F . #x8FB6BD) - (#x5640 . #x8FB6BE) - (#x5641 . #x8FB6BF) - (#x5642 . #xB1BD) - (#x5643 . #x8FB6C0) - (#x5644 . #x8FB6C1) - (#x5646 . #x8FB6C2) - (#x5649 . #x8FB6C3) - (#x564B . #x8FB6C4) - (#x564C . #xC1B9) - (#x564D . #x8FB6C5) - (#x564E . #xD3D9) - (#x564F . #x8FB6C6) - (#x5650 . #xD3DA) - (#x5654 . #x8FB6C7) - (#x565B . #xB3FA) - (#x565E . #x8FB6C8) - (#x5660 . #x8FB6C9) - (#x5661 . #x8FB6CA) - (#x5662 . #x8FB6CB) - (#x5663 . #x8FB6CC) - (#x5664 . #xD3E1) - (#x5666 . #x8FB6CD) - (#x5668 . #xB4EF) - (#x5669 . #x8FB6CE) - (#x566A . #xD3E4) - (#x566B . #xD3E0) - (#x566C . #xD3E3) - (#x566D . #x8FB6CF) - (#x566F . #x8FB6D0) - (#x5671 . #x8FB6D1) - (#x5672 . #x8FB6D2) - (#x5674 . #xCAAE) - (#x5675 . #x8FB6D3) - (#x5678 . #xC6D5) - (#x567A . #xC8B8) - (#x5680 . #xD3E6) - (#x5684 . #x8FB6D4) - (#x5685 . #x8FB6D5) - (#x5686 . #xD3E5) - (#x5687 . #xB3C5) - (#x5688 . #x8FB6D6) - (#x568A . #xD3E7) - (#x568B . #x8FB6D7) - (#x568C . #x8FB6D8) - (#x568F . #xD3EA) - (#x5694 . #xD3E9) - (#x5695 . #x8FB6D9) - (#x5699 . #x8FB6DA) - (#x569A . #x8FB6DB) - (#x569D . #x8FB6DC) - (#x569E . #x8FB6DD) - (#x569F . #x8FB6DE) - (#x56A0 . #xD3E8) - (#x56A2 . #xC7B9) - (#x56A5 . #xD3EB) - (#x56A6 . #x8FB6DF) - (#x56A7 . #x8FB6E0) - (#x56A8 . #x8FB6E1) - (#x56A9 . #x8FB6E2) - (#x56AB . #x8FB6E3) - (#x56AC . #x8FB6E4) - (#x56AD . #x8FB6E5) - (#x56AE . #xD3EC) - (#x56B1 . #x8FB6E6) - (#x56B3 . #x8FB6E7) - (#x56B4 . #xD3EE) - (#x56B6 . #xD3ED) - (#x56B7 . #x8FB6E8) - (#x56BC . #xD3F0) - (#x56BE . #x8FB6E9) - (#x56C0 . #xD3F3) - (#x56C1 . #xD3F1) - (#x56C2 . #xD3EF) - (#x56C3 . #xD3F2) - (#x56C5 . #x8FB6EA) - (#x56C8 . #xD3F4) - (#x56C9 . #x8FB6EB) - (#x56CA . #x8FB6EC) - (#x56CB . #x8FB6ED) - (#x56CC . #x8FB6F0) - (#x56CD . #x8FB6F1) - (#x56CE . #xD3F5) - (#x56CF . #x8FB6EE) - (#x56D0 . #x8FB6EF) - (#x56D1 . #xD3F6) - (#x56D3 . #xD3F7) - (#x56D7 . #xD3F8) - (#x56D8 . #xD1C5) - (#x56D9 . #x8FB6F2) - (#x56DA . #xBCFC) - (#x56DB . #xBBCD) - (#x56DC . #x8FB6F3) - (#x56DD . #x8FB6F4) - (#x56DE . #xB2F3) - (#x56DF . #x8FB6F5) - (#x56E0 . #xB0F8) - (#x56E1 . #x8FB6F6) - (#x56E3 . #xC3C4) - (#x56E4 . #x8FB6F7) - (#x56E5 . #x8FB6F8) - (#x56E6 . #x8FB6F9) - (#x56E7 . #x8FB6FA) - (#x56E8 . #x8FB6FB) - (#x56EB . #x8FB6FD) - (#x56ED . #x8FB6FE) - (#x56EE . #xD3F9) - (#x56F0 . #xBAA4) - (#x56F1 . #x8FB6FC) - (#x56F2 . #xB0CF) - (#x56F3 . #xBFDE) - (#x56F6 . #x8FB7A1) - (#x56F7 . #x8FB7A2) - (#x56F9 . #xD3FA) - (#x56FA . #xB8C7) - (#x56FD . #xB9F1) - (#x56FF . #xD3FC) - (#x5700 . #xD3FB) - (#x5701 . #x8FB7A3) - (#x5702 . #x8FB7A4) - (#x5703 . #xCAE0) - (#x5704 . #xD3FD) - (#x5707 . #x8FB7A5) - (#x5708 . #xD4A1) - (#x5709 . #xD3FE) - (#x570A . #x8FB7A6) - (#x570B . #xD4A2) - (#x570C . #x8FB7A7) - (#x570D . #xD4A3) - (#x570F . #xB7F7) - (#x5711 . #x8FB7A8) - (#x5712 . #xB1E0) - (#x5713 . #xD4A4) - (#x5715 . #x8FB7A9) - (#x5716 . #xD4A6) - (#x5718 . #xD4A5) - (#x571A . #x8FB7AA) - (#x571B . #x8FB7AB) - (#x571C . #xD4A8) - (#x571D . #x8FB7AC) - (#x571F . #xC5DA) - (#x5720 . #x8FB7AD) - (#x5722 . #x8FB7AE) - (#x5723 . #x8FB7AF) - (#x5724 . #x8FB7B0) - (#x5725 . #x8FB7B1) - (#x5726 . #xD4A9) - (#x5727 . #xB0B5) - (#x5728 . #xBADF) - (#x5729 . #x8FB7B2) - (#x572A . #x8FB7B3) - (#x572C . #x8FB7B4) - (#x572D . #xB7BD) - (#x572E . #x8FB7B5) - (#x572F . #x8FB7B6) - (#x5730 . #xC3CF) - (#x5733 . #x8FB7B7) - (#x5734 . #x8FB7B8) - (#x5737 . #xD4AA) - (#x5738 . #xD4AB) - (#x573B . #xD4AD) - (#x573D . #x8FB7B9) - (#x573E . #x8FB7BA) - (#x573F . #x8FB7BB) - (#x5740 . #xD4AE) - (#x5742 . #xBAE4) - (#x5745 . #x8FB7BC) - (#x5746 . #x8FB7BD) - (#x5747 . #xB6D1) - (#x574A . #xCBB7) - (#x574C . #x8FB7BE) - (#x574D . #x8FB7BF) - (#x574E . #xD4AC) - (#x574F . #xD4AF) - (#x5750 . #xBAC1) - (#x5751 . #xB9A3) - (#x5752 . #x8FB7C0) - (#x5761 . #xD4B3) - (#x5762 . #x8FB7C1) - (#x5764 . #xBAA5) - (#x5765 . #x8FB7C2) - (#x5766 . #xC3B3) - (#x5767 . #x8FB7C3) - (#x5768 . #x8FB7C4) - (#x5769 . #xD4B0) - (#x576A . #xC4DA) - (#x576B . #x8FB7C5) - (#x576D . #x8FB7C6) - (#x576E . #x8FB7C7) - (#x576F . #x8FB7C8) - (#x5770 . #x8FB7C9) - (#x5771 . #x8FB7CA) - (#x5773 . #x8FB7CB) - (#x5774 . #x8FB7CC) - (#x5775 . #x8FB7CD) - (#x5777 . #x8FB7CE) - (#x5779 . #x8FB7CF) - (#x577A . #x8FB7D0) - (#x577B . #x8FB7D1) - (#x577C . #x8FB7D2) - (#x577E . #x8FB7D3) - (#x577F . #xD4B4) - (#x5781 . #x8FB7D4) - (#x5782 . #xBFE2) - (#x5783 . #x8FB7D5) - (#x5788 . #xD4B2) - (#x5789 . #xD4B5) - (#x578B . #xB7BF) - (#x578C . #x8FB7D6) - (#x5793 . #xD4B6) - (#x5794 . #x8FB7D7) - (#x5795 . #x8FB7E0) - (#x5797 . #x8FB7D8) - (#x5799 . #x8FB7D9) - (#x579A . #x8FB7DA) - (#x579C . #x8FB7DB) - (#x579D . #x8FB7DC) - (#x579E . #x8FB7DD) - (#x579F . #x8FB7DE) - (#x57A0 . #xD4B7) - (#x57A1 . #x8FB7DF) - (#x57A2 . #xB9A4) - (#x57A3 . #xB3C0) - (#x57A4 . #xD4B9) - (#x57A7 . #x8FB7E1) - (#x57A8 . #x8FB7E2) - (#x57A9 . #x8FB7E3) - (#x57AA . #xD4BA) - (#x57AC . #x8FB7E4) - (#x57B0 . #xD4BB) - (#x57B3 . #xD4B8) - (#x57B8 . #x8FB7E5) - (#x57BD . #x8FB7E6) - (#x57C0 . #xD4B1) - (#x57C3 . #xD4BC) - (#x57C6 . #xD4BD) - (#x57C7 . #x8FB7E7) - (#x57C8 . #x8FB7E8) - (#x57CB . #xCBE4) - (#x57CC . #x8FB7E9) - (#x57CE . #xBEEB) - (#x57CF . #x8FB7EA) - (#x57D2 . #xD4BF) - (#x57D3 . #xD4C0) - (#x57D4 . #xD4BE) - (#x57D5 . #x8FB7EB) - (#x57D6 . #xD4C2) - (#x57DC . #xC7B8) - (#x57DD . #x8FB7EC) - (#x57DE . #x8FB7ED) - (#x57DF . #xB0E8) - (#x57E0 . #xC9D6) - (#x57E1 . #x8FB7FE) - (#x57E3 . #xD4C3) - (#x57E4 . #x8FB7EE) - (#x57E6 . #x8FB7EF) - (#x57E7 . #x8FB7F0) - (#x57E9 . #x8FB7F1) - (#x57ED . #x8FB7F2) - (#x57F0 . #x8FB7F3) - (#x57F4 . #xBEFD) - (#x57F5 . #x8FB7F4) - (#x57F6 . #x8FB7F5) - (#x57F7 . #xBCB9) - (#x57F8 . #x8FB7F6) - (#x57F9 . #xC7DD) - (#x57FA . #xB4F0) - (#x57FC . #xBAEB) - (#x57FD . #x8FB7F7) - (#x57FE . #x8FB7F8) - (#x57FF . #x8FB7F9) - (#x5800 . #xCBD9) - (#x5802 . #xC6B2) - (#x5803 . #x8FB7FA) - (#x5804 . #x8FB7FB) - (#x5805 . #xB7F8) - (#x5806 . #xC2CF) - (#x5808 . #x8FB7FC) - (#x5809 . #x8FB7FD) - (#x580A . #xD4C1) - (#x580B . #xD4C4) - (#x580C . #x8FB8A1) - (#x580D . #x8FB8A2) - (#x5815 . #xC2C4) - (#x5819 . #xD4C5) - (#x581B . #x8FB8A3) - (#x581D . #xD4C6) - (#x581E . #x8FB8A4) - (#x581F . #x8FB8A5) - (#x5820 . #x8FB8A6) - (#x5821 . #xD4C8) - (#x5824 . #xC4E9) - (#x5826 . #x8FB8A7) - (#x5827 . #x8FB8A8) - (#x582A . #xB4AE) - (#x582D . #x8FB8A9) - (#x582F . #xF4A1) - (#x5830 . #xB1E1) - (#x5831 . #xCAF3) - (#x5832 . #x8FB8AA) - (#x5834 . #xBEEC) - (#x5835 . #xC5C8) - (#x5839 . #x8FB8AB) - (#x583A . #xBAE6) - (#x583D . #xD4CE) - (#x583F . #x8FB8AC) - (#x5840 . #xCABD) - (#x5841 . #xCEDD) - (#x5849 . #x8FB8AD) - (#x584A . #xB2F4) - (#x584B . #xD4CA) - (#x584C . #x8FB8AE) - (#x584D . #x8FB8AF) - (#x584F . #x8FB8B0) - (#x5850 . #x8FB8B1) - (#x5851 . #xC1BA) - (#x5852 . #xD4CD) - (#x5854 . #xC5E3) - (#x5855 . #x8FB8B2) - (#x5857 . #xC5C9) - (#x5858 . #xC5E4) - (#x5859 . #xC8B9) - (#x585A . #xC4CD) - (#x585E . #xBAC9) - (#x585F . #x8FB8B3) - (#x5861 . #x8FB8B4) - (#x5862 . #xD4C9) - (#x5864 . #x8FB8B5) - (#x5867 . #x8FB8B6) - (#x5868 . #x8FB8B7) - (#x5869 . #xB1F6) - (#x586B . #xC5B6) - (#x5870 . #xD4CB) - (#x5872 . #xD4C7) - (#x5875 . #xBFD0) - (#x5878 . #x8FB8B8) - (#x5879 . #xD4CF) - (#x587C . #x8FB8B9) - (#x587E . #xBDCE) - (#x587F . #x8FB8BA) - (#x5880 . #x8FB8BB) - (#x5881 . #x8FB8BC) - (#x5883 . #xB6AD) - (#x5885 . #xD4D0) - (#x5887 . #x8FB8BD) - (#x5888 . #x8FB8BE) - (#x5889 . #x8FB8BF) - (#x588A . #x8FB8C0) - (#x588C . #x8FB8C1) - (#x588D . #x8FB8C2) - (#x588F . #x8FB8C3) - (#x5890 . #x8FB8C4) - (#x5893 . #xCAE8) - (#x5894 . #x8FB8C5) - (#x5896 . #x8FB8C6) - (#x5897 . #xC1FD) - (#x589C . #xC4C6) - (#x589D . #x8FB8C7) - (#x589F . #xD4D2) - (#x58A0 . #x8FB8C8) - (#x58A1 . #x8FB8C9) - (#x58A2 . #x8FB8CA) - (#x58A6 . #x8FB8CB) - (#x58A8 . #xCBCF) - (#x58A9 . #x8FB8CC) - (#x58AB . #xD4D3) - (#x58AE . #xD4D8) - (#x58B1 . #x8FB8CD) - (#x58B2 . #x8FB8CE) - (#x58B3 . #xCAAF) - (#x58B8 . #xD4D7) - (#x58B9 . #xD4D1) - (#x58BA . #xD4D4) - (#x58BB . #xD4D6) - (#x58BC . #x8FB8D0) - (#x58BE . #xBAA6) - (#x58C1 . #xCAC9) - (#x58C2 . #x8FB8D1) - (#x58C4 . #x8FB8CF) - (#x58C5 . #xD4D9) - (#x58C7 . #xC3C5) - (#x58C8 . #x8FB8D2) - (#x58CA . #xB2F5) - (#x58CC . #xBEED) - (#x58CD . #x8FB8D3) - (#x58CE . #x8FB8D4) - (#x58D0 . #x8FB8D5) - (#x58D1 . #xD4DB) - (#x58D2 . #x8FB8D6) - (#x58D3 . #xD4DA) - (#x58D4 . #x8FB8D7) - (#x58D5 . #xB9E8) - (#x58D6 . #x8FB8D8) - (#x58D7 . #xD4DC) - (#x58D8 . #xD4DE) - (#x58D9 . #xD4DD) - (#x58DA . #x8FB8D9) - (#x58DC . #xD4E0) - (#x58DD . #x8FB8DA) - (#x58DE . #xD4D5) - (#x58DF . #xD4E2) - (#x58E1 . #x8FB8DB) - (#x58E2 . #x8FB8DC) - (#x58E4 . #xD4E1) - (#x58E5 . #xD4DF) - (#x58E9 . #x8FB8DD) - (#x58EB . #xBBCE) - (#x58EC . #xBFD1) - (#x58EE . #xC1D4) - (#x58EF . #xD4E3) - (#x58F0 . #xC0BC) - (#x58F1 . #xB0ED) - (#x58F2 . #xC7E4) - (#x58F3 . #x8FB8DE) - (#x58F7 . #xC4DB) - (#x58F9 . #xD4E5) - (#x58FA . #xD4E4) - (#x58FB . #xD4E6) - (#x58FC . #xD4E7) - (#x58FD . #xD4E8) - (#x5902 . #xD4E9) - (#x5905 . #x8FB8DF) - (#x5906 . #x8FB8E0) - (#x5909 . #xCAD1) - (#x590A . #xD4EA) - (#x590B . #x8FB8E1) - (#x590C . #x8FB8E2) - (#x590F . #xB2C6) - (#x5910 . #xD4EB) - (#x5912 . #x8FB8E3) - (#x5913 . #x8FB8E4) - (#x5914 . #x8FB8E5) - (#x5915 . #xCDBC) - (#x5916 . #xB3B0) - (#x5918 . #xD2C9) - (#x5919 . #xBDC8) - (#x591A . #xC2BF) - (#x591B . #xD4EC) - (#x591C . #xCCEB) - (#x591D . #x8FB8E7) - (#x5921 . #x8FB8E8) - (#x5922 . #xCCB4) - (#x5923 . #x8FB8E9) - (#x5924 . #x8FB8EA) - (#x5925 . #xD4EE) - (#x5927 . #xC2E7) - (#x5928 . #x8FB8EB) - (#x5929 . #xC5B7) - (#x592A . #xC2C0) - (#x592B . #xC9D7) - (#x592C . #xD4EF) - (#x592D . #xD4F0) - (#x592E . #xB1FB) - (#x592F . #x8FB8EC) - (#x5930 . #x8FB8ED) - (#x5931 . #xBCBA) - (#x5932 . #xD4F1) - (#x5933 . #x8FB8EE) - (#x5935 . #x8FB8EF) - (#x5936 . #x8FB8F0) - (#x5937 . #xB0D0) - (#x5938 . #xD4F2) - (#x593E . #xD4F3) - (#x593F . #x8FB8F1) - (#x5943 . #x8FB8F2) - (#x5944 . #xB1E2) - (#x5946 . #x8FB8F3) - (#x5947 . #xB4F1) - (#x5948 . #xC6E0) - (#x5949 . #xCAF4) - (#x594E . #xD4F7) - (#x594F . #xC1D5) - (#x5950 . #xD4F6) - (#x5951 . #xB7C0) - (#x5952 . #x8FB8F4) - (#x5953 . #x8FB8F5) - (#x5954 . #xCBDB) - (#x5955 . #xD4F5) - (#x5957 . #xC5E5) - (#x5958 . #xD4F9) - (#x5959 . #x8FB8F6) - (#x595A . #xD4F8) - (#x595B . #x8FB8F7) - (#x595D . #x8FB8F8) - (#x595E . #x8FB8F9) - (#x595F . #x8FB8FA) - (#x5960 . #xD4FB) - (#x5961 . #x8FB8FB) - (#x5962 . #xD4FA) - (#x5963 . #x8FB8FC) - (#x5965 . #xB1FC) - (#x5967 . #xD4FC) - (#x5968 . #xBEA9) - (#x5969 . #xD4FE) - (#x596A . #xC3A5) - (#x596B . #x8FB8FD) - (#x596C . #xD4FD) - (#x596D . #x8FB8FE) - (#x596E . #xCAB3) - (#x596F . #x8FB9A1) - (#x5972 . #x8FB9A2) - (#x5973 . #xBDF7) - (#x5974 . #xC5DB) - (#x5975 . #x8FB9A3) - (#x5976 . #x8FB9A4) - (#x5978 . #xD5A1) - (#x5979 . #x8FB9A5) - (#x597B . #x8FB9A6) - (#x597C . #x8FB9A7) - (#x597D . #xB9A5) - (#x5981 . #xD5A2) - (#x5982 . #xC7A1) - (#x5983 . #xC8DE) - (#x5984 . #xCCD1) - (#x598A . #xC7A5) - (#x598B . #x8FB9A8) - (#x598C . #x8FB9A9) - (#x598D . #xD5AB) - (#x598E . #x8FB9AA) - (#x5992 . #x8FB9AB) - (#x5993 . #xB5B8) - (#x5995 . #x8FB9AC) - (#x5996 . #xCDC5) - (#x5997 . #x8FB9AD) - (#x5999 . #xCCAF) - (#x599B . #xD6AC) - (#x599D . #xD5A3) - (#x599F . #x8FB9AE) - (#x59A3 . #xD5A6) - (#x59A4 . #x8FB9AF) - (#x59A5 . #xC2C5) - (#x59A7 . #x8FB9B0) - (#x59A8 . #xCBB8) - (#x59AC . #xC5CA) - (#x59AD . #x8FB9B1) - (#x59AE . #x8FB9B2) - (#x59AF . #x8FB9B3) - (#x59B0 . #x8FB9B4) - (#x59B2 . #xD5A7) - (#x59B3 . #x8FB9B5) - (#x59B7 . #x8FB9B6) - (#x59B9 . #xCBE5) - (#x59BA . #x8FB9B7) - (#x59BB . #xBACA) - (#x59BC . #x8FB9B8) - (#x59BE . #xBEAA) - (#x59C1 . #x8FB9B9) - (#x59C3 . #x8FB9BA) - (#x59C4 . #x8FB9BB) - (#x59C6 . #xD5A8) - (#x59C8 . #x8FB9BC) - (#x59C9 . #xBBD0) - (#x59CA . #x8FB9BD) - (#x59CB . #xBBCF) - (#x59CD . #x8FB9BE) - (#x59D0 . #xB0B9) - (#x59D1 . #xB8C8) - (#x59D2 . #x8FB9BF) - (#x59D3 . #xC0AB) - (#x59D4 . #xB0D1) - (#x59D9 . #xD5AC) - (#x59DA . #xD5AD) - (#x59DC . #xD5AA) - (#x59DD . #x8FB9C0) - (#x59DE . #x8FB9C1) - (#x59DF . #x8FB9C2) - (#x59E3 . #x8FB9C3) - (#x59E4 . #x8FB9C4) - (#x59E5 . #xB1B8) - (#x59E6 . #xB4AF) - (#x59E7 . #x8FB9C5) - (#x59E8 . #xD5A9) - (#x59EA . #xCCC5) - (#x59EB . #xC9B1) - (#x59EE . #x8FB9C6) - (#x59EF . #x8FB9C7) - (#x59F1 . #x8FB9C8) - (#x59F2 . #x8FB9C9) - (#x59F4 . #x8FB9CA) - (#x59F6 . #xB0A8) - (#x59F7 . #x8FB9CB) - (#x59FB . #xB0F9) - (#x59FF . #xBBD1) - (#x5A00 . #x8FB9CC) - (#x5A01 . #xB0D2) - (#x5A03 . #xB0A3) - (#x5A04 . #x8FB9CD) - (#x5A09 . #xD5B2) - (#x5A0C . #x8FB9CE) - (#x5A0D . #x8FB9CF) - (#x5A0E . #x8FB9D0) - (#x5A11 . #xD5B0) - (#x5A12 . #x8FB9D1) - (#x5A13 . #x8FB9D2) - (#x5A18 . #xCCBC) - (#x5A1A . #xD5B3) - (#x5A1C . #xD5B1) - (#x5A1E . #x8FB9D3) - (#x5A1F . #xD5AF) - (#x5A20 . #xBFB1) - (#x5A23 . #x8FB9D4) - (#x5A24 . #x8FB9D5) - (#x5A25 . #xD5AE) - (#x5A27 . #x8FB9D6) - (#x5A28 . #x8FB9D7) - (#x5A29 . #xCADA) - (#x5A2A . #x8FB9D8) - (#x5A2D . #x8FB9D9) - (#x5A2F . #xB8E4) - (#x5A30 . #x8FB9DA) - (#x5A35 . #xD5B7) - (#x5A36 . #xD5B8) - (#x5A3C . #xBEAB) - (#x5A40 . #xD5B4) - (#x5A41 . #xCFAC) - (#x5A44 . #x8FB9DB) - (#x5A45 . #x8FB9DC) - (#x5A46 . #xC7CC) - (#x5A47 . #x8FB9DD) - (#x5A48 . #x8FB9DE) - (#x5A49 . #xD5B6) - (#x5A4C . #x8FB9DF) - (#x5A50 . #x8FB9E0) - (#x5A55 . #x8FB9E1) - (#x5A5A . #xBAA7) - (#x5A5E . #x8FB9E2) - (#x5A62 . #xD5B9) - (#x5A63 . #x8FB9E3) - (#x5A65 . #x8FB9E4) - (#x5A66 . #xC9D8) - (#x5A67 . #x8FB9E5) - (#x5A6A . #xD5BA) - (#x5A6C . #xD5B5) - (#x5A6D . #x8FB9E6) - (#x5A77 . #x8FB9E7) - (#x5A7A . #x8FB9E8) - (#x5A7B . #x8FB9E9) - (#x5A7E . #x8FB9EA) - (#x5A7F . #xCCBB) - (#x5A8B . #x8FB9EB) - (#x5A90 . #x8FB9EC) - (#x5A92 . #xC7DE) - (#x5A93 . #x8FB9ED) - (#x5A96 . #x8FB9EE) - (#x5A99 . #x8FB9EF) - (#x5A9A . #xD5BB) - (#x5A9B . #xC9B2) - (#x5A9C . #x8FB9F0) - (#x5A9E . #x8FB9F1) - (#x5A9F . #x8FB9F2) - (#x5AA0 . #x8FB9F3) - (#x5AA2 . #x8FB9F4) - (#x5AA7 . #x8FB9F5) - (#x5AAC . #x8FB9F6) - (#x5AB1 . #x8FB9F7) - (#x5AB2 . #x8FB9F8) - (#x5AB3 . #x8FB9F9) - (#x5AB5 . #x8FB9FA) - (#x5AB8 . #x8FB9FB) - (#x5ABA . #x8FB9FC) - (#x5ABB . #x8FB9FD) - (#x5ABC . #xD5BC) - (#x5ABD . #xD5C0) - (#x5ABE . #xD5BD) - (#x5ABF . #x8FB9FE) - (#x5AC1 . #xB2C7) - (#x5AC2 . #xD5BF) - (#x5AC4 . #x8FBAA1) - (#x5AC6 . #x8FBAA2) - (#x5AC8 . #x8FBAA3) - (#x5AC9 . #xBCBB) - (#x5ACB . #xD5BE) - (#x5ACC . #xB7F9) - (#x5ACF . #x8FBAA4) - (#x5AD0 . #xD5CC) - (#x5AD6 . #xD5C5) - (#x5AD7 . #xD5C2) - (#x5ADA . #x8FBAA5) - (#x5ADC . #x8FBAA6) - (#x5AE0 . #x8FBAA7) - (#x5AE1 . #xC3E4) - (#x5AE3 . #xD5C1) - (#x5AE5 . #x8FBAA8) - (#x5AE6 . #xD5C3) - (#x5AE9 . #xD5C4) - (#x5AEA . #x8FBAA9) - (#x5AEE . #x8FBAAA) - (#x5AF5 . #x8FBAAB) - (#x5AF6 . #x8FBAAC) - (#x5AFA . #xD5C6) - (#x5AFB . #xD5C7) - (#x5AFD . #x8FBAAD) - (#x5B00 . #x8FBAAE) - (#x5B01 . #x8FBAAF) - (#x5B08 . #x8FBAB0) - (#x5B09 . #xB4F2) - (#x5B0B . #xD5C9) - (#x5B0C . #xD5C8) - (#x5B16 . #xD5CA) - (#x5B17 . #x8FBAB1) - (#x5B19 . #x8FBAB3) - (#x5B1B . #x8FBAB4) - (#x5B1D . #x8FBAB5) - (#x5B21 . #x8FBAB6) - (#x5B22 . #xBEEE) - (#x5B25 . #x8FBAB7) - (#x5B2A . #xD5CD) - (#x5B2C . #xC4DC) - (#x5B2D . #x8FBAB8) - (#x5B30 . #xB1C5) - (#x5B32 . #xD5CB) - (#x5B34 . #x8FBAB2) - (#x5B36 . #xD5CE) - (#x5B38 . #x8FBAB9) - (#x5B3E . #xD5CF) - (#x5B40 . #xD5D2) - (#x5B41 . #x8FBABA) - (#x5B43 . #xD5D0) - (#x5B45 . #xD5D1) - (#x5B4B . #x8FBABB) - (#x5B4C . #x8FBABC) - (#x5B50 . #xBBD2) - (#x5B51 . #xD5D3) - (#x5B52 . #x8FBABD) - (#x5B54 . #xB9A6) - (#x5B55 . #xD5D4) - (#x5B56 . #x8FBABE) - (#x5B57 . #xBBFA) - (#x5B58 . #xC2B8) - (#x5B5A . #xD5D5) - (#x5B5B . #xD5D6) - (#x5B5C . #xBBDA) - (#x5B5D . #xB9A7) - (#x5B5E . #x8FBABF) - (#x5B5F . #xCCD2) - (#x5B63 . #xB5A8) - (#x5B64 . #xB8C9) - (#x5B65 . #xD5D7) - (#x5B66 . #xB3D8) - (#x5B68 . #x8FBAC0) - (#x5B69 . #xD5D8) - (#x5B6B . #xC2B9) - (#x5B6E . #x8FBAC1) - (#x5B6F . #x8FBAC2) - (#x5B70 . #xD5D9) - (#x5B71 . #xD6A3) - (#x5B73 . #xD5DA) - (#x5B75 . #xD5DB) - (#x5B78 . #xD5DC) - (#x5B7A . #xD5DE) - (#x5B7C . #x8FBAC3) - (#x5B7D . #x8FBAC4) - (#x5B7E . #x8FBAC5) - (#x5B7F . #x8FBAC6) - (#x5B80 . #xD5DF) - (#x5B81 . #x8FBAC7) - (#x5B83 . #xD5E0) - (#x5B84 . #x8FBAC8) - (#x5B85 . #xC2F0) - (#x5B86 . #x8FBAC9) - (#x5B87 . #xB1A7) - (#x5B88 . #xBCE9) - (#x5B89 . #xB0C2) - (#x5B8A . #x8FBACA) - (#x5B8B . #xC1D7) - (#x5B8C . #xB4B0) - (#x5B8D . #xBCB5) - (#x5B8E . #x8FBACB) - (#x5B8F . #xB9A8) - (#x5B90 . #x8FBACC) - (#x5B91 . #x8FBACD) - (#x5B93 . #x8FBACE) - (#x5B94 . #x8FBACF) - (#x5B95 . #xC5E6) - (#x5B96 . #x8FBAD0) - (#x5B97 . #xBDA1) - (#x5B98 . #xB4B1) - (#x5B99 . #xC3E8) - (#x5B9A . #xC4EA) - (#x5B9B . #xB0B8) - (#x5B9C . #xB5B9) - (#x5B9D . #xCAF5) - (#x5B9F . #xBCC2) - (#x5BA2 . #xB5D2) - (#x5BA3 . #xC0EB) - (#x5BA4 . #xBCBC) - (#x5BA5 . #xCDA8) - (#x5BA6 . #xD5E1) - (#x5BA8 . #x8FBAD1) - (#x5BA9 . #x8FBAD2) - (#x5BAC . #x8FBAD3) - (#x5BAD . #x8FBAD4) - (#x5BAE . #xB5DC) - (#x5BAF . #x8FBAD5) - (#x5BB0 . #xBACB) - (#x5BB1 . #x8FBAD6) - (#x5BB2 . #x8FBAD7) - (#x5BB3 . #xB3B2) - (#x5BB4 . #xB1E3) - (#x5BB5 . #xBEAC) - (#x5BB6 . #xB2C8) - (#x5BB7 . #x8FBAD8) - (#x5BB8 . #xD5E2) - (#x5BB9 . #xCDC6) - (#x5BBA . #x8FBAD9) - (#x5BBC . #x8FBADA) - (#x5BBF . #xBDC9) - (#x5BC0 . #x8FBADB) - (#x5BC1 . #x8FBADC) - (#x5BC2 . #xBCE4) - (#x5BC3 . #xD5E3) - (#x5BC4 . #xB4F3) - (#x5BC5 . #xC6D2) - (#x5BC6 . #xCCA9) - (#x5BC7 . #xD5E4) - (#x5BC9 . #xD5E5) - (#x5BCC . #xC9D9) - (#x5BCD . #x8FBADD) - (#x5BCF . #x8FBADE) - (#x5BD0 . #xD5E7) - (#x5BD2 . #xB4A8) - (#x5BD3 . #xB6F7) - (#x5BD4 . #xD5E6) - (#x5BD6 . #x8FBADF) - (#x5BD7 . #x8FBAE0) - (#x5BD8 . #x8FBAE1) - (#x5BD9 . #x8FBAE2) - (#x5BDA . #x8FBAE3) - (#x5BDB . #xB4B2) - (#x5BDD . #xBFB2) - (#x5BDE . #xD5EB) - (#x5BDF . #xBBA1) - (#x5BE0 . #x8FBAE4) - (#x5BE1 . #xB2C9) - (#x5BE2 . #xD5EA) - (#x5BE4 . #xD5E8) - (#x5BE5 . #xD5EC) - (#x5BE6 . #xD5E9) - (#x5BE7 . #xC7AB) - (#x5BE8 . #xDCCD) - (#x5BE9 . #xBFB3) - (#x5BEB . #xD5ED) - (#x5BEE . #xCEC0) - (#x5BEF . #x8FBAE5) - (#x5BF0 . #xD5EE) - (#x5BF1 . #x8FBAE6) - (#x5BF3 . #xD5F0) - (#x5BF4 . #x8FBAE7) - (#x5BF5 . #xC3FE) - (#x5BF6 . #xD5EF) - (#x5BF8 . #xC0A3) - (#x5BFA . #xBBFB) - (#x5BFD . #x8FBAE8) - (#x5BFE . #xC2D0) - (#x5BFF . #xBCF7) - (#x5C01 . #xC9F5) - (#x5C02 . #xC0EC) - (#x5C04 . #xBCCD) - (#x5C05 . #xD5F1) - (#x5C06 . #xBEAD) - (#x5C07 . #xD5F2) - (#x5C08 . #xD5F3) - (#x5C09 . #xB0D3) - (#x5C0A . #xC2BA) - (#x5C0B . #xBFD2) - (#x5C0C . #x8FBAE9) - (#x5C0D . #xD5F4) - (#x5C0E . #xC6B3) - (#x5C0F . #xBEAE) - (#x5C11 . #xBEAF) - (#x5C13 . #xD5F5) - (#x5C16 . #xC0ED) - (#x5C17 . #x8FBAEA) - (#x5C1A . #xBEB0) - (#x5C1E . #x8FBAEB) - (#x5C1F . #x8FBAEC) - (#x5C20 . #xD5F6) - (#x5C22 . #xD5F7) - (#x5C23 . #x8FBAED) - (#x5C24 . #xCCE0) - (#x5C26 . #x8FBAEE) - (#x5C28 . #xD5F8) - (#x5C29 . #x8FBAEF) - (#x5C2B . #x8FBAF0) - (#x5C2C . #x8FBAF1) - (#x5C2D . #xB6C6) - (#x5C2E . #x8FBAF2) - (#x5C30 . #x8FBAF3) - (#x5C31 . #xBDA2) - (#x5C32 . #x8FBAF4) - (#x5C35 . #x8FBAF5) - (#x5C36 . #x8FBAF6) - (#x5C38 . #xD5F9) - (#x5C39 . #xD5FA) - (#x5C3A . #xBCDC) - (#x5C3B . #xBFAC) - (#x5C3C . #xC6F4) - (#x5C3D . #xBFD4) - (#x5C3E . #xC8F8) - (#x5C3F . #xC7A2) - (#x5C40 . #xB6C9) - (#x5C41 . #xD5FB) - (#x5C45 . #xB5EF) - (#x5C46 . #xD5FC) - (#x5C48 . #xB6FE) - (#x5C4A . #xC6CF) - (#x5C4B . #xB2B0) - (#x5C4D . #xBBD3) - (#x5C4E . #xD5FD) - (#x5C4F . #xD6A2) - (#x5C50 . #xD6A1) - (#x5C51 . #xB6FD) - (#x5C53 . #xD5FE) - (#x5C55 . #xC5B8) - (#x5C59 . #x8FBAF7) - (#x5C5A . #x8FBAF8) - (#x5C5C . #x8FBAF9) - (#x5C5E . #xC2B0) - (#x5C60 . #xC5CB) - (#x5C61 . #xBCC8) - (#x5C62 . #x8FBAFA) - (#x5C63 . #x8FBAFB) - (#x5C64 . #xC1D8) - (#x5C65 . #xCDFA) - (#x5C67 . #x8FBAFC) - (#x5C68 . #x8FBAFD) - (#x5C69 . #x8FBAFE) - (#x5C6C . #xD6A4) - (#x5C6D . #x8FBBA1) - (#x5C6E . #xD6A5) - (#x5C6F . #xC6D6) - (#x5C70 . #x8FBBA2) - (#x5C71 . #xBBB3) - (#x5C74 . #x8FBBA3) - (#x5C75 . #x8FBBA4) - (#x5C76 . #xD6A7) - (#x5C79 . #xD6A8) - (#x5C7A . #x8FBBA5) - (#x5C7B . #x8FBBA6) - (#x5C7C . #x8FBBA7) - (#x5C7D . #x8FBBA8) - (#x5C87 . #x8FBBA9) - (#x5C88 . #x8FBBAA) - (#x5C8A . #x8FBBAB) - (#x5C8C . #xD6A9) - (#x5C8F . #x8FBBAC) - (#x5C90 . #xB4F4) - (#x5C91 . #xD6AA) - (#x5C92 . #x8FBBAD) - (#x5C94 . #xD6AB) - (#x5C9D . #x8FBBAE) - (#x5C9F . #x8FBBAF) - (#x5CA0 . #x8FBBB0) - (#x5CA1 . #xB2AC) - (#x5CA2 . #x8FBBB1) - (#x5CA3 . #x8FBBB2) - (#x5CA6 . #x8FBBB3) - (#x5CA8 . #xC1BB) - (#x5CA9 . #xB4E4) - (#x5CAA . #x8FBBB4) - (#x5CAB . #xD6AD) - (#x5CAC . #xCCA8) - (#x5CB1 . #xC2D2) - (#x5CB2 . #x8FBBB5) - (#x5CB3 . #xB3D9) - (#x5CB4 . #x8FBBB6) - (#x5CB5 . #x8FBBB7) - (#x5CB6 . #xD6AF) - (#x5CB7 . #xD6B1) - (#x5CB8 . #xB4DF) - (#x5CBA . #x8FBBB8) - (#x5CBB . #xD6AE) - (#x5CBC . #xD6B0) - (#x5CBE . #xD6B3) - (#x5CC5 . #xD6B2) - (#x5CC7 . #xD6B4) - (#x5CC9 . #x8FBBB9) - (#x5CCB . #x8FBBBA) - (#x5CD2 . #x8FBBBB) - (#x5CD7 . #x8FBBBD) - (#x5CD9 . #xD6B5) - (#x5CDD . #x8FBBBC) - (#x5CE0 . #xC6BD) - (#x5CE1 . #xB6AE) - (#x5CE8 . #xB2E5) - (#x5CE9 . #xD6B6) - (#x5CEA . #xD6BB) - (#x5CED . #xD6B9) - (#x5CEE . #x8FBBBE) - (#x5CEF . #xCAF7) - (#x5CF0 . #xCAF6) - (#x5CF1 . #x8FBBBF) - (#x5CF2 . #x8FBBC0) - (#x5CF4 . #x8FBBC1) - (#x5CF6 . #xC5E7) - (#x5CFA . #xD6B8) - (#x5CFB . #xBDD4) - (#x5CFD . #xD6B7) - (#x5D01 . #x8FBBC2) - (#x5D06 . #x8FBBC3) - (#x5D07 . #xBFF2) - (#x5D0B . #xD6BC) - (#x5D0D . #x8FBBC4) - (#x5D0E . #xBAEA) - (#x5D11 . #xD6C2) - (#x5D12 . #x8FBBC5) - (#x5D14 . #xD6C3) - (#x5D15 . #xD6BD) - (#x5D16 . #xB3B3) - (#x5D17 . #xD6BE) - (#x5D18 . #xD6C7) - (#x5D19 . #xD6C6) - (#x5D1A . #xD6C5) - (#x5D1B . #xD6C1) - (#x5D1F . #xD6C0) - (#x5D22 . #xD6C4) - (#x5D23 . #x8FBBC7) - (#x5D24 . #x8FBBC8) - (#x5D26 . #x8FBBC9) - (#x5D27 . #x8FBBCA) - (#x5D29 . #xCAF8) - (#x5D2B . #x8FBBC6) - (#x5D31 . #x8FBBCB) - (#x5D34 . #x8FBBCC) - (#x5D39 . #x8FBBCD) - (#x5D3D . #x8FBBCE) - (#x5D3F . #x8FBBCF) - (#x5D42 . #x8FBBD0) - (#x5D43 . #x8FBBD1) - (#x5D46 . #x8FBBD2) - (#x5D48 . #x8FBBD3) - (#x5D4A . #x8FBBD7) - (#x5D4B . #xD6CB) - (#x5D4C . #xD6C8) - (#x5D4E . #xD6CA) - (#x5D50 . #xCDF2) - (#x5D51 . #x8FBBD5) - (#x5D52 . #xD6C9) - (#x5D55 . #x8FBBD4) - (#x5D59 . #x8FBBD6) - (#x5D5C . #xD6BF) - (#x5D5F . #x8FBBD8) - (#x5D60 . #x8FBBD9) - (#x5D61 . #x8FBBDA) - (#x5D62 . #x8FBBDB) - (#x5D64 . #x8FBBDC) - (#x5D69 . #xBFF3) - (#x5D6A . #x8FBBDD) - (#x5D6C . #xD6CC) - (#x5D6D . #x8FBBDE) - (#x5D6F . #xBAB7) - (#x5D70 . #x8FBBDF) - (#x5D73 . #xD6CD) - (#x5D76 . #xD6CE) - (#x5D79 . #x8FBBE0) - (#x5D7A . #x8FBBE1) - (#x5D7E . #x8FBBE2) - (#x5D7F . #x8FBBE3) - (#x5D81 . #x8FBBE4) - (#x5D82 . #xD6D1) - (#x5D83 . #x8FBBE5) - (#x5D84 . #xD6D0) - (#x5D87 . #xD6CF) - (#x5D88 . #x8FBBE6) - (#x5D8A . #x8FBBE7) - (#x5D8B . #xC5E8) - (#x5D8C . #xD6BA) - (#x5D90 . #xD6D7) - (#x5D92 . #x8FBBE8) - (#x5D93 . #x8FBBE9) - (#x5D94 . #x8FBBEA) - (#x5D95 . #x8FBBEB) - (#x5D99 . #x8FBBEC) - (#x5D9B . #x8FBBED) - (#x5D9D . #xD6D3) - (#x5D9F . #x8FBBEE) - (#x5DA0 . #x8FBBEF) - (#x5DA2 . #xD6D2) - (#x5DA7 . #x8FBBF0) - (#x5DAB . #x8FBBF1) - (#x5DAC . #xD6D4) - (#x5DAE . #xD6D5) - (#x5DB0 . #x8FBBF2) - (#x5DB2 . #x8FE6F4) - (#x5DB4 . #x8FBBF3) - (#x5DB7 . #xD6D8) - (#x5DB8 . #x8FBBF4) - (#x5DB9 . #x8FBBF5) - (#x5DBA . #xCEE6) - (#x5DBC . #xD6D9) - (#x5DBD . #xD6D6) - (#x5DC3 . #x8FBBF6) - (#x5DC7 . #x8FBBF7) - (#x5DC9 . #xD6DA) - (#x5DCB . #x8FBBF8) - (#x5DCC . #xB4E0) - (#x5DCD . #xD6DB) - (#x5DCE . #x8FBBFA) - (#x5DD0 . #x8FBBF9) - (#x5DD2 . #xD6DD) - (#x5DD3 . #xD6DC) - (#x5DD6 . #xD6DE) - (#x5DD8 . #x8FBBFB) - (#x5DD9 . #x8FBBFC) - (#x5DDB . #xD6DF) - (#x5DDD . #xC0EE) - (#x5DDE . #xBDA3) - (#x5DE0 . #x8FBBFD) - (#x5DE1 . #xBDE4) - (#x5DE3 . #xC1E3) - (#x5DE4 . #x8FBBFE) - (#x5DE5 . #xB9A9) - (#x5DE6 . #xBAB8) - (#x5DE7 . #xB9AA) - (#x5DE8 . #xB5F0) - (#x5DE9 . #x8FBCA1) - (#x5DEB . #xD6E0) - (#x5DEE . #xBAB9) - (#x5DF1 . #xB8CA) - (#x5DF2 . #xD6E1) - (#x5DF3 . #xCCA6) - (#x5DF4 . #xC7C3) - (#x5DF5 . #xD6E2) - (#x5DF7 . #xB9AB) - (#x5DF8 . #x8FBCA2) - (#x5DF9 . #x8FBCA3) - (#x5DFB . #xB4AC) - (#x5DFD . #xC3A7) - (#x5DFE . #xB6D2) - (#x5E00 . #x8FBCA4) - (#x5E02 . #xBBD4) - (#x5E03 . #xC9DB) - (#x5E06 . #xC8C1) - (#x5E07 . #x8FBCA5) - (#x5E0B . #xD6E3) - (#x5E0C . #xB4F5) - (#x5E0D . #x8FBCA6) - (#x5E11 . #xD6E6) - (#x5E12 . #x8FBCA7) - (#x5E14 . #x8FBCA8) - (#x5E15 . #x8FBCA9) - (#x5E16 . #xC4A1) - (#x5E18 . #x8FBCAA) - (#x5E19 . #xD6E5) - (#x5E1A . #xD6E4) - (#x5E1B . #xD6E7) - (#x5E1D . #xC4EB) - (#x5E1F . #x8FBCAB) - (#x5E20 . #x8FBCAC) - (#x5E25 . #xBFE3) - (#x5E28 . #x8FBCAE) - (#x5E2B . #xBBD5) - (#x5E2D . #xC0CA) - (#x5E2E . #x8FBCAD) - (#x5E2F . #xC2D3) - (#x5E30 . #xB5A2) - (#x5E32 . #x8FBCAF) - (#x5E33 . #xC4A2) - (#x5E35 . #x8FBCB0) - (#x5E36 . #xD6E8) - (#x5E37 . #xD6E9) - (#x5E38 . #xBEEF) - (#x5E3D . #xCBB9) - (#x5E3E . #x8FBCB1) - (#x5E40 . #xD6EC) - (#x5E43 . #xD6EB) - (#x5E44 . #xD6EA) - (#x5E45 . #xC9FD) - (#x5E47 . #xD6F3) - (#x5E49 . #x8FBCB4) - (#x5E4B . #x8FBCB2) - (#x5E4C . #xCBDA) - (#x5E4E . #xD6ED) - (#x5E50 . #x8FBCB3) - (#x5E51 . #x8FBCB5) - (#x5E54 . #xD6EF) - (#x5E55 . #xCBEB) - (#x5E56 . #x8FBCB6) - (#x5E57 . #xD6EE) - (#x5E58 . #x8FBCB7) - (#x5E5B . #x8FBCB8) - (#x5E5C . #x8FBCB9) - (#x5E5E . #x8FBCBA) - (#x5E5F . #xD6F0) - (#x5E61 . #xC8A8) - (#x5E62 . #xD6F1) - (#x5E63 . #xCABE) - (#x5E64 . #xD6F2) - (#x5E68 . #x8FBCBB) - (#x5E6A . #x8FBCBC) - (#x5E6B . #x8FBCBD) - (#x5E6C . #x8FBCBE) - (#x5E6D . #x8FBCBF) - (#x5E6E . #x8FBCC0) - (#x5E70 . #x8FBCC1) - (#x5E72 . #xB4B3) - (#x5E73 . #xCABF) - (#x5E74 . #xC7AF) - (#x5E75 . #xD6F4) - (#x5E76 . #xD6F5) - (#x5E78 . #xB9AC) - (#x5E79 . #xB4B4) - (#x5E7A . #xD6F6) - (#x5E7B . #xB8B8) - (#x5E7C . #xCDC4) - (#x5E7D . #xCDA9) - (#x5E7E . #xB4F6) - (#x5E7F . #xD6F8) - (#x5E80 . #x8FBCC2) - (#x5E81 . #xC4A3) - (#x5E83 . #xB9AD) - (#x5E84 . #xBEB1) - (#x5E87 . #xC8DF) - (#x5E8A . #xBEB2) - (#x5E8B . #x8FBCC3) - (#x5E8E . #x8FBCC4) - (#x5E8F . #xBDF8) - (#x5E95 . #xC4EC) - (#x5E96 . #xCAF9) - (#x5E97 . #xC5B9) - (#x5E9A . #xB9AE) - (#x5E9C . #xC9DC) - (#x5EA0 . #xD6F9) - (#x5EA2 . #x8FBCC5) - (#x5EA4 . #x8FBCC6) - (#x5EA5 . #x8FBCC7) - (#x5EA6 . #xC5D9) - (#x5EA7 . #xBAC2) - (#x5EA8 . #x8FBCC8) - (#x5EAA . #x8FBCC9) - (#x5EAB . #xB8CB) - (#x5EAC . #x8FBCCA) - (#x5EAD . #xC4ED) - (#x5EB1 . #x8FBCCB) - (#x5EB3 . #x8FBCCC) - (#x5EB5 . #xB0C3) - (#x5EB6 . #xBDEE) - (#x5EB7 . #xB9AF) - (#x5EB8 . #xCDC7) - (#x5EBD . #x8FBCCD) - (#x5EBE . #x8FBCCE) - (#x5EBF . #x8FBCCF) - (#x5EC1 . #xD6FA) - (#x5EC2 . #xD6FB) - (#x5EC3 . #xC7D1) - (#x5EC6 . #x8FBCD0) - (#x5EC8 . #xD6FC) - (#x5EC9 . #xCEF7) - (#x5ECA . #xCFAD) - (#x5ECB . #x8FBCD2) - (#x5ECC . #x8FBCD1) - (#x5ECE . #x8FBCD3) - (#x5ECF . #xD6FE) - (#x5ED0 . #xD6FD) - (#x5ED1 . #x8FBCD4) - (#x5ED2 . #x8FBCD5) - (#x5ED3 . #xB3C7) - (#x5ED4 . #x8FBCD6) - (#x5ED5 . #x8FBCD7) - (#x5ED6 . #xD7A1) - (#x5EDA . #xD7A4) - (#x5EDB . #xD7A5) - (#x5EDC . #x8FBCD8) - (#x5EDD . #xD7A3) - (#x5EDE . #x8FBCD9) - (#x5EDF . #xC9C0) - (#x5EE0 . #xBEB3) - (#x5EE1 . #xD7A7) - (#x5EE2 . #xD7A6) - (#x5EE3 . #xD7A2) - (#x5EE5 . #x8FBCDA) - (#x5EE8 . #xD7A8) - (#x5EE9 . #xD7A9) - (#x5EEB . #x8FBCDB) - (#x5EEC . #xD7AA) - (#x5EF0 . #xD7AD) - (#x5EF1 . #xD7AB) - (#x5EF3 . #xD7AC) - (#x5EF4 . #xD7AE) - (#x5EF6 . #xB1E4) - (#x5EF7 . #xC4EE) - (#x5EF8 . #xD7AF) - (#x5EFA . #xB7FA) - (#x5EFB . #xB2F6) - (#x5EFC . #xC7B6) - (#x5EFE . #xD7B0) - (#x5EFF . #xC6FB) - (#x5F01 . #xCADB) - (#x5F02 . #x8FBCDC) - (#x5F03 . #xD7B1) - (#x5F04 . #xCFAE) - (#x5F06 . #x8FBCDD) - (#x5F07 . #x8FBCDE) - (#x5F08 . #x8FBCDF) - (#x5F09 . #xD7B2) - (#x5F0A . #xCAC0) - (#x5F0B . #xD7B5) - (#x5F0C . #xD0A1) - (#x5F0D . #xD0B1) - (#x5F0E . #x8FBCE0) - (#x5F0F . #xBCB0) - (#x5F10 . #xC6F5) - (#x5F11 . #xD7B6) - (#x5F13 . #xB5DD) - (#x5F14 . #xC4A4) - (#x5F15 . #xB0FA) - (#x5F16 . #xD7B7) - (#x5F17 . #xCAA6) - (#x5F18 . #xB9B0) - (#x5F19 . #x8FBCE1) - (#x5F1B . #xC3D0) - (#x5F1C . #x8FBCE2) - (#x5F1D . #x8FBCE3) - (#x5F1F . #xC4EF) - (#x5F21 . #x8FBCE4) - (#x5F22 . #x8FBCE5) - (#x5F23 . #x8FBCE6) - (#x5F24 . #x8FBCE7) - (#x5F25 . #xCCEF) - (#x5F26 . #xB8B9) - (#x5F27 . #xB8CC) - (#x5F28 . #x8FBCE8) - (#x5F29 . #xD7B8) - (#x5F2B . #x8FBCE9) - (#x5F2C . #x8FBCEA) - (#x5F2D . #xD7B9) - (#x5F2E . #x8FBCEB) - (#x5F2F . #xD7BF) - (#x5F30 . #x8FBCEC) - (#x5F31 . #xBCE5) - (#x5F34 . #x8FBCED) - (#x5F35 . #xC4A5) - (#x5F36 . #x8FBCEE) - (#x5F37 . #xB6AF) - (#x5F38 . #xD7BA) - (#x5F3B . #x8FBCEF) - (#x5F3C . #xC9AB) - (#x5F3D . #x8FBCF0) - (#x5F3E . #xC3C6) - (#x5F3F . #x8FBCF1) - (#x5F40 . #x8FBCF2) - (#x5F41 . #xD7BB) - (#x5F44 . #x8FBCF3) - (#x5F45 . #x8FBCF4) - (#x5F47 . #x8FBCF5) - (#x5F48 . #xD7BC) - (#x5F4A . #xB6B0) - (#x5F4C . #xD7BD) - (#x5F4D . #x8FBCF6) - (#x5F4E . #xD7BE) - (#x5F50 . #x8FBCF7) - (#x5F51 . #xD7C0) - (#x5F53 . #xC5F6) - (#x5F54 . #x8FBCF8) - (#x5F56 . #xD7C1) - (#x5F57 . #xD7C2) - (#x5F58 . #x8FBCF9) - (#x5F59 . #xD7C3) - (#x5F5B . #x8FBCFA) - (#x5F5C . #xD7B4) - (#x5F5D . #xD7B3) - (#x5F60 . #x8FBCFB) - (#x5F61 . #xD7C4) - (#x5F62 . #xB7C1) - (#x5F63 . #x8FBCFC) - (#x5F64 . #x8FBCFD) - (#x5F66 . #xC9A7) - (#x5F67 . #x8FBCFE) - (#x5F69 . #xBACC) - (#x5F6A . #xC9B7) - (#x5F6B . #xC4A6) - (#x5F6C . #xC9CB) - (#x5F6D . #xD7C5) - (#x5F6F . #x8FBDA1) - (#x5F70 . #xBEB4) - (#x5F71 . #xB1C6) - (#x5F72 . #x8FBDA2) - (#x5F73 . #xD7C6) - (#x5F74 . #x8FBDA3) - (#x5F75 . #x8FBDA4) - (#x5F77 . #xD7C7) - (#x5F78 . #x8FBDA5) - (#x5F79 . #xCCF2) - (#x5F7A . #x8FBDA6) - (#x5F7C . #xC8E0) - (#x5F7D . #x8FBDA7) - (#x5F7E . #x8FBDA8) - (#x5F7F . #xD7CA) - (#x5F80 . #xB1FD) - (#x5F81 . #xC0AC) - (#x5F82 . #xD7C9) - (#x5F83 . #xD7C8) - (#x5F84 . #xB7C2) - (#x5F85 . #xC2D4) - (#x5F87 . #xD7CE) - (#x5F88 . #xD7CC) - (#x5F89 . #x8FBDA9) - (#x5F8A . #xD7CB) - (#x5F8B . #xCEA7) - (#x5F8C . #xB8E5) - (#x5F8D . #x8FBDAA) - (#x5F8F . #x8FBDAB) - (#x5F90 . #xBDF9) - (#x5F91 . #xD7CD) - (#x5F92 . #xC5CC) - (#x5F93 . #xBDBE) - (#x5F96 . #x8FBDAC) - (#x5F97 . #xC6C0) - (#x5F98 . #xD7D1) - (#x5F99 . #xD7D0) - (#x5F9C . #x8FBDAD) - (#x5F9D . #x8FBDAE) - (#x5F9E . #xD7CF) - (#x5FA0 . #xD7D2) - (#x5FA1 . #xB8E6) - (#x5FA2 . #x8FBDAF) - (#x5FA4 . #x8FBDB2) - (#x5FA7 . #x8FBDB0) - (#x5FA8 . #xD7D3) - (#x5FA9 . #xC9FC) - (#x5FAA . #xBDDB) - (#x5FAB . #x8FBDB1) - (#x5FAC . #x8FBDB3) - (#x5FAD . #xD7D4) - (#x5FAE . #xC8F9) - (#x5FAF . #x8FBDB4) - (#x5FB0 . #x8FBDB5) - (#x5FB1 . #x8FBDB6) - (#x5FB3 . #xC6C1) - (#x5FB4 . #xC4A7) - (#x5FB8 . #x8FBDB7) - (#x5FB9 . #xC5B0) - (#x5FBC . #xD7D5) - (#x5FBD . #xB5AB) - (#x5FC3 . #xBFB4) - (#x5FC4 . #x8FBDB8) - (#x5FC5 . #xC9AC) - (#x5FC7 . #x8FBDB9) - (#x5FC8 . #x8FBDBA) - (#x5FC9 . #x8FBDBB) - (#x5FCB . #x8FBDBC) - (#x5FCC . #xB4F7) - (#x5FCD . #xC7A6) - (#x5FD0 . #x8FBDBD) - (#x5FD1 . #x8FBDBE) - (#x5FD2 . #x8FBDBF) - (#x5FD3 . #x8FBDC0) - (#x5FD4 . #x8FBDC1) - (#x5FD6 . #xD7D6) - (#x5FD7 . #xBBD6) - (#x5FD8 . #xCBBA) - (#x5FD9 . #xCBBB) - (#x5FDC . #xB1FE) - (#x5FDD . #xD7DB) - (#x5FDE . #x8FBDC2) - (#x5FE0 . #xC3E9) - (#x5FE1 . #x8FBDC3) - (#x5FE2 . #x8FBDC4) - (#x5FE4 . #xD7D8) - (#x5FE8 . #x8FBDC5) - (#x5FE9 . #x8FBDC6) - (#x5FEA . #x8FBDC7) - (#x5FEB . #xB2F7) - (#x5FEC . #x8FBDC8) - (#x5FED . #x8FBDC9) - (#x5FEE . #x8FBDCA) - (#x5FEF . #x8FBDCB) - (#x5FF0 . #xD8AD) - (#x5FF1 . #xD7DA) - (#x5FF2 . #x8FBDCC) - (#x5FF3 . #x8FBDCD) - (#x5FF5 . #xC7B0) - (#x5FF6 . #x8FBDCE) - (#x5FF8 . #xD7D9) - (#x5FFA . #x8FBDCF) - (#x5FFB . #xD7D7) - (#x5FFC . #x8FBDD0) - (#x5FFD . #xB9FA) - (#x5FFF . #xD7DD) - (#x6007 . #x8FBDD1) - (#x600A . #x8FBDD2) - (#x600D . #x8FBDD3) - (#x600E . #xD7E3) - (#x600F . #xD7E9) - (#x6010 . #xD7E1) - (#x6012 . #xC5DC) - (#x6013 . #x8FBDD4) - (#x6014 . #x8FBDD5) - (#x6015 . #xD7E6) - (#x6016 . #xC9DD) - (#x6017 . #x8FBDD6) - (#x6018 . #x8FBDD7) - (#x6019 . #xD7E0) - (#x601A . #x8FBDD8) - (#x601B . #xD7E5) - (#x601C . #xCEE7) - (#x601D . #xBBD7) - (#x601F . #x8FBDD9) - (#x6020 . #xC2D5) - (#x6021 . #xD7DE) - (#x6024 . #x8FBDDA) - (#x6025 . #xB5DE) - (#x6026 . #xD7E8) - (#x6027 . #xC0AD) - (#x6028 . #xB1E5) - (#x6029 . #xD7E2) - (#x602A . #xB2F8) - (#x602B . #xD7E7) - (#x602D . #x8FBDDB) - (#x602F . #xB6B1) - (#x6031 . #xD7E4) - (#x6033 . #x8FBDDC) - (#x6035 . #x8FBDDD) - (#x603A . #xD7EA) - (#x6040 . #x8FBDDE) - (#x6041 . #xD7EC) - (#x6042 . #xD7F6) - (#x6043 . #xD7F4) - (#x6046 . #xD7F1) - (#x6047 . #x8FBDDF) - (#x6048 . #x8FBDE0) - (#x6049 . #x8FBDE1) - (#x604A . #xD7F0) - (#x604B . #xCEF8) - (#x604C . #x8FBDE2) - (#x604D . #xD7F2) - (#x6050 . #xB6B2) - (#x6051 . #x8FBDE3) - (#x6052 . #xB9B1) - (#x6054 . #x8FBDE4) - (#x6055 . #xBDFA) - (#x6056 . #x8FBDE5) - (#x6057 . #x8FBDE6) - (#x6059 . #xD7F9) - (#x605A . #xD7EB) - (#x605D . #x8FBDE7) - (#x605F . #xD7EF) - (#x6060 . #xD7DF) - (#x6061 . #x8FBDE8) - (#x6062 . #xB2FA) - (#x6063 . #xD7F3) - (#x6064 . #xD7F5) - (#x6065 . #xC3D1) - (#x6067 . #x8FBDE9) - (#x6068 . #xBAA8) - (#x6069 . #xB2B8) - (#x606A . #xD7ED) - (#x606B . #xD7F8) - (#x606C . #xD7F7) - (#x606D . #xB6B3) - (#x606F . #xC2A9) - (#x6070 . #xB3E6) - (#x6071 . #x8FBDEA) - (#x6075 . #xB7C3) - (#x6077 . #xD7EE) - (#x607E . #x8FBDEB) - (#x607F . #x8FBDEC) - (#x6081 . #xD7FA) - (#x6082 . #x8FBDED) - (#x6083 . #xD7FD) - (#x6084 . #xD8A1) - (#x6086 . #x8FBDEE) - (#x6088 . #x8FBDEF) - (#x6089 . #xBCBD) - (#x608A . #x8FBDF0) - (#x608B . #xD8A7) - (#x608C . #xC4F0) - (#x608D . #xD7FB) - (#x608E . #x8FBDF1) - (#x6091 . #x8FBDF2) - (#x6092 . #xD8A5) - (#x6093 . #x8FBDF3) - (#x6094 . #xB2F9) - (#x6095 . #x8FBDF4) - (#x6096 . #xD8A3) - (#x6097 . #xD8A4) - (#x6098 . #x8FBDF5) - (#x609A . #xD7FE) - (#x609B . #xD8A2) - (#x609D . #x8FBDF6) - (#x609E . #x8FBDF7) - (#x609F . #xB8E7) - (#x60A0 . #xCDAA) - (#x60A2 . #x8FBDF8) - (#x60A3 . #xB4B5) - (#x60A4 . #x8FBDF9) - (#x60A5 . #x8FBDFA) - (#x60A6 . #xB1D9) - (#x60A7 . #xD8A6) - (#x60A8 . #x8FBDFB) - (#x60A9 . #xC7BA) - (#x60AA . #xB0AD) - (#x60B0 . #x8FBDFC) - (#x60B1 . #x8FBDFD) - (#x60B2 . #xC8E1) - (#x60B3 . #xD7DC) - (#x60B4 . #xD8AC) - (#x60B5 . #xD8B0) - (#x60B6 . #xCCE5) - (#x60B7 . #x8FBDFE) - (#x60B8 . #xD8A9) - (#x60BB . #x8FBEA1) - (#x60BC . #xC5E9) - (#x60BD . #xD8AE) - (#x60BE . #x8FBEA2) - (#x60C2 . #x8FBEA3) - (#x60C4 . #x8FBEA4) - (#x60C5 . #xBEF0) - (#x60C6 . #xD8AF) - (#x60C7 . #xC6D7) - (#x60C8 . #x8FBEA5) - (#x60C9 . #x8FBEA6) - (#x60CA . #x8FBEA7) - (#x60CB . #x8FBEA8) - (#x60CE . #x8FBEA9) - (#x60CF . #x8FBEAA) - (#x60D1 . #xCFC7) - (#x60D3 . #xD8AB) - (#x60D4 . #x8FBEAB) - (#x60D5 . #x8FBEAC) - (#x60D8 . #xD8B1) - (#x60D9 . #x8FBEAD) - (#x60DA . #xB9FB) - (#x60DB . #x8FBEAE) - (#x60DC . #xC0CB) - (#x60DD . #x8FBEAF) - (#x60DE . #x8FBEB0) - (#x60DF . #xB0D4) - (#x60E0 . #xD8AA) - (#x60E1 . #xD8A8) - (#x60E2 . #x8FBEB1) - (#x60E3 . #xC1DA) - (#x60E5 . #x8FBEB2) - (#x60E7 . #xD7FC) - (#x60E8 . #xBBB4) - (#x60F0 . #xC2C6) - (#x60F1 . #xD8BD) - (#x60F2 . #x8FBEB3) - (#x60F3 . #xC1DB) - (#x60F4 . #xD8B8) - (#x60F5 . #x8FBEB4) - (#x60F6 . #xD8B5) - (#x60F7 . #xD8B6) - (#x60F8 . #x8FBEB5) - (#x60F9 . #xBCE6) - (#x60FA . #xD8B9) - (#x60FB . #xD8BC) - (#x60FC . #x8FBEB6) - (#x60FD . #x8FBEB7) - (#x6100 . #xD8B7) - (#x6101 . #xBDA5) - (#x6102 . #x8FBEB8) - (#x6103 . #xD8BA) - (#x6106 . #xD8B4) - (#x6107 . #x8FBEB9) - (#x6108 . #xCCFC) - (#x6109 . #xCCFB) - (#x610A . #x8FBEBA) - (#x610C . #x8FBEBB) - (#x610D . #xD8BE) - (#x610E . #xD8BF) - (#x610F . #xB0D5) - (#x6110 . #x8FBEBC) - (#x6111 . #x8FBEBD) - (#x6112 . #x8FBEBE) - (#x6113 . #x8FBEBF) - (#x6114 . #x8FBEC0) - (#x6115 . #xD8B3) - (#x6116 . #x8FBEC1) - (#x6117 . #x8FBEC2) - (#x6119 . #x8FBEC3) - (#x611A . #xB6F2) - (#x611B . #xB0A6) - (#x611C . #x8FBEC4) - (#x611E . #x8FBEC5) - (#x611F . #xB4B6) - (#x6121 . #xD8BB) - (#x6122 . #x8FBEC6) - (#x6127 . #xD8C3) - (#x6128 . #xD8C2) - (#x612A . #x8FBEC7) - (#x612B . #x8FBEC8) - (#x612C . #xD8C7) - (#x6130 . #x8FBEC9) - (#x6131 . #x8FBECA) - (#x6134 . #xD8C8) - (#x6135 . #x8FBECB) - (#x6136 . #x8FBECC) - (#x6137 . #x8FBECD) - (#x6139 . #x8FBECE) - (#x613C . #xD8C6) - (#x613D . #xD8C9) - (#x613E . #xD8C1) - (#x613F . #xD8C5) - (#x6141 . #x8FBECF) - (#x6142 . #xD8CA) - (#x6144 . #xD8CB) - (#x6145 . #x8FBED0) - (#x6146 . #x8FBED1) - (#x6147 . #xD8C0) - (#x6148 . #xBBFC) - (#x6149 . #x8FBED2) - (#x614A . #xD8C4) - (#x614B . #xC2D6) - (#x614C . #xB9B2) - (#x614D . #xD8B2) - (#x614E . #xBFB5) - (#x6153 . #xD8D8) - (#x6155 . #xCAE9) - (#x6158 . #xD8CE) - (#x6159 . #xD8CF) - (#x615A . #xD8D0) - (#x615D . #xD8D7) - (#x615E . #x8FBED3) - (#x615F . #xD8D6) - (#x6160 . #x8FBED4) - (#x6162 . #xCBFD) - (#x6163 . #xB4B7) - (#x6165 . #xD8D4) - (#x6167 . #xB7C5) - (#x6168 . #xB3B4) - (#x616B . #xD8D1) - (#x616C . #x8FBED5) - (#x616E . #xCEB8) - (#x616F . #xD8D3) - (#x6170 . #xB0D6) - (#x6171 . #xD8D5) - (#x6172 . #x8FBED6) - (#x6173 . #xD8CC) - (#x6174 . #xD8D2) - (#x6175 . #xD8D9) - (#x6176 . #xB7C4) - (#x6177 . #xD8CD) - (#x6178 . #x8FBED7) - (#x617B . #x8FBED8) - (#x617C . #x8FBED9) - (#x617E . #xCDDD) - (#x617F . #x8FBEDA) - (#x6180 . #x8FBEDB) - (#x6181 . #x8FBEDC) - (#x6182 . #xCDAB) - (#x6183 . #x8FBEDD) - (#x6184 . #x8FBEDE) - (#x6187 . #xD8DC) - (#x618A . #xD8E0) - (#x618B . #x8FBEDF) - (#x618D . #x8FBEE0) - (#x618E . #xC1FE) - (#x6190 . #xCEF9) - (#x6191 . #xD8E1) - (#x6192 . #x8FBEE1) - (#x6193 . #x8FBEE2) - (#x6194 . #xD8DE) - (#x6196 . #xD8DB) - (#x6197 . #x8FBEE3) - (#x6198 . #x8FBEE4) - (#x6199 . #xD8DA) - (#x619A . #xD8DF) - (#x619C . #x8FBEE5) - (#x619D . #x8FBEE6) - (#x619F . #x8FBEE7) - (#x61A0 . #x8FBEE8) - (#x61A4 . #xCAB0) - (#x61A5 . #x8FBEE9) - (#x61A7 . #xC6B4) - (#x61A8 . #x8FBEEA) - (#x61A9 . #xB7C6) - (#x61AA . #x8FBEEB) - (#x61AB . #xD8E2) - (#x61AC . #xD8DD) - (#x61AD . #x8FBEEC) - (#x61AE . #xD8E3) - (#x61B2 . #xB7FB) - (#x61B6 . #xB2B1) - (#x61B8 . #x8FBEED) - (#x61B9 . #x8FBEEE) - (#x61BA . #xD8EB) - (#x61BC . #x8FBEEF) - (#x61BE . #xB4B8) - (#x61C0 . #x8FBEF0) - (#x61C1 . #x8FBEF1) - (#x61C2 . #x8FBEF2) - (#x61C3 . #xD8E9) - (#x61C6 . #xD8EA) - (#x61C7 . #xBAA9) - (#x61C8 . #xD8E8) - (#x61C9 . #xD8E6) - (#x61CA . #xD8E5) - (#x61CB . #xD8EC) - (#x61CC . #xD8E4) - (#x61CD . #xD8EE) - (#x61CE . #x8FBEF3) - (#x61CF . #x8FBEF4) - (#x61D0 . #xB2FB) - (#x61D5 . #x8FBEF5) - (#x61DC . #x8FBEF6) - (#x61DD . #x8FBEF7) - (#x61DE . #x8FBEF8) - (#x61DF . #x8FBEF9) - (#x61E1 . #x8FBEFA) - (#x61E2 . #x8FBEFB) - (#x61E3 . #xD8F0) - (#x61E5 . #x8FBEFE) - (#x61E6 . #xD8EF) - (#x61E7 . #x8FBEFC) - (#x61E9 . #x8FBEFD) - (#x61EC . #x8FBFA1) - (#x61ED . #x8FBFA2) - (#x61EF . #x8FBFA3) - (#x61F2 . #xC4A8) - (#x61F4 . #xD8F3) - (#x61F6 . #xD8F1) - (#x61F7 . #xD8E7) - (#x61F8 . #xB7FC) - (#x61FA . #xD8F2) - (#x61FC . #xD8F6) - (#x61FD . #xD8F5) - (#x61FE . #xD8F7) - (#x61FF . #xD8F4) - (#x6200 . #xD8F8) - (#x6201 . #x8FBFA4) - (#x6203 . #x8FBFA5) - (#x6204 . #x8FBFA6) - (#x6207 . #x8FBFA7) - (#x6208 . #xD8F9) - (#x6209 . #xD8FA) - (#x620A . #xCAEA) - (#x620C . #xD8FC) - (#x620D . #xD8FB) - (#x620E . #xBDBF) - (#x6210 . #xC0AE) - (#x6211 . #xB2E6) - (#x6212 . #xB2FC) - (#x6213 . #x8FBFA8) - (#x6214 . #xD8FD) - (#x6215 . #x8FBFA9) - (#x6216 . #xB0BF) - (#x621A . #xC0CC) - (#x621B . #xD8FE) - (#x621C . #x8FBFAA) - (#x621D . #xECC3) - (#x621E . #xD9A1) - (#x621F . #xB7E1) - (#x6220 . #x8FBFAB) - (#x6221 . #xD9A2) - (#x6222 . #x8FBFAC) - (#x6223 . #x8FBFAD) - (#x6226 . #xC0EF) - (#x6227 . #x8FBFAE) - (#x6229 . #x8FBFAF) - (#x622A . #xD9A3) - (#x622B . #x8FBFB0) - (#x622E . #xD9A4) - (#x622F . #xB5BA) - (#x6230 . #xD9A5) - (#x6232 . #xD9A6) - (#x6233 . #xD9A7) - (#x6234 . #xC2D7) - (#x6238 . #xB8CD) - (#x6239 . #x8FBFB1) - (#x623B . #xCCE1) - (#x623D . #x8FBFB2) - (#x623F . #xCBBC) - (#x6240 . #xBDEA) - (#x6241 . #xD9A8) - (#x6242 . #x8FBFB3) - (#x6243 . #x8FBFB4) - (#x6244 . #x8FBFB5) - (#x6246 . #x8FBFB6) - (#x6247 . #xC0F0) - (#x6248 . #xEEBD) - (#x6249 . #xC8E2) - (#x624B . #xBCEA) - (#x624C . #x8FBFB7) - (#x624D . #xBACD) - (#x624E . #xD9A9) - (#x6250 . #x8FBFB8) - (#x6251 . #x8FBFB9) - (#x6252 . #x8FBFBA) - (#x6253 . #xC2C7) - (#x6254 . #x8FBFBB) - (#x6255 . #xCAA7) - (#x6256 . #x8FBFBC) - (#x6258 . #xC2F1) - (#x625A . #x8FBFBD) - (#x625B . #xD9AC) - (#x625C . #x8FBFBE) - (#x625E . #xD9AA) - (#x6260 . #xD9AD) - (#x6263 . #xD9AB) - (#x6264 . #x8FBFBF) - (#x6268 . #xD9AE) - (#x626D . #x8FBFC0) - (#x626E . #xCAB1) - (#x626F . #x8FBFC1) - (#x6271 . #xB0B7) - (#x6273 . #x8FBFC2) - (#x6276 . #xC9DE) - (#x6279 . #xC8E3) - (#x627A . #x8FBFC3) - (#x627C . #xD9AF) - (#x627D . #x8FBFC4) - (#x627E . #xD9B2) - (#x627F . #xBEB5) - (#x6280 . #xB5BB) - (#x6282 . #xD9B0) - (#x6283 . #xD9B7) - (#x6284 . #xBEB6) - (#x6289 . #xD9B1) - (#x628A . #xC7C4) - (#x628D . #x8FBFC5) - (#x628E . #x8FBFC6) - (#x628F . #x8FBFC7) - (#x6290 . #x8FBFC8) - (#x6291 . #xCDDE) - (#x6292 . #xD9B3) - (#x6293 . #xD9B4) - (#x6294 . #xD9B8) - (#x6295 . #xC5EA) - (#x6296 . #xD9B5) - (#x6297 . #xB9B3) - (#x6298 . #xC0DE) - (#x629B . #xD9C6) - (#x629C . #xC8B4) - (#x629E . #xC2F2) - (#x62A6 . #x8FBFC9) - (#x62A8 . #x8FBFCA) - (#x62AB . #xC8E4) - (#x62AC . #xDAAD) - (#x62B1 . #xCAFA) - (#x62B3 . #x8FBFCB) - (#x62B5 . #xC4F1) - (#x62B6 . #x8FBFCC) - (#x62B7 . #x8FBFCD) - (#x62B9 . #xCBF5) - (#x62BA . #x8FBFCE) - (#x62BB . #xD9BB) - (#x62BC . #xB2A1) - (#x62BD . #xC3EA) - (#x62BE . #x8FBFCF) - (#x62BF . #x8FBFD0) - (#x62C2 . #xD9C4) - (#x62C4 . #x8FBFD1) - (#x62C5 . #xC3B4) - (#x62C6 . #xD9BE) - (#x62C7 . #xD9C5) - (#x62C8 . #xD9C0) - (#x62C9 . #xD9C7) - (#x62CA . #xD9C3) - (#x62CC . #xD9C2) - (#x62CD . #xC7EF) - (#x62CE . #x8FBFD2) - (#x62CF . #xD9BC) - (#x62D0 . #xB2FD) - (#x62D1 . #xD9BA) - (#x62D2 . #xB5F1) - (#x62D3 . #xC2F3) - (#x62D4 . #xD9B6) - (#x62D5 . #x8FBFD3) - (#x62D6 . #x8FBFD4) - (#x62D7 . #xD9B9) - (#x62D8 . #xB9B4) - (#x62D9 . #xC0DB) - (#x62DA . #x8FBFD5) - (#x62DB . #xBEB7) - (#x62DC . #xD9C1) - (#x62DD . #xC7D2) - (#x62E0 . #xB5F2) - (#x62E1 . #xB3C8) - (#x62EA . #x8FBFD6) - (#x62EC . #xB3E7) - (#x62ED . #xBFA1) - (#x62EE . #xD9C9) - (#x62EF . #xD9CE) - (#x62F1 . #xD9CA) - (#x62F2 . #x8FBFD7) - (#x62F3 . #xB7FD) - (#x62F4 . #x8FBFD8) - (#x62F5 . #xD9CF) - (#x62F6 . #xBBA2) - (#x62F7 . #xB9E9) - (#x62FC . #x8FBFD9) - (#x62FD . #x8FBFDA) - (#x62FE . #xBDA6) - (#x62FF . #xD9BD) - (#x6301 . #xBBFD) - (#x6302 . #xD9CC) - (#x6303 . #x8FBFDB) - (#x6304 . #x8FBFDC) - (#x6307 . #xBBD8) - (#x6308 . #xD9CD) - (#x6309 . #xB0C4) - (#x630A . #x8FBFDD) - (#x630B . #x8FBFDE) - (#x630C . #xD9C8) - (#x630D . #x8FBFDF) - (#x6310 . #x8FBFE0) - (#x6311 . #xC4A9) - (#x6313 . #x8FBFE1) - (#x6316 . #x8FBFE2) - (#x6318 . #x8FBFE3) - (#x6319 . #xB5F3) - (#x631F . #xB6B4) - (#x6327 . #xD9CB) - (#x6328 . #xB0A7) - (#x6329 . #x8FBFE4) - (#x632A . #x8FBFE5) - (#x632B . #xBAC3) - (#x632D . #x8FBFE6) - (#x632F . #xBFB6) - (#x6335 . #x8FBFE7) - (#x6336 . #x8FBFE8) - (#x6339 . #x8FBFE9) - (#x633A . #xC4F2) - (#x633C . #x8FBFEA) - (#x633D . #xC8D4) - (#x633E . #xD9D1) - (#x633F . #xC1DE) - (#x6341 . #x8FBFEB) - (#x6342 . #x8FBFEC) - (#x6343 . #x8FBFED) - (#x6344 . #x8FBFEE) - (#x6346 . #x8FBFEF) - (#x6349 . #xC2AA) - (#x634A . #x8FBFF0) - (#x634B . #x8FBFF1) - (#x634C . #xBBAB) - (#x634D . #xD9D2) - (#x634E . #x8FBFF2) - (#x634F . #xD9D4) - (#x6350 . #xD9D0) - (#x6352 . #x8FBFF3) - (#x6353 . #x8FBFF4) - (#x6354 . #x8FBFF5) - (#x6355 . #xCAE1) - (#x6357 . #xC4BD) - (#x6358 . #x8FBFF6) - (#x635B . #x8FBFF7) - (#x635C . #xC1DC) - (#x6365 . #x8FBFF8) - (#x6366 . #x8FBFF9) - (#x6367 . #xCAFB) - (#x6368 . #xBCCE) - (#x6369 . #xD9E0) - (#x636B . #xD9DF) - (#x636C . #x8FBFFA) - (#x636D . #x8FBFFB) - (#x636E . #xBFF8) - (#x6371 . #x8FBFFC) - (#x6372 . #xB7FE) - (#x6374 . #x8FBFFD) - (#x6375 . #x8FBFFE) - (#x6376 . #xD9D9) - (#x6377 . #xBEB9) - (#x6378 . #x8FC0A1) - (#x637A . #xC6E8) - (#x637B . #xC7B1) - (#x637C . #x8FC0A2) - (#x637D . #x8FC0A3) - (#x637F . #x8FC0A4) - (#x6380 . #xD9D7) - (#x6382 . #x8FC0A5) - (#x6383 . #xC1DD) - (#x6384 . #x8FC0A6) - (#x6387 . #x8FC0A7) - (#x6388 . #xBCF8) - (#x6389 . #xD9DC) - (#x638A . #x8FC0A8) - (#x638C . #xBEB8) - (#x638E . #xD9D6) - (#x638F . #xD9DB) - (#x6390 . #x8FC0A9) - (#x6392 . #xC7D3) - (#x6394 . #x8FC0AA) - (#x6395 . #x8FC0AB) - (#x6396 . #xD9D5) - (#x6398 . #xB7A1) - (#x6399 . #x8FC0AC) - (#x639A . #x8FC0AD) - (#x639B . #xB3DD) - (#x639E . #x8FC0AE) - (#x639F . #xD9DD) - (#x63A0 . #xCEAB) - (#x63A1 . #xBACE) - (#x63A2 . #xC3B5) - (#x63A3 . #xD9DA) - (#x63A4 . #x8FC0AF) - (#x63A5 . #xC0DC) - (#x63A6 . #x8FC0B0) - (#x63A7 . #xB9B5) - (#x63A8 . #xBFE4) - (#x63A9 . #xB1E6) - (#x63AA . #xC1BC) - (#x63AB . #xD9D8) - (#x63AC . #xB5C5) - (#x63AD . #x8FC0B1) - (#x63AE . #x8FC0B2) - (#x63AF . #x8FC0B3) - (#x63B2 . #xB7C7) - (#x63B4 . #xC4CF) - (#x63B5 . #xD9DE) - (#x63BB . #xC1DF) - (#x63BD . #x8FC0B4) - (#x63BE . #xD9E1) - (#x63C0 . #xD9E3) - (#x63C1 . #x8FC0B5) - (#x63C3 . #xC2B7) - (#x63C4 . #xD9E9) - (#x63C5 . #x8FC0B6) - (#x63C6 . #xD9E4) - (#x63C8 . #x8FC0B7) - (#x63C9 . #xD9E6) - (#x63CE . #x8FC0B8) - (#x63CF . #xC9C1) - (#x63D0 . #xC4F3) - (#x63D1 . #x8FC0B9) - (#x63D2 . #xD9E7) - (#x63D3 . #x8FC0BA) - (#x63D4 . #x8FC0BB) - (#x63D5 . #x8FC0BC) - (#x63D6 . #xCDAC) - (#x63DA . #xCDC8) - (#x63DB . #xB4B9) - (#x63DC . #x8FC0BD) - (#x63E0 . #x8FC0BE) - (#x63E1 . #xB0AE) - (#x63E3 . #xD9E5) - (#x63E5 . #x8FC0BF) - (#x63E9 . #xD9E2) - (#x63EA . #x8FC0C0) - (#x63EC . #x8FC0C1) - (#x63EE . #xB4F8) - (#x63F2 . #x8FC0C2) - (#x63F3 . #x8FC0C3) - (#x63F4 . #xB1E7) - (#x63F5 . #x8FC0C4) - (#x63F6 . #xD9E8) - (#x63F8 . #x8FC0C5) - (#x63F9 . #x8FC0C6) - (#x63FA . #xCDC9) - (#x6406 . #xD9EC) - (#x6409 . #x8FC0C7) - (#x640A . #x8FC0C8) - (#x640D . #xC2BB) - (#x640F . #xD9F3) - (#x6410 . #x8FC0C9) - (#x6412 . #x8FC0CA) - (#x6413 . #xD9ED) - (#x6414 . #x8FC0CB) - (#x6416 . #xD9EA) - (#x6417 . #xD9F1) - (#x6418 . #x8FC0CC) - (#x641C . #xD9D3) - (#x641E . #x8FC0CD) - (#x6420 . #x8FC0CE) - (#x6422 . #x8FC0CF) - (#x6424 . #x8FC0D0) - (#x6425 . #x8FC0D1) - (#x6426 . #xD9EE) - (#x6428 . #xD9F2) - (#x6429 . #x8FC0D2) - (#x642A . #x8FC0D3) - (#x642C . #xC8C2) - (#x642D . #xC5EB) - (#x642F . #x8FC0D4) - (#x6430 . #x8FC0D5) - (#x6434 . #xD9EB) - (#x6435 . #x8FC0D6) - (#x6436 . #xD9EF) - (#x643A . #xB7C8) - (#x643D . #x8FC0D7) - (#x643E . #xBAF1) - (#x643F . #x8FC0D8) - (#x6442 . #xC0DD) - (#x644B . #x8FC0D9) - (#x644E . #xD9F7) - (#x644F . #x8FC0DA) - (#x6451 . #x8FC0DB) - (#x6452 . #x8FC0DC) - (#x6453 . #x8FC0DD) - (#x6454 . #x8FC0DE) - (#x6458 . #xC5A6) - (#x645A . #x8FC0DF) - (#x645B . #x8FC0E0) - (#x645C . #x8FC0E1) - (#x645D . #x8FC0E2) - (#x645F . #x8FC0E3) - (#x6460 . #x8FC0E4) - (#x6461 . #x8FC0E5) - (#x6463 . #x8FC0E6) - (#x6467 . #xD9F4) - (#x6469 . #xCBE0) - (#x646D . #x8FC0E7) - (#x646F . #xD9F5) - (#x6473 . #x8FC0E8) - (#x6474 . #x8FC0E9) - (#x6476 . #xD9F6) - (#x6478 . #xCCCE) - (#x647A . #xC0A2) - (#x647B . #x8FC0EA) - (#x647D . #x8FC0EB) - (#x6483 . #xB7E2) - (#x6485 . #x8FC0EC) - (#x6487 . #x8FC0ED) - (#x6488 . #xD9FD) - (#x648F . #x8FC0EE) - (#x6490 . #x8FC0EF) - (#x6491 . #x8FC0F0) - (#x6492 . #xBBB5) - (#x6493 . #xD9FA) - (#x6495 . #xD9F9) - (#x6498 . #x8FC0F1) - (#x6499 . #x8FC0F2) - (#x649A . #xC7B2) - (#x649B . #x8FC0F3) - (#x649D . #x8FC0F4) - (#x649E . #xC6B5) - (#x649F . #x8FC0F5) - (#x64A1 . #x8FC0F6) - (#x64A3 . #x8FC0F7) - (#x64A4 . #xC5B1) - (#x64A5 . #xD9FB) - (#x64A6 . #x8FC0F8) - (#x64A8 . #x8FC0F9) - (#x64A9 . #xD9FC) - (#x64AB . #xC9EF) - (#x64AC . #x8FC0FA) - (#x64AD . #xC7C5) - (#x64AE . #xBBA3) - (#x64B0 . #xC0F1) - (#x64B2 . #xCBD0) - (#x64B3 . #x8FC0FB) - (#x64B9 . #xB3C9) - (#x64BB . #xDAA5) - (#x64BC . #xD9FE) - (#x64BD . #x8FC0FC) - (#x64BE . #x8FC0FD) - (#x64BF . #x8FC0FE) - (#x64C1 . #xCDCA) - (#x64C2 . #xDAA7) - (#x64C4 . #x8FC1A1) - (#x64C5 . #xDAA3) - (#x64C7 . #xDAA4) - (#x64C9 . #x8FC1A2) - (#x64CA . #x8FC1A3) - (#x64CB . #x8FC1A4) - (#x64CC . #x8FC1A5) - (#x64CD . #xC1E0) - (#x64CE . #x8FC1A6) - (#x64D0 . #x8FC1A7) - (#x64D1 . #x8FC1A8) - (#x64D2 . #xDAA2) - (#x64D4 . #xD9BF) - (#x64D5 . #x8FC1A9) - (#x64D7 . #x8FC1AA) - (#x64D8 . #xDAA6) - (#x64DA . #xDAA1) - (#x64E0 . #xDAAB) - (#x64E1 . #xDAAC) - (#x64E2 . #xC5A7) - (#x64E3 . #xDAAE) - (#x64E4 . #x8FC1AB) - (#x64E5 . #x8FC1AC) - (#x64E6 . #xBBA4) - (#x64E7 . #xDAA9) - (#x64E9 . #x8FC1AD) - (#x64EA . #x8FC1AE) - (#x64EC . #xB5BC) - (#x64ED . #x8FC1AF) - (#x64EF . #xDAAF) - (#x64F0 . #x8FC1B0) - (#x64F1 . #xDAA8) - (#x64F2 . #xDAB3) - (#x64F4 . #xDAB2) - (#x64F5 . #x8FC1B1) - (#x64F6 . #xDAB1) - (#x64F7 . #x8FC1B2) - (#x64FA . #xDAB4) - (#x64FB . #x8FC1B3) - (#x64FD . #xDAB6) - (#x64FE . #xBEF1) - (#x64FF . #x8FC1B4) - (#x6500 . #xDAB5) - (#x6501 . #x8FC1B5) - (#x6504 . #x8FC1B6) - (#x6505 . #xDAB9) - (#x6508 . #x8FC1B7) - (#x6509 . #x8FC1B8) - (#x650A . #x8FC1B9) - (#x650F . #x8FC1BA) - (#x6513 . #x8FC1BB) - (#x6514 . #x8FC1BC) - (#x6516 . #x8FC1BD) - (#x6518 . #xDAB7) - (#x6519 . #x8FC1BE) - (#x651B . #x8FC1BF) - (#x651C . #xDAB8) - (#x651D . #xD9F0) - (#x651E . #x8FC1C0) - (#x651F . #x8FC1C1) - (#x6522 . #x8FC1C2) - (#x6523 . #xDABB) - (#x6524 . #xDABA) - (#x6526 . #x8FC1C3) - (#x6529 . #x8FC1C4) - (#x652A . #xD9F8) - (#x652B . #xDABC) - (#x652C . #xDAB0) - (#x652E . #x8FC1C5) - (#x652F . #xBBD9) - (#x6531 . #x8FC1C6) - (#x6534 . #xDABD) - (#x6535 . #xDABE) - (#x6536 . #xDAC0) - (#x6537 . #xDABF) - (#x6538 . #xDAC1) - (#x6539 . #xB2FE) - (#x653A . #x8FC1C7) - (#x653B . #xB9B6) - (#x653C . #x8FC1C8) - (#x653D . #x8FC1C9) - (#x653E . #xCAFC) - (#x653F . #xC0AF) - (#x6543 . #x8FC1CA) - (#x6545 . #xB8CE) - (#x6547 . #x8FC1CB) - (#x6548 . #xDAC3) - (#x6549 . #x8FC1CC) - (#x654D . #xDAC6) - (#x654F . #xC9D2) - (#x6550 . #x8FC1CD) - (#x6551 . #xB5DF) - (#x6552 . #x8FC1CE) - (#x6554 . #x8FC1CF) - (#x6555 . #xDAC5) - (#x6556 . #xDAC4) - (#x6557 . #xC7D4) - (#x6558 . #xDAC7) - (#x6559 . #xB6B5) - (#x655D . #xDAC9) - (#x655E . #xDAC8) - (#x655F . #x8FC1D0) - (#x6560 . #x8FC1D1) - (#x6562 . #xB4BA) - (#x6563 . #xBBB6) - (#x6566 . #xC6D8) - (#x6567 . #x8FC1D2) - (#x656B . #x8FC1D3) - (#x656C . #xB7C9) - (#x6570 . #xBFF4) - (#x6572 . #xDACA) - (#x6574 . #xC0B0) - (#x6575 . #xC5A8) - (#x6577 . #xC9DF) - (#x6578 . #xDACB) - (#x657A . #x8FC1D4) - (#x657D . #x8FC1D5) - (#x6581 . #x8FC1D6) - (#x6582 . #xDACC) - (#x6583 . #xDACD) - (#x6585 . #x8FC1D7) - (#x6587 . #xCAB8) - (#x6588 . #xD5DD) - (#x6589 . #xC0C6) - (#x658A . #x8FC1D8) - (#x658C . #xC9CC) - (#x658E . #xBAD8) - (#x6590 . #xC8E5) - (#x6591 . #xC8C3) - (#x6592 . #x8FC1D9) - (#x6595 . #x8FC1DA) - (#x6597 . #xC5CD) - (#x6598 . #x8FC1DB) - (#x6599 . #xCEC1) - (#x659B . #xDACF) - (#x659C . #xBCD0) - (#x659D . #x8FC1DC) - (#x659F . #xDAD0) - (#x65A0 . #x8FC1DD) - (#x65A1 . #xB0B6) - (#x65A3 . #x8FC1DE) - (#x65A4 . #xB6D4) - (#x65A5 . #xC0CD) - (#x65A6 . #x8FC1DF) - (#x65A7 . #xC9E0) - (#x65AB . #xDAD1) - (#x65AC . #xBBC2) - (#x65AD . #xC3C7) - (#x65AE . #x8FC1E0) - (#x65AF . #xBBDB) - (#x65B0 . #xBFB7) - (#x65B2 . #x8FC1E1) - (#x65B3 . #x8FC1E2) - (#x65B4 . #x8FC1E3) - (#x65B7 . #xDAD2) - (#x65B9 . #xCAFD) - (#x65BC . #xB1F7) - (#x65BD . #xBBDC) - (#x65BF . #x8FC1E4) - (#x65C1 . #xDAD5) - (#x65C2 . #x8FC1E5) - (#x65C3 . #xDAD3) - (#x65C4 . #xDAD6) - (#x65C5 . #xCEB9) - (#x65C6 . #xDAD4) - (#x65C8 . #x8FC1E6) - (#x65C9 . #x8FC1E7) - (#x65CB . #xC0FB) - (#x65CC . #xDAD7) - (#x65CE . #x8FC1E8) - (#x65CF . #xC2B2) - (#x65D0 . #x8FC1E9) - (#x65D2 . #xDAD8) - (#x65D4 . #x8FC1EA) - (#x65D6 . #x8FC1EB) - (#x65D7 . #xB4FA) - (#x65D8 . #x8FC1EC) - (#x65D9 . #xDADA) - (#x65DB . #xDAD9) - (#x65DF . #x8FC1ED) - (#x65E0 . #xDADB) - (#x65E1 . #xDADC) - (#x65E2 . #xB4FB) - (#x65E5 . #xC6FC) - (#x65E6 . #xC3B6) - (#x65E7 . #xB5EC) - (#x65E8 . #xBBDD) - (#x65E9 . #xC1E1) - (#x65EC . #xBDDC) - (#x65ED . #xB0B0) - (#x65F0 . #x8FC1EE) - (#x65F1 . #xDADD) - (#x65F2 . #x8FC1EF) - (#x65F4 . #x8FC1F0) - (#x65F5 . #x8FC1F1) - (#x65F9 . #x8FC1F2) - (#x65FA . #xB2A2) - (#x65FB . #xDAE1) - (#x65FE . #x8FC1F3) - (#x65FF . #x8FC1F4) - (#x6600 . #x8FC1F5) - (#x6602 . #xB9B7) - (#x6603 . #xDAE0) - (#x6604 . #x8FC1F6) - (#x6606 . #xBAAB) - (#x6607 . #xBEBA) - (#x6608 . #x8FC1F7) - (#x6609 . #x8FC1F8) - (#x660A . #xDADF) - (#x660C . #xBEBB) - (#x660D . #x8FC1F9) - (#x660E . #xCCC0) - (#x660F . #xBAAA) - (#x6611 . #x8FC1FA) - (#x6612 . #x8FC1FB) - (#x6613 . #xB0D7) - (#x6614 . #xC0CE) - (#x6615 . #x8FC1FC) - (#x6616 . #x8FC1FD) - (#x661C . #xDAE6) - (#x661D . #x8FC1FE) - (#x661E . #x8FC2A1) - (#x661F . #xC0B1) - (#x6620 . #xB1C7) - (#x6621 . #x8FC2A2) - (#x6622 . #x8FC2A3) - (#x6623 . #x8FC2A4) - (#x6624 . #x8FC2A5) - (#x6625 . #xBDD5) - (#x6626 . #x8FC2A6) - (#x6627 . #xCBE6) - (#x6628 . #xBAF2) - (#x6629 . #x8FC2A7) - (#x662A . #x8FC2A8) - (#x662B . #x8FC2A9) - (#x662C . #x8FC2AA) - (#x662D . #xBEBC) - (#x662E . #x8FC2AB) - (#x662F . #xC0A7) - (#x6630 . #x8FC2AC) - (#x6631 . #x8FC2AD) - (#x6633 . #x8FC2AE) - (#x6634 . #xDAE5) - (#x6635 . #xDAE3) - (#x6636 . #xDAE4) - (#x6637 . #x8FC2B0) - (#x6639 . #x8FC2AF) - (#x663C . #xC3EB) - (#x663F . #xDBA6) - (#x6640 . #x8FC2B1) - (#x6641 . #xDAEA) - (#x6642 . #xBBFE) - (#x6643 . #xB9B8) - (#x6644 . #xDAE8) - (#x6645 . #x8FC2B2) - (#x6646 . #x8FC2B3) - (#x6649 . #xDAE9) - (#x664A . #x8FC2B4) - (#x664B . #xBFB8) - (#x664C . #x8FC2B5) - (#x664E . #x8FC2B7) - (#x664F . #xDAE7) - (#x6651 . #x8FC2B6) - (#x6652 . #xBBAF) - (#x6657 . #x8FC2B8) - (#x6658 . #x8FC2B9) - (#x6659 . #x8FC2BA) - (#x665B . #x8FC2BB) - (#x665C . #x8FC2BC) - (#x665D . #xDAEC) - (#x665E . #xDAEB) - (#x665F . #xDAF0) - (#x6660 . #x8FC2BD) - (#x6661 . #x8FC2BE) - (#x6662 . #xDAF1) - (#x6664 . #xDAED) - (#x6666 . #xB3A2) - (#x6667 . #xDAEE) - (#x6668 . #xDAEF) - (#x6669 . #xC8D5) - (#x666A . #x8FC2C0) - (#x666B . #x8FC2C1) - (#x666C . #x8FC2C2) - (#x666E . #xC9E1) - (#x666F . #xB7CA) - (#x6670 . #xDAF2) - (#x6673 . #x8FC2C4) - (#x6674 . #xC0B2) - (#x6675 . #x8FC2C5) - (#x6676 . #xBEBD) - (#x6677 . #x8FC2C7) - (#x6678 . #x8FC2C8) - (#x6679 . #x8FC2C9) - (#x667A . #xC3D2) - (#x667B . #x8FC2CA) - (#x667C . #x8FC2CC) - (#x667E . #x8FC2C3) - (#x667F . #x8FC2C6) - (#x6680 . #x8FC2CB) - (#x6681 . #xB6C7) - (#x6683 . #xDAF3) - (#x6684 . #xDAF7) - (#x6687 . #xB2CB) - (#x6688 . #xDAF4) - (#x6689 . #xDAF6) - (#x668B . #x8FC2CD) - (#x668C . #x8FC2CE) - (#x668D . #x8FC2CF) - (#x668E . #xDAF5) - (#x6690 . #x8FC2D0) - (#x6691 . #xBDEB) - (#x6692 . #x8FC2D1) - (#x6696 . #xC3C8) - (#x6697 . #xB0C5) - (#x6698 . #xDAF8) - (#x6699 . #x8FC2D2) - (#x669A . #x8FC2D3) - (#x669B . #x8FC2D4) - (#x669C . #x8FC2D5) - (#x669D . #xDAF9) - (#x669F . #x8FC2D6) - (#x66A0 . #x8FC2D7) - (#x66A2 . #xC4AA) - (#x66A4 . #x8FC2D8) - (#x66A6 . #xCEF1) - (#x66AB . #xBBC3) - (#x66AD . #x8FC2D9) - (#x66AE . #xCAEB) - (#x66B1 . #x8FC2DA) - (#x66B2 . #x8FC2DB) - (#x66B4 . #xCBBD) - (#x66B5 . #x8FC2DC) - (#x66B8 . #xDBA2) - (#x66B9 . #xDAFB) - (#x66BB . #x8FC2DD) - (#x66BC . #xDAFE) - (#x66BE . #xDAFD) - (#x66BF . #x8FC2DE) - (#x66C0 . #x8FC2DF) - (#x66C1 . #xDAFA) - (#x66C2 . #x8FC2E0) - (#x66C3 . #x8FC2E1) - (#x66C4 . #xDBA1) - (#x66C7 . #xC6DE) - (#x66C8 . #x8FC2E2) - (#x66C9 . #xDAFC) - (#x66CC . #x8FC2E3) - (#x66CE . #x8FC2E4) - (#x66CF . #x8FC2E5) - (#x66D4 . #x8FC2E6) - (#x66D6 . #xDBA3) - (#x66D9 . #xBDEC) - (#x66DA . #xDBA4) - (#x66DB . #x8FC2E7) - (#x66DC . #xCDCB) - (#x66DD . #xC7F8) - (#x66DF . #x8FC2E8) - (#x66E0 . #xDBA5) - (#x66E6 . #xDBA7) - (#x66E8 . #x8FC2E9) - (#x66E9 . #xDBA8) - (#x66EB . #x8FC2EA) - (#x66EC . #x8FC2EB) - (#x66EE . #x8FC2EC) - (#x66F0 . #xDBA9) - (#x66F2 . #xB6CA) - (#x66F3 . #xB1C8) - (#x66F4 . #xB9B9) - (#x66F5 . #xDBAA) - (#x66F7 . #xDBAB) - (#x66F8 . #xBDF1) - (#x66F9 . #xC1E2) - (#x66FA . #x8FC2ED) - (#x66FB . #x8FC2BF) - (#x66FC . #xD2D8) - (#x66FD . #xC1BE) - (#x66FE . #xC1BD) - (#x66FF . #xC2D8) - (#x6700 . #xBAC7) - (#x6703 . #xD0F2) - (#x6705 . #x8FC2EE) - (#x6707 . #x8FC2EF) - (#x6708 . #xB7EE) - (#x6709 . #xCDAD) - (#x670B . #xCAFE) - (#x670D . #xC9FE) - (#x670E . #x8FC2F0) - (#x670F . #xDBAC) - (#x6713 . #x8FC2F1) - (#x6714 . #xBAF3) - (#x6715 . #xC4BF) - (#x6716 . #xDBAD) - (#x6717 . #xCFAF) - (#x6719 . #x8FC2F2) - (#x671B . #xCBBE) - (#x671C . #x8FC2F3) - (#x671D . #xC4AB) - (#x671E . #xDBAE) - (#x671F . #xB4FC) - (#x6720 . #x8FC2F4) - (#x6722 . #x8FC2F5) - (#x6726 . #xDBAF) - (#x6727 . #xDBB0) - (#x6728 . #xCCDA) - (#x672A . #xCCA4) - (#x672B . #xCBF6) - (#x672C . #xCBDC) - (#x672D . #xBBA5) - (#x672E . #xDBB2) - (#x6731 . #xBCEB) - (#x6733 . #x8FC2F6) - (#x6734 . #xCBD1) - (#x6736 . #xDBB4) - (#x6737 . #xDBB7) - (#x6738 . #xDBB6) - (#x673A . #xB4F9) - (#x673D . #xB5E0) - (#x673E . #x8FC2F7) - (#x673F . #xDBB3) - (#x6741 . #xDBB5) - (#x6745 . #x8FC2F8) - (#x6746 . #xDBB8) - (#x6747 . #x8FC2F9) - (#x6748 . #x8FC2FA) - (#x6749 . #xBFF9) - (#x674C . #x8FC2FB) - (#x674E . #xCDFB) - (#x674F . #xB0C9) - (#x6750 . #xBAE0) - (#x6751 . #xC2BC) - (#x6753 . #xBCDD) - (#x6754 . #x8FC2FC) - (#x6755 . #x8FC2FD) - (#x6756 . #xBEF3) - (#x6759 . #xDBBB) - (#x675C . #xC5CE) - (#x675D . #x8FC2FE) - (#x675E . #xDBB9) - (#x675F . #xC2AB) - (#x6760 . #xDBBA) - (#x6761 . #xBEF2) - (#x6762 . #xCCDD) - (#x6763 . #xDBBC) - (#x6764 . #xDBBD) - (#x6765 . #xCDE8) - (#x6766 . #x8FC3A1) - (#x676A . #xDBC2) - (#x676C . #x8FC3A2) - (#x676D . #xB9BA) - (#x676E . #x8FC3A3) - (#x676F . #xC7D5) - (#x6770 . #xDBBF) - (#x6771 . #xC5EC) - (#x6772 . #xDADE) - (#x6773 . #xDAE2) - (#x6774 . #x8FC3A4) - (#x6775 . #xB5CF) - (#x6776 . #x8FC3A5) - (#x6777 . #xC7C7) - (#x677B . #x8FC3A6) - (#x677C . #xDBC1) - (#x677E . #xBEBE) - (#x677F . #xC8C4) - (#x6781 . #x8FC3A7) - (#x6784 . #x8FC3A8) - (#x6785 . #xDBC7) - (#x6787 . #xC8FA) - (#x6789 . #xDBBE) - (#x678B . #xDBC4) - (#x678C . #xDBC3) - (#x678E . #x8FC3A9) - (#x678F . #x8FC3AA) - (#x6790 . #xC0CF) - (#x6791 . #x8FC3AB) - (#x6793 . #x8FC3AC) - (#x6795 . #xCBED) - (#x6796 . #x8FC3AD) - (#x6797 . #xCED3) - (#x6798 . #x8FC3AE) - (#x6799 . #x8FC3AF) - (#x679A . #xCBE7) - (#x679B . #x8FC3B0) - (#x679C . #xB2CC) - (#x679D . #xBBDE) - (#x67A0 . #xCFC8) - (#x67A1 . #xDBC6) - (#x67A2 . #xBFF5) - (#x67A6 . #xDBC5) - (#x67A9 . #xDBC0) - (#x67AF . #xB8CF) - (#x67B0 . #x8FC3B1) - (#x67B1 . #x8FC3B2) - (#x67B2 . #x8FC3B3) - (#x67B3 . #xDBCC) - (#x67B4 . #xDBCA) - (#x67B5 . #x8FC3B4) - (#x67B6 . #xB2CD) - (#x67B7 . #xDBC8) - (#x67B8 . #xDBCE) - (#x67B9 . #xDBD4) - (#x67BB . #x8FC3B5) - (#x67BC . #x8FC3B6) - (#x67BD . #x8FC3B7) - (#x67C0 . #x8FC3B9) - (#x67C1 . #xC2C8) - (#x67C2 . #x8FC3BA) - (#x67C3 . #x8FC3BB) - (#x67C4 . #xCAC1) - (#x67C5 . #x8FC3BC) - (#x67C6 . #xDBD6) - (#x67C8 . #x8FC3BD) - (#x67C9 . #x8FC3BE) - (#x67CA . #xC9A2) - (#x67CE . #xDBD5) - (#x67CF . #xC7F0) - (#x67D0 . #xCBBF) - (#x67D1 . #xB4BB) - (#x67D2 . #x8FC3BF) - (#x67D3 . #xC0F7) - (#x67D4 . #xBDC0) - (#x67D7 . #x8FC3C0) - (#x67D8 . #xC4D3) - (#x67D9 . #x8FC3C1) - (#x67DA . #xCDAE) - (#x67DC . #x8FC3C2) - (#x67DD . #xDBD1) - (#x67DE . #xDBD0) - (#x67E1 . #x8FC3C3) - (#x67E2 . #xDBD2) - (#x67E4 . #xDBCF) - (#x67E6 . #x8FC3C4) - (#x67E7 . #xDBD7) - (#x67E9 . #xDBCD) - (#x67EC . #xDBCB) - (#x67EE . #xDBD3) - (#x67EF . #xDBC9) - (#x67F0 . #x8FC3C5) - (#x67F1 . #xC3EC) - (#x67F2 . #x8FC3C6) - (#x67F3 . #xCCF8) - (#x67F4 . #xBCC6) - (#x67F5 . #xBAF4) - (#x67F6 . #x8FC3C7) - (#x67F7 . #x8FC3C8) - (#x67F9 . #x8FC3B8) - (#x67FB . #xBABA) - (#x67FE . #xCBEF) - (#x67FF . #xB3C1) - (#x6802 . #xC4CE) - (#x6803 . #xC6CA) - (#x6804 . #xB1C9) - (#x6813 . #xC0F2) - (#x6814 . #x8FC3CA) - (#x6816 . #xC0B4) - (#x6817 . #xB7AA) - (#x6819 . #x8FC3CB) - (#x681D . #x8FC3CC) - (#x681E . #xDBD9) - (#x681F . #x8FC3CD) - (#x6821 . #xB9BB) - (#x6822 . #xB3FC) - (#x6827 . #x8FC3CF) - (#x6828 . #x8FC3CE) - (#x6829 . #xDBDB) - (#x682A . #xB3F4) - (#x682B . #xDBE1) - (#x682C . #x8FC3D0) - (#x682D . #x8FC3D1) - (#x682F . #x8FC3D2) - (#x6830 . #x8FC3D3) - (#x6831 . #x8FC3D4) - (#x6832 . #xDBDE) - (#x6833 . #x8FC3D5) - (#x6834 . #xC0F3) - (#x6838 . #xB3CB) - (#x6839 . #xBAAC) - (#x683B . #x8FC3D6) - (#x683C . #xB3CA) - (#x683D . #xBACF) - (#x683F . #x8FC3D7) - (#x6840 . #xDBDC) - (#x6841 . #xB7E5) - (#x6842 . #xB7CB) - (#x6843 . #xC5ED) - (#x6844 . #x8FC3D8) - (#x6845 . #x8FC3D9) - (#x6846 . #xDBDA) - (#x6848 . #xB0C6) - (#x684A . #x8FC3DA) - (#x684C . #x8FC3DB) - (#x684D . #xDBDD) - (#x684E . #xDBDF) - (#x6850 . #xB6CD) - (#x6851 . #xB7AC) - (#x6852 . #x8FC3C9) - (#x6853 . #xB4BC) - (#x6854 . #xB5CB) - (#x6855 . #x8FC3DC) - (#x6857 . #x8FC3DD) - (#x6858 . #x8FC3DE) - (#x6859 . #xDBE2) - (#x685B . #x8FC3DF) - (#x685C . #xBAF9) - (#x685D . #xCBF1) - (#x685F . #xBBB7) - (#x6863 . #xDBE3) - (#x6867 . #xC9B0) - (#x686B . #x8FC3E0) - (#x686E . #x8FC3E1) - (#x686F . #x8FC3E2) - (#x6870 . #x8FC3E3) - (#x6871 . #x8FC3E4) - (#x6872 . #x8FC3E5) - (#x6874 . #xDBEF) - (#x6875 . #x8FC3E6) - (#x6876 . #xB2B3) - (#x6877 . #xDBE4) - (#x6879 . #x8FC3E7) - (#x687A . #x8FC3E8) - (#x687B . #x8FC3E9) - (#x687C . #x8FC3EA) - (#x687E . #xDBF5) - (#x687F . #xDBE5) - (#x6881 . #xCEC2) - (#x6882 . #x8FC3EB) - (#x6883 . #xDBEC) - (#x6884 . #x8FC3EC) - (#x6885 . #xC7DF) - (#x6886 . #x8FC3ED) - (#x6888 . #x8FC3EE) - (#x688D . #xDBF4) - (#x688F . #xDBE7) - (#x6893 . #xB0B4) - (#x6894 . #xDBE9) - (#x6896 . #x8FC3EF) - (#x6897 . #xB9BC) - (#x6898 . #x8FC3F0) - (#x689A . #x8FC3F1) - (#x689B . #xDBEB) - (#x689C . #x8FC3F2) - (#x689D . #xDBEA) - (#x689F . #xDBE6) - (#x68A0 . #xDBF1) - (#x68A1 . #x8FC3F3) - (#x68A2 . #xBEBF) - (#x68A3 . #x8FC3F4) - (#x68A5 . #x8FC3F5) - (#x68A6 . #xD4ED) - (#x68A7 . #xB8E8) - (#x68A8 . #xCDFC) - (#x68A9 . #x8FC3F6) - (#x68AA . #x8FC3F7) - (#x68AD . #xDBE8) - (#x68AE . #x8FC3F8) - (#x68AF . #xC4F4) - (#x68B0 . #xB3A3) - (#x68B1 . #xBAAD) - (#x68B2 . #x8FC3F9) - (#x68B3 . #xDBE0) - (#x68B5 . #xDBF0) - (#x68B6 . #xB3E1) - (#x68B9 . #xDBEE) - (#x68BA . #xDBF2) - (#x68BB . #x8FC3FA) - (#x68BC . #xC5EE) - (#x68C4 . #xB4FE) - (#x68C5 . #x8FC3FB) - (#x68C6 . #xDCB2) - (#x68C8 . #x8FC3FC) - (#x68C9 . #xCCC9) - (#x68CA . #xDBF7) - (#x68CB . #xB4FD) - (#x68CC . #x8FC3FD) - (#x68CD . #xDBFE) - (#x68CF . #x8FC3FE) - (#x68D0 . #x8FC4A1) - (#x68D1 . #x8FC4A2) - (#x68D2 . #xCBC0) - (#x68D3 . #x8FC4A3) - (#x68D4 . #xDCA1) - (#x68D5 . #xDCA3) - (#x68D6 . #x8FC4A4) - (#x68D7 . #xDCA7) - (#x68D8 . #xDBF9) - (#x68D9 . #x8FC4A5) - (#x68DA . #xC3AA) - (#x68DC . #x8FC4A6) - (#x68DD . #x8FC4A7) - (#x68DF . #xC5EF) - (#x68E0 . #xDCAB) - (#x68E1 . #xDBFC) - (#x68E3 . #xDCA8) - (#x68E5 . #x8FC4A8) - (#x68E7 . #xDCA2) - (#x68E8 . #x8FC4A9) - (#x68EA . #x8FC4AA) - (#x68EB . #x8FC4AB) - (#x68EC . #x8FC4AC) - (#x68ED . #x8FC4AD) - (#x68EE . #xBFB9) - (#x68EF . #xDCAC) - (#x68F0 . #x8FC4AE) - (#x68F1 . #x8FC4AF) - (#x68F2 . #xC0B3) - (#x68F5 . #x8FC4B0) - (#x68F6 . #x8FC4B1) - (#x68F9 . #xDCAA) - (#x68FA . #xB4BD) - (#x68FB . #x8FC4B2) - (#x68FC . #x8FC4B3) - (#x68FD . #x8FC4B4) - (#x6900 . #xCFD0) - (#x6901 . #xDBF6) - (#x6904 . #xDCA6) - (#x6905 . #xB0D8) - (#x6906 . #x8FC4B5) - (#x6908 . #xDBF8) - (#x6909 . #x8FC4B6) - (#x690A . #x8FC4B7) - (#x690B . #xCCBA) - (#x690C . #xDBFD) - (#x690D . #xBFA2) - (#x690E . #xC4C7) - (#x690F . #xDBF3) - (#x6910 . #x8FC4B8) - (#x6911 . #x8FC4B9) - (#x6912 . #xDCA5) - (#x6913 . #x8FC4BA) - (#x6916 . #x8FC4BB) - (#x6917 . #x8FC4BC) - (#x6919 . #xBFFA) - (#x691A . #xDCAF) - (#x691B . #xB3F1) - (#x691C . #xB8A1) - (#x6921 . #xDCB1) - (#x6922 . #xDBFA) - (#x6923 . #xDCB0) - (#x6925 . #xDCA9) - (#x6926 . #xDBFB) - (#x6928 . #xDCAD) - (#x692A . #xDCAE) - (#x6930 . #xDCBF) - (#x6931 . #x8FC4BD) - (#x6933 . #x8FC4BE) - (#x6934 . #xC6CE) - (#x6935 . #x8FC4BF) - (#x6936 . #xDCA4) - (#x6938 . #x8FC4C0) - (#x6939 . #xDCBB) - (#x693B . #x8FC4C1) - (#x693D . #xDCBD) - (#x693F . #xC4D8) - (#x6942 . #x8FC4C2) - (#x6945 . #x8FC4C3) - (#x6949 . #x8FC4C4) - (#x694A . #xCDCC) - (#x694E . #x8FC4C5) - (#x6953 . #xC9F6) - (#x6954 . #xDCB8) - (#x6955 . #xC2CA) - (#x6957 . #x8FC4C6) - (#x6959 . #xDCBE) - (#x695A . #xC1BF) - (#x695B . #x8FC4C7) - (#x695C . #xDCB5) - (#x695D . #xDCC2) - (#x695E . #xDCC1) - (#x6960 . #xC6EF) - (#x6961 . #xDCC0) - (#x6962 . #xC6EA) - (#x6963 . #x8FC4C8) - (#x6964 . #x8FC4C9) - (#x6965 . #x8FC4CA) - (#x6966 . #x8FC4CB) - (#x6968 . #x8FC4CC) - (#x6969 . #x8FC4CD) - (#x696A . #xDCC4) - (#x696B . #xDCB7) - (#x696C . #x8FC4CE) - (#x696D . #xB6C8) - (#x696E . #xDCBA) - (#x696F . #xBDDD) - (#x6970 . #x8FC4CF) - (#x6971 . #x8FC4D0) - (#x6972 . #x8FC4D1) - (#x6973 . #xC7E0) - (#x6974 . #xDCBC) - (#x6975 . #xB6CB) - (#x6977 . #xDCB4) - (#x6978 . #xDCB6) - (#x6979 . #xDCB3) - (#x697A . #x8FC4D2) - (#x697B . #x8FC4D3) - (#x697C . #xCFB0) - (#x697D . #xB3DA) - (#x697E . #xDCB9) - (#x697F . #x8FC4D4) - (#x6980 . #x8FC4D5) - (#x6981 . #xDCC3) - (#x6982 . #xB3B5) - (#x698A . #xBAE7) - (#x698D . #x8FC4D6) - (#x698E . #xB1DD) - (#x6991 . #xDCD4) - (#x6992 . #x8FC4D7) - (#x6994 . #xCFB1) - (#x6995 . #xDCD7) - (#x6996 . #x8FC4D8) - (#x6998 . #x8FC4D9) - (#x699B . #xBFBA) - (#x699C . #xDCD6) - (#x69A0 . #xDCD5) - (#x69A1 . #x8FC4DA) - (#x69A5 . #x8FC4DB) - (#x69A6 . #x8FC4DC) - (#x69A7 . #xDCD2) - (#x69A8 . #x8FC4DD) - (#x69AB . #x8FC4DE) - (#x69AD . #x8FC4DF) - (#x69AE . #xDCC6) - (#x69AF . #x8FC4E0) - (#x69B1 . #xDCE3) - (#x69B2 . #xDCC5) - (#x69B4 . #xDCD8) - (#x69B7 . #x8FC4E1) - (#x69B8 . #x8FC4E2) - (#x69BA . #x8FC4E3) - (#x69BB . #xDCD0) - (#x69BC . #x8FC4E4) - (#x69BE . #xDCCB) - (#x69BF . #xDCC8) - (#x69C1 . #xDCC9) - (#x69C3 . #xDCD1) - (#x69C5 . #x8FC4E5) - (#x69C7 . #xF4A2) - (#x69C8 . #x8FC4E6) - (#x69CA . #xDCCE) - (#x69CB . #xB9BD) - (#x69CC . #xC4C8) - (#x69CD . #xC1E4) - (#x69CE . #xDCCC) - (#x69D0 . #xDCC7) - (#x69D1 . #x8FC4E7) - (#x69D3 . #xDCCA) - (#x69D6 . #x8FC4E8) - (#x69D7 . #x8FC4E9) - (#x69D8 . #xCDCD) - (#x69D9 . #xCBEA) - (#x69DD . #xDCCF) - (#x69DE . #xDCD9) - (#x69E2 . #x8FC4EA) - (#x69E5 . #x8FC4EB) - (#x69E7 . #xDCE1) - (#x69E8 . #xDCDA) - (#x69EB . #xDCE7) - (#x69ED . #xDCE5) - (#x69EE . #x8FC4EC) - (#x69EF . #x8FC4ED) - (#x69F1 . #x8FC4EE) - (#x69F2 . #xDCE0) - (#x69F3 . #x8FC4EF) - (#x69F5 . #x8FC4F0) - (#x69F9 . #xDCDF) - (#x69FB . #xC4D0) - (#x69FD . #xC1E5) - (#x69FE . #x8FC4F1) - (#x69FF . #xDCDD) - (#x6A00 . #x8FC4F2) - (#x6A01 . #x8FC4F3) - (#x6A02 . #xDCDB) - (#x6A03 . #x8FC4F4) - (#x6A05 . #xDCE2) - (#x6A0A . #xDCE8) - (#x6A0B . #xC8F5) - (#x6A0C . #xDCEE) - (#x6A0F . #x8FC4F5) - (#x6A11 . #x8FC4F6) - (#x6A12 . #xDCE9) - (#x6A13 . #xDCEC) - (#x6A14 . #xDCE6) - (#x6A15 . #x8FC4F7) - (#x6A17 . #xC3F4) - (#x6A19 . #xC9B8) - (#x6A1A . #x8FC4F8) - (#x6A1B . #xDCDC) - (#x6A1D . #x8FC4F9) - (#x6A1E . #xDCE4) - (#x6A1F . #xBEC0) - (#x6A20 . #x8FC4FA) - (#x6A21 . #xCCCF) - (#x6A22 . #xDCF8) - (#x6A23 . #xDCEB) - (#x6A24 . #x8FC4FB) - (#x6A28 . #x8FC4FC) - (#x6A29 . #xB8A2) - (#x6A2A . #xB2A3) - (#x6A2B . #xB3DF) - (#x6A2E . #xDCD3) - (#x6A30 . #x8FC4FD) - (#x6A32 . #x8FC4FE) - (#x6A34 . #x8FC5A1) - (#x6A35 . #xBEC1) - (#x6A36 . #xDCF0) - (#x6A37 . #x8FC5A2) - (#x6A38 . #xDCF7) - (#x6A39 . #xBCF9) - (#x6A3A . #xB3F2) - (#x6A3B . #x8FC5A3) - (#x6A3D . #xC3AE) - (#x6A3E . #x8FC5A4) - (#x6A3F . #x8FC5A5) - (#x6A44 . #xDCED) - (#x6A45 . #x8FC5A6) - (#x6A46 . #x8FC5A7) - (#x6A47 . #xDCF2) - (#x6A48 . #xDCF6) - (#x6A49 . #x8FC5A8) - (#x6A4A . #x8FC5A9) - (#x6A4B . #xB6B6) - (#x6A4E . #x8FC5AA) - (#x6A50 . #x8FC5AB) - (#x6A51 . #x8FC5AC) - (#x6A52 . #x8FC5AD) - (#x6A55 . #x8FC5AE) - (#x6A56 . #x8FC5AF) - (#x6A58 . #xB5CC) - (#x6A59 . #xDCF4) - (#x6A5B . #x8FC5B0) - (#x6A5F . #xB5A1) - (#x6A61 . #xC6CB) - (#x6A62 . #xDCF3) - (#x6A64 . #x8FC5B1) - (#x6A66 . #xDCF5) - (#x6A67 . #x8FC5B2) - (#x6A6A . #x8FC5B3) - (#x6A71 . #x8FC5B4) - (#x6A72 . #xDCEF) - (#x6A73 . #x8FC5B5) - (#x6A78 . #xDCF1) - (#x6A7E . #x8FC5B6) - (#x6A7F . #xB3E0) - (#x6A80 . #xC3C9) - (#x6A81 . #x8FC5B7) - (#x6A83 . #x8FC5B8) - (#x6A84 . #xDCFC) - (#x6A86 . #x8FC5B9) - (#x6A87 . #x8FC5BA) - (#x6A89 . #x8FC5BB) - (#x6A8B . #x8FC5BC) - (#x6A8D . #xDCFA) - (#x6A8E . #xB8E9) - (#x6A90 . #xDCF9) - (#x6A91 . #x8FC5BD) - (#x6A97 . #xDDA1) - (#x6A9B . #x8FC5BE) - (#x6A9C . #xDBD8) - (#x6A9D . #x8FC5BF) - (#x6A9E . #x8FC5C0) - (#x6A9F . #x8FC5C1) - (#x6AA0 . #xDCFB) - (#x6AA2 . #xDCFD) - (#x6AA3 . #xDCFE) - (#x6AA5 . #x8FC5C2) - (#x6AAA . #xDDAC) - (#x6AAB . #x8FC5C3) - (#x6AAC . #xDDA8) - (#x6AAE . #xDBED) - (#x6AAF . #x8FC5C4) - (#x6AB0 . #x8FC5C5) - (#x6AB1 . #x8FC5C6) - (#x6AB3 . #xDDA7) - (#x6AB4 . #x8FC5C7) - (#x6AB8 . #xDDA6) - (#x6ABB . #xDDA3) - (#x6ABD . #x8FC5C8) - (#x6ABE . #x8FC5C9) - (#x6ABF . #x8FC5CA) - (#x6AC1 . #xDCEA) - (#x6AC2 . #xDDA5) - (#x6AC3 . #xDDA4) - (#x6AC6 . #x8FC5CB) - (#x6AC8 . #x8FC5CD) - (#x6AC9 . #x8FC5CC) - (#x6ACC . #x8FC5CE) - (#x6AD0 . #x8FC5CF) - (#x6AD1 . #xDDAA) - (#x6AD3 . #xCFA6) - (#x6AD4 . #x8FC5D0) - (#x6AD5 . #x8FC5D1) - (#x6AD6 . #x8FC5D2) - (#x6ADA . #xDDAD) - (#x6ADB . #xB6FB) - (#x6ADC . #x8FC5D3) - (#x6ADD . #x8FC5D4) - (#x6ADE . #xDDA9) - (#x6ADF . #xDDAB) - (#x6AE4 . #x8FC5D5) - (#x6AE7 . #x8FC5D6) - (#x6AE8 . #xC8A7) - (#x6AEA . #xDDAE) - (#x6AEC . #x8FC5D7) - (#x6AF0 . #x8FC5D8) - (#x6AF1 . #x8FC5D9) - (#x6AF2 . #x8FC5DA) - (#x6AFA . #xDDB2) - (#x6AFB . #xDDAF) - (#x6AFC . #x8FC5DB) - (#x6AFD . #x8FC5DC) - (#x6B02 . #x8FC5DD) - (#x6B03 . #x8FC5DE) - (#x6B04 . #xCDF3) - (#x6B05 . #xDDB0) - (#x6B06 . #x8FC5DF) - (#x6B07 . #x8FC5E0) - (#x6B09 . #x8FC5E1) - (#x6B0A . #xDCDE) - (#x6B0F . #x8FC5E2) - (#x6B10 . #x8FC5E3) - (#x6B11 . #x8FC5E4) - (#x6B12 . #xDDB3) - (#x6B16 . #xDDB4) - (#x6B17 . #x8FC5E5) - (#x6B1B . #x8FC5E6) - (#x6B1D . #xB1B5) - (#x6B1E . #x8FC5E7) - (#x6B1F . #xDDB6) - (#x6B20 . #xB7E7) - (#x6B21 . #xBCA1) - (#x6B23 . #xB6D5) - (#x6B24 . #x8FC5E8) - (#x6B27 . #xB2A4) - (#x6B28 . #x8FC5E9) - (#x6B2B . #x8FC5EA) - (#x6B2C . #x8FC5EB) - (#x6B2F . #x8FC5EC) - (#x6B32 . #xCDDF) - (#x6B35 . #x8FC5ED) - (#x6B36 . #x8FC5EE) - (#x6B37 . #xDDB8) - (#x6B38 . #xDDB7) - (#x6B39 . #xDDBA) - (#x6B3A . #xB5BD) - (#x6B3B . #x8FC5EF) - (#x6B3D . #xB6D6) - (#x6B3E . #xB4BE) - (#x6B3F . #x8FC5F0) - (#x6B43 . #xDDBD) - (#x6B46 . #x8FC5F1) - (#x6B47 . #xDDBC) - (#x6B49 . #xDDBE) - (#x6B4A . #x8FC5F2) - (#x6B4C . #xB2CE) - (#x6B4D . #x8FC5F3) - (#x6B4E . #xC3B7) - (#x6B50 . #xDDBF) - (#x6B52 . #x8FC5F4) - (#x6B53 . #xB4BF) - (#x6B54 . #xDDC1) - (#x6B56 . #x8FC5F5) - (#x6B58 . #x8FC5F6) - (#x6B59 . #xDDC0) - (#x6B5B . #xDDC2) - (#x6B5D . #x8FC5F7) - (#x6B5F . #xDDC3) - (#x6B60 . #x8FC5F8) - (#x6B61 . #xDDC4) - (#x6B62 . #xBBDF) - (#x6B63 . #xC0B5) - (#x6B64 . #xBAA1) - (#x6B66 . #xC9F0) - (#x6B67 . #x8FC5F9) - (#x6B69 . #xCAE2) - (#x6B6A . #xCFC4) - (#x6B6B . #x8FC5FA) - (#x6B6E . #x8FC5FB) - (#x6B6F . #xBBF5) - (#x6B70 . #x8FC5FC) - (#x6B73 . #xBAD0) - (#x6B74 . #xCEF2) - (#x6B75 . #x8FC5FD) - (#x6B78 . #xDDC5) - (#x6B79 . #xDDC6) - (#x6B7B . #xBBE0) - (#x6B7D . #x8FC5FE) - (#x6B7E . #x8FC6A1) - (#x6B7F . #xDDC7) - (#x6B80 . #xDDC8) - (#x6B82 . #x8FC6A2) - (#x6B83 . #xDDCA) - (#x6B84 . #xDDC9) - (#x6B85 . #x8FC6A3) - (#x6B86 . #xCBD8) - (#x6B89 . #xBDDE) - (#x6B8A . #xBCEC) - (#x6B8B . #xBBC4) - (#x6B8D . #xDDCB) - (#x6B95 . #xDDCD) - (#x6B96 . #xBFA3) - (#x6B97 . #x8FC6A4) - (#x6B98 . #xDDCC) - (#x6B9B . #x8FC6A5) - (#x6B9E . #xDDCE) - (#x6B9F . #x8FC6A6) - (#x6BA0 . #x8FC6A7) - (#x6BA2 . #x8FC6A8) - (#x6BA3 . #x8FC6A9) - (#x6BA4 . #xDDCF) - (#x6BA8 . #x8FC6AA) - (#x6BA9 . #x8FC6AB) - (#x6BAA . #xDDD0) - (#x6BAB . #xDDD1) - (#x6BAC . #x8FC6AC) - (#x6BAD . #x8FC6AD) - (#x6BAE . #x8FC6AE) - (#x6BAF . #xDDD2) - (#x6BB0 . #x8FC6AF) - (#x6BB1 . #xDDD4) - (#x6BB2 . #xDDD3) - (#x6BB3 . #xDDD5) - (#x6BB4 . #xB2A5) - (#x6BB5 . #xC3CA) - (#x6BB7 . #xDDD6) - (#x6BB8 . #x8FC6B0) - (#x6BB9 . #x8FC6B1) - (#x6BBA . #xBBA6) - (#x6BBB . #xB3CC) - (#x6BBC . #xDDD7) - (#x6BBD . #x8FC6B2) - (#x6BBE . #x8FC6B3) - (#x6BBF . #xC5C2) - (#x6BC0 . #xD4CC) - (#x6BC3 . #x8FC6B4) - (#x6BC4 . #x8FC6B5) - (#x6BC5 . #xB5A3) - (#x6BC6 . #xDDD8) - (#x6BC9 . #x8FC6B6) - (#x6BCB . #xDDD9) - (#x6BCC . #x8FC6B7) - (#x6BCD . #xCAEC) - (#x6BCE . #xCBE8) - (#x6BD2 . #xC6C7) - (#x6BD3 . #xDDDA) - (#x6BD4 . #xC8E6) - (#x6BD6 . #x8FC6B8) - (#x6BD8 . #xC8FB) - (#x6BDA . #x8FC6B9) - (#x6BDB . #xCCD3) - (#x6BDF . #xDDDB) - (#x6BE1 . #x8FC6BA) - (#x6BE3 . #x8FC6BB) - (#x6BE6 . #x8FC6BC) - (#x6BE7 . #x8FC6BD) - (#x6BEB . #xDDDD) - (#x6BEC . #xDDDC) - (#x6BEE . #x8FC6BE) - (#x6BEF . #xDDDF) - (#x6BF1 . #x8FC6BF) - (#x6BF3 . #xDDDE) - (#x6BF7 . #x8FC6C0) - (#x6BF9 . #x8FC6C1) - (#x6BFF . #x8FC6C2) - (#x6C02 . #x8FC6C3) - (#x6C04 . #x8FC6C4) - (#x6C05 . #x8FC6C5) - (#x6C08 . #xDDE1) - (#x6C09 . #x8FC6C6) - (#x6C0D . #x8FC6C7) - (#x6C0E . #x8FC6C8) - (#x6C0F . #xBBE1) - (#x6C10 . #x8FC6C9) - (#x6C11 . #xCCB1) - (#x6C12 . #x8FC6CA) - (#x6C13 . #xDDE2) - (#x6C14 . #xDDE3) - (#x6C17 . #xB5A4) - (#x6C19 . #x8FC6CB) - (#x6C1B . #xDDE4) - (#x6C1F . #x8FC6CC) - (#x6C23 . #xDDE6) - (#x6C24 . #xDDE5) - (#x6C26 . #x8FC6CD) - (#x6C27 . #x8FC6CE) - (#x6C28 . #x8FC6CF) - (#x6C2C . #x8FC6D0) - (#x6C2E . #x8FC6D1) - (#x6C33 . #x8FC6D2) - (#x6C34 . #xBFE5) - (#x6C35 . #x8FC6D3) - (#x6C36 . #x8FC6D4) - (#x6C37 . #xC9B9) - (#x6C38 . #xB1CA) - (#x6C3A . #x8FC6D5) - (#x6C3B . #x8FC6D6) - (#x6C3E . #xC8C5) - (#x6C3F . #x8FC6D7) - (#x6C40 . #xC4F5) - (#x6C41 . #xBDC1) - (#x6C42 . #xB5E1) - (#x6C4A . #x8FC6D8) - (#x6C4B . #x8FC6D9) - (#x6C4D . #x8FC6DA) - (#x6C4E . #xC8C6) - (#x6C4F . #x8FC6DB) - (#x6C50 . #xBCAE) - (#x6C52 . #x8FC6DC) - (#x6C54 . #x8FC6DD) - (#x6C55 . #xDDE8) - (#x6C57 . #xB4C0) - (#x6C59 . #x8FC6DE) - (#x6C5A . #xB1F8) - (#x6C5B . #x8FC6DF) - (#x6C5C . #x8FC6E0) - (#x6C5D . #xC6F2) - (#x6C5E . #xDDE7) - (#x6C5F . #xB9BE) - (#x6C60 . #xC3D3) - (#x6C62 . #xDDE9) - (#x6C67 . #x8FC7B6) - (#x6C68 . #xDDF1) - (#x6C6A . #xDDEA) - (#x6C6B . #x8FC6E1) - (#x6C6D . #x8FC6E2) - (#x6C6F . #x8FC6E3) - (#x6C70 . #xC2C1) - (#x6C72 . #xB5E2) - (#x6C73 . #xDDF2) - (#x6C74 . #x8FC6E4) - (#x6C76 . #x8FC6E5) - (#x6C78 . #x8FC6E6) - (#x6C79 . #x8FC6E7) - (#x6C7A . #xB7E8) - (#x6C7B . #x8FC6E8) - (#x6C7D . #xB5A5) - (#x6C7E . #xDDF0) - (#x6C81 . #xDDEE) - (#x6C82 . #xDDEB) - (#x6C83 . #xCDE0) - (#x6C85 . #x8FC6E9) - (#x6C86 . #x8FC6EA) - (#x6C87 . #x8FC6EB) - (#x6C88 . #xC4C0) - (#x6C89 . #x8FC6EC) - (#x6C8C . #xC6D9) - (#x6C8D . #xDDEC) - (#x6C90 . #xDDF4) - (#x6C92 . #xDDF3) - (#x6C93 . #xB7A3) - (#x6C94 . #x8FC6ED) - (#x6C95 . #x8FC6EE) - (#x6C96 . #xB2AD) - (#x6C97 . #x8FC6EF) - (#x6C98 . #x8FC6F0) - (#x6C99 . #xBABB) - (#x6C9A . #xDDED) - (#x6C9B . #xDDEF) - (#x6C9C . #x8FC6F1) - (#x6C9F . #x8FC6F2) - (#x6CA1 . #xCBD7) - (#x6CA2 . #xC2F4) - (#x6CAB . #xCBF7) - (#x6CAE . #xDDFC) - (#x6CB0 . #x8FC6F3) - (#x6CB1 . #xDDFD) - (#x6CB2 . #x8FC6F4) - (#x6CB3 . #xB2CF) - (#x6CB4 . #x8FC6F5) - (#x6CB8 . #xCAA8) - (#x6CB9 . #xCCFD) - (#x6CBA . #xDEA1) - (#x6CBB . #xBCA3) - (#x6CBC . #xBEC2) - (#x6CBD . #xDDF8) - (#x6CBE . #xDDFE) - (#x6CBF . #xB1E8) - (#x6CC1 . #xB6B7) - (#x6CC2 . #x8FC6F6) - (#x6CC4 . #xDDF5) - (#x6CC5 . #xDDFA) - (#x6CC6 . #x8FC6F7) - (#x6CC9 . #xC0F4) - (#x6CCA . #xC7F1) - (#x6CCC . #xC8E7) - (#x6CCD . #x8FC6F8) - (#x6CCF . #x8FC6F9) - (#x6CD0 . #x8FC6FA) - (#x6CD1 . #x8FC6FB) - (#x6CD2 . #x8FC6FC) - (#x6CD3 . #xDDF7) - (#x6CD4 . #x8FC6FD) - (#x6CD5 . #xCBA1) - (#x6CD6 . #x8FC6FE) - (#x6CD7 . #xDDF9) - (#x6CD9 . #xDEA4) - (#x6CDA . #x8FC7A1) - (#x6CDB . #xDEA2) - (#x6CDC . #x8FC7A2) - (#x6CDD . #xDDFB) - (#x6CE0 . #x8FC7A3) - (#x6CE1 . #xCBA2) - (#x6CE2 . #xC7C8) - (#x6CE3 . #xB5E3) - (#x6CE5 . #xC5A5) - (#x6CE7 . #x8FC7A4) - (#x6CE8 . #xC3ED) - (#x6CE9 . #x8FC7A5) - (#x6CEA . #xDEA5) - (#x6CEB . #x8FC7A6) - (#x6CEC . #x8FC7A7) - (#x6CEE . #x8FC7A8) - (#x6CEF . #xDEA3) - (#x6CF0 . #xC2D9) - (#x6CF1 . #xDDF6) - (#x6CF2 . #x8FC7A9) - (#x6CF3 . #xB1CB) - (#x6CF4 . #x8FC7AA) - (#x6D04 . #x8FC7AB) - (#x6D07 . #x8FC7AC) - (#x6D0A . #x8FC7AD) - (#x6D0B . #xCDCE) - (#x6D0C . #xDEB0) - (#x6D0E . #x8FC7AE) - (#x6D0F . #x8FC7AF) - (#x6D11 . #x8FC7B0) - (#x6D12 . #xDEAF) - (#x6D13 . #x8FC7B1) - (#x6D17 . #xC0F6) - (#x6D19 . #xDEAC) - (#x6D1A . #x8FC7B2) - (#x6D1B . #xCDEC) - (#x6D1E . #xC6B6) - (#x6D1F . #xDEA6) - (#x6D25 . #xC4C5) - (#x6D26 . #x8FC7B3) - (#x6D27 . #x8FC7B4) - (#x6D28 . #x8FC7B5) - (#x6D29 . #xB1CC) - (#x6D2A . #xB9BF) - (#x6D2B . #xDEA9) - (#x6D2E . #x8FC7B7) - (#x6D2F . #x8FC7B8) - (#x6D31 . #x8FC7B9) - (#x6D32 . #xBDA7) - (#x6D33 . #xDEAE) - (#x6D35 . #xDEAD) - (#x6D36 . #xDEA8) - (#x6D38 . #xDEAB) - (#x6D39 . #x8FC7BA) - (#x6D3B . #xB3E8) - (#x6D3C . #x8FC7BB) - (#x6D3D . #xDEAA) - (#x6D3E . #xC7C9) - (#x6D3F . #x8FC7BC) - (#x6D41 . #xCEAE) - (#x6D44 . #xBEF4) - (#x6D45 . #xC0F5) - (#x6D57 . #x8FC7BD) - (#x6D59 . #xDEB6) - (#x6D5A . #xDEB4) - (#x6D5C . #xC9CD) - (#x6D5E . #x8FC7BE) - (#x6D5F . #x8FC7BF) - (#x6D61 . #x8FC7C0) - (#x6D63 . #xDEB1) - (#x6D64 . #xDEB3) - (#x6D65 . #x8FC7C1) - (#x6D66 . #xB1BA) - (#x6D67 . #x8FC7C2) - (#x6D69 . #xB9C0) - (#x6D6A . #xCFB2) - (#x6D6C . #xB3BD) - (#x6D6E . #xC9E2) - (#x6D6F . #x8FC7C3) - (#x6D70 . #x8FC7C4) - (#x6D74 . #xCDE1) - (#x6D77 . #xB3A4) - (#x6D78 . #xBFBB) - (#x6D79 . #xDEB5) - (#x6D7C . #x8FC7C5) - (#x6D82 . #x8FC7C6) - (#x6D85 . #xDEBA) - (#x6D87 . #x8FC7C7) - (#x6D88 . #xBEC3) - (#x6D8C . #xCDB0) - (#x6D8E . #xDEB7) - (#x6D91 . #x8FC7C8) - (#x6D92 . #x8FC7C9) - (#x6D93 . #xDEB2) - (#x6D94 . #x8FC7CA) - (#x6D95 . #xDEB8) - (#x6D96 . #x8FC7CB) - (#x6D97 . #x8FC7CC) - (#x6D98 . #x8FC7CD) - (#x6D99 . #xCEDE) - (#x6D9B . #xC5F3) - (#x6D9C . #xC6C2) - (#x6DAA . #x8FC7CE) - (#x6DAC . #x8FC7CF) - (#x6DAF . #xB3B6) - (#x6DB2 . #xB1D5) - (#x6DB4 . #x8FC7D0) - (#x6DB5 . #xDEBE) - (#x6DB7 . #x8FC7D1) - (#x6DB8 . #xDEC1) - (#x6DB9 . #x8FC7D2) - (#x6DBC . #xCEC3) - (#x6DBD . #x8FC7D3) - (#x6DBF . #x8FC7D4) - (#x6DC0 . #xCDE4) - (#x6DC4 . #x8FC7D5) - (#x6DC5 . #xDEC8) - (#x6DC6 . #xDEC2) - (#x6DC7 . #xDEBF) - (#x6DC8 . #x8FC7D6) - (#x6DCA . #x8FC7D7) - (#x6DCB . #xCED4) - (#x6DCC . #xDEC5) - (#x6DCE . #x8FC7D8) - (#x6DCF . #x8FC7D9) - (#x6DD1 . #xBDCA) - (#x6DD2 . #xDEC7) - (#x6DD5 . #xDECC) - (#x6DD6 . #x8FC7DA) - (#x6DD8 . #xC5F1) - (#x6DD9 . #xDECA) - (#x6DDB . #x8FC7DB) - (#x6DDD . #x8FC7DC) - (#x6DDE . #xDEC4) - (#x6DDF . #x8FC7DD) - (#x6DE0 . #x8FC7DE) - (#x6DE1 . #xC3B8) - (#x6DE2 . #x8FC7DF) - (#x6DE4 . #xDECB) - (#x6DE5 . #x8FC7E0) - (#x6DE6 . #xDEC0) - (#x6DE8 . #xDEC6) - (#x6DE9 . #x8FC7E1) - (#x6DEA . #xDECD) - (#x6DEB . #xB0FC) - (#x6DEC . #xDEC3) - (#x6DEE . #xDECE) - (#x6DEF . #x8FC7E2) - (#x6DF0 . #x8FC7E3) - (#x6DF1 . #xBFBC) - (#x6DF3 . #xBDDF) - (#x6DF4 . #x8FC7E4) - (#x6DF5 . #xCAA5) - (#x6DF6 . #x8FC7E5) - (#x6DF7 . #xBAAE) - (#x6DF9 . #xDEBB) - (#x6DFA . #xDEC9) - (#x6DFB . #xC5BA) - (#x6DFC . #x8FC7E6) - (#x6E00 . #x8FC7E7) - (#x6E04 . #x8FC7E8) - (#x6E05 . #xC0B6) - (#x6E07 . #xB3E9) - (#x6E08 . #xBAD1) - (#x6E09 . #xBEC4) - (#x6E0A . #xDEBD) - (#x6E0B . #xBDC2) - (#x6E13 . #xB7CC) - (#x6E15 . #xDEBC) - (#x6E19 . #xDED2) - (#x6E1A . #xBDED) - (#x6E1B . #xB8BA) - (#x6E1D . #xDEE1) - (#x6E1E . #x8FC7E9) - (#x6E1F . #xDEDB) - (#x6E20 . #xB5F4) - (#x6E21 . #xC5CF) - (#x6E22 . #x8FC7EA) - (#x6E23 . #xDED6) - (#x6E24 . #xDEDF) - (#x6E25 . #xB0AF) - (#x6E26 . #xB1B2) - (#x6E27 . #x8FC7EB) - (#x6E29 . #xB2B9) - (#x6E2B . #xDED8) - (#x6E2C . #xC2AC) - (#x6E2D . #xDECF) - (#x6E2E . #xDED1) - (#x6E2F . #xB9C1) - (#x6E32 . #x8FC7EC) - (#x6E36 . #x8FC7ED) - (#x6E38 . #xDEE2) - (#x6E39 . #x8FC7EE) - (#x6E3A . #xDEDD) - (#x6E3B . #x8FC7EF) - (#x6E3C . #x8FC7F0) - (#x6E3E . #xDED5) - (#x6E43 . #xDEDC) - (#x6E44 . #x8FC7F1) - (#x6E45 . #x8FC7F2) - (#x6E48 . #x8FC7F3) - (#x6E49 . #x8FC7F4) - (#x6E4A . #xCCAB) - (#x6E4B . #x8FC7F5) - (#x6E4D . #xDEDA) - (#x6E4E . #xDEDE) - (#x6E4F . #x8FC7F6) - (#x6E51 . #x8FC7F7) - (#x6E52 . #x8FC7F8) - (#x6E53 . #x8FC7F9) - (#x6E54 . #x8FC7FA) - (#x6E56 . #xB8D0) - (#x6E57 . #x8FC7FB) - (#x6E58 . #xBEC5) - (#x6E5B . #xC3B9) - (#x6E5C . #x8FC7FC) - (#x6E5D . #x8FC7FD) - (#x6E5E . #x8FC7FE) - (#x6E5F . #xDED4) - (#x6E62 . #x8FC8A1) - (#x6E63 . #x8FC8A2) - (#x6E67 . #xCDAF) - (#x6E68 . #x8FC8A3) - (#x6E6B . #xDED7) - (#x6E6E . #xDED0) - (#x6E6F . #xC5F2) - (#x6E72 . #xDED3) - (#x6E73 . #x8FC8A4) - (#x6E76 . #xDED9) - (#x6E7B . #x8FC8A5) - (#x6E7D . #x8FC8A6) - (#x6E7E . #xCFD1) - (#x6E7F . #xBCBE) - (#x6E80 . #xCBFE) - (#x6E82 . #xDEE3) - (#x6E8C . #xC8AE) - (#x6E8D . #x8FC8A7) - (#x6E8F . #xDEEF) - (#x6E90 . #xB8BB) - (#x6E93 . #x8FC8A8) - (#x6E96 . #xBDE0) - (#x6E98 . #xDEE5) - (#x6E99 . #x8FC8A9) - (#x6E9C . #xCEAF) - (#x6E9D . #xB9C2) - (#x6E9F . #xDEF2) - (#x6EA0 . #x8FC8AA) - (#x6EA2 . #xB0EE) - (#x6EA5 . #xDEF0) - (#x6EA7 . #x8FC8AB) - (#x6EAA . #xDEE4) - (#x6EAD . #x8FC8AC) - (#x6EAE . #x8FC8AD) - (#x6EAF . #xDEEA) - (#x6EB1 . #x8FC8AE) - (#x6EB2 . #xDEEC) - (#x6EB3 . #x8FC8AF) - (#x6EB6 . #xCDCF) - (#x6EB7 . #xDEE7) - (#x6EBA . #xC5AE) - (#x6EBB . #x8FC8B0) - (#x6EBD . #xDEE9) - (#x6EBF . #x8FC8B1) - (#x6EC0 . #x8FC8B2) - (#x6EC1 . #x8FC8B3) - (#x6EC2 . #xDEF1) - (#x6EC3 . #x8FC8B4) - (#x6EC4 . #xDEEB) - (#x6EC5 . #xCCC7) - (#x6EC7 . #x8FC8B5) - (#x6EC8 . #x8FC8B6) - (#x6EC9 . #xDEE6) - (#x6ECA . #x8FC8B7) - (#x6ECB . #xBCA2) - (#x6ECC . #xDEFE) - (#x6ECD . #x8FC8B8) - (#x6ECE . #x8FC8B9) - (#x6ECF . #x8FC8BA) - (#x6ED1 . #xB3EA) - (#x6ED3 . #xDEE8) - (#x6ED4 . #xDEED) - (#x6ED5 . #xDEEE) - (#x6EDD . #xC2EC) - (#x6EDE . #xC2DA) - (#x6EEB . #x8FC8BB) - (#x6EEC . #xDEF6) - (#x6EED . #x8FC8BC) - (#x6EEE . #x8FC8BD) - (#x6EEF . #xDEFC) - (#x6EF2 . #xDEFA) - (#x6EF4 . #xC5A9) - (#x6EF7 . #xDFA3) - (#x6EF8 . #xDEF7) - (#x6EF9 . #x8FC8BE) - (#x6EFB . #x8FC8BF) - (#x6EFD . #x8FC8C0) - (#x6EFE . #xDEF8) - (#x6EFF . #xDEE0) - (#x6F01 . #xB5F9) - (#x6F02 . #xC9BA) - (#x6F04 . #x8FC8C1) - (#x6F06 . #xBCBF) - (#x6F08 . #x8FC8C2) - (#x6F09 . #xB9F7) - (#x6F0A . #x8FC8C3) - (#x6F0C . #x8FC8C4) - (#x6F0D . #x8FC8C5) - (#x6F0F . #xCFB3) - (#x6F11 . #xDEF4) - (#x6F13 . #xDFA2) - (#x6F14 . #xB1E9) - (#x6F15 . #xC1E6) - (#x6F16 . #x8FC8C6) - (#x6F18 . #x8FC8C7) - (#x6F1A . #x8FC8C8) - (#x6F1B . #x8FC8C9) - (#x6F20 . #xC7F9) - (#x6F22 . #xB4C1) - (#x6F23 . #xCEFA) - (#x6F26 . #x8FC8CA) - (#x6F29 . #x8FC8CB) - (#x6F2A . #x8FC8CC) - (#x6F2B . #xCCA1) - (#x6F2C . #xC4D2) - (#x6F2D . #x8FC8D3) - (#x6F2F . #x8FC8CD) - (#x6F30 . #x8FC8CE) - (#x6F31 . #xDEFB) - (#x6F32 . #xDEFD) - (#x6F33 . #x8FC8CF) - (#x6F36 . #x8FC8D0) - (#x6F38 . #xC1B2) - (#x6F3B . #x8FC8D1) - (#x6F3C . #x8FC8D2) - (#x6F3E . #xDFA1) - (#x6F3F . #xDEF9) - (#x6F41 . #xDEF3) - (#x6F45 . #xB4C3) - (#x6F4F . #x8FC8D4) - (#x6F51 . #x8FC8D5) - (#x6F52 . #x8FC8D6) - (#x6F53 . #x8FC8D7) - (#x6F54 . #xB7E9) - (#x6F57 . #x8FC8D8) - (#x6F58 . #xDFAF) - (#x6F59 . #x8FC8D9) - (#x6F5A . #x8FC8DA) - (#x6F5B . #xDFAA) - (#x6F5C . #xC0F8) - (#x6F5D . #x8FC8DB) - (#x6F5E . #x8FC8DC) - (#x6F5F . #xB3E3) - (#x6F61 . #x8FC8DD) - (#x6F62 . #x8FC8DE) - (#x6F64 . #xBDE1) - (#x6F66 . #xDFB3) - (#x6F68 . #x8FC8DF) - (#x6F6C . #x8FC8E0) - (#x6F6D . #xDFAC) - (#x6F6E . #xC4AC) - (#x6F6F . #xDFA9) - (#x6F70 . #xC4D9) - (#x6F74 . #xDFCC) - (#x6F78 . #xDFA6) - (#x6F7A . #xDFA5) - (#x6F7C . #xDFAE) - (#x6F7D . #x8FC8E1) - (#x6F7E . #x8FC8E2) - (#x6F80 . #xDFA8) - (#x6F81 . #xDFA7) - (#x6F82 . #xDFAD) - (#x6F83 . #x8FC8E3) - (#x6F84 . #xC0A1) - (#x6F86 . #xDFA4) - (#x6F87 . #x8FC8E4) - (#x6F88 . #x8FC8E5) - (#x6F8B . #x8FC8E6) - (#x6F8C . #x8FC8E7) - (#x6F8D . #x8FC8E8) - (#x6F8E . #xDFB0) - (#x6F90 . #x8FC8E9) - (#x6F91 . #xDFB1) - (#x6F92 . #x8FC8EA) - (#x6F93 . #x8FC8EB) - (#x6F94 . #x8FC8EC) - (#x6F96 . #x8FC8ED) - (#x6F97 . #xB4C2) - (#x6F9A . #x8FC8EE) - (#x6F9F . #x8FC8EF) - (#x6FA0 . #x8FC8F0) - (#x6FA1 . #xDFB6) - (#x6FA3 . #xDFB5) - (#x6FA4 . #xDFB7) - (#x6FA5 . #x8FC8F1) - (#x6FA6 . #x8FC8F2) - (#x6FA7 . #x8FC8F3) - (#x6FA8 . #x8FC8F4) - (#x6FAA . #xDFBA) - (#x6FAE . #x8FC8F5) - (#x6FAF . #x8FC8F6) - (#x6FB0 . #x8FC8F7) - (#x6FB1 . #xC5C3) - (#x6FB3 . #xDFB4) - (#x6FB5 . #x8FC8F8) - (#x6FB6 . #x8FC8F9) - (#x6FB9 . #xDFB8) - (#x6FBC . #x8FC8FA) - (#x6FC0 . #xB7E3) - (#x6FC1 . #xC2F9) - (#x6FC2 . #xDFB2) - (#x6FC3 . #xC7BB) - (#x6FC5 . #x8FC8FB) - (#x6FC6 . #xDFB9) - (#x6FC7 . #x8FC8FC) - (#x6FC8 . #x8FC8FD) - (#x6FCA . #x8FC8FE) - (#x6FD4 . #xDFBE) - (#x6FD5 . #xDFBC) - (#x6FD8 . #xDFBF) - (#x6FDA . #x8FC9A1) - (#x6FDB . #xDFC2) - (#x6FDE . #x8FC9A2) - (#x6FDF . #xDFBB) - (#x6FE0 . #xB9EA) - (#x6FE1 . #xC7A8) - (#x6FE4 . #xDEB9) - (#x6FE8 . #x8FC9A3) - (#x6FE9 . #x8FC9A4) - (#x6FEB . #xCDF4) - (#x6FEC . #xDFBD) - (#x6FEE . #xDFC1) - (#x6FEF . #xC2F5) - (#x6FF0 . #x8FC9A5) - (#x6FF1 . #xDFC0) - (#x6FF3 . #xDFAB) - (#x6FF5 . #x8FC9A6) - (#x6FF6 . #xEFE9) - (#x6FF9 . #x8FC9A7) - (#x6FFA . #xDFC5) - (#x6FFC . #x8FC9A8) - (#x6FFD . #x8FC9A9) - (#x6FFE . #xDFC9) - (#x7000 . #x8FC9AA) - (#x7001 . #xDFC7) - (#x7005 . #x8FC9AB) - (#x7006 . #x8FC9AC) - (#x7007 . #x8FC9AD) - (#x7009 . #xDFC3) - (#x700B . #xDFC4) - (#x700D . #x8FC9AE) - (#x700F . #xDFC8) - (#x7011 . #xDFC6) - (#x7015 . #xC9CE) - (#x7017 . #x8FC9AF) - (#x7018 . #xDFCE) - (#x701A . #xDFCB) - (#x701B . #xDFCA) - (#x701D . #xDFCD) - (#x701E . #xC6D4) - (#x701F . #xDFCF) - (#x7020 . #x8FC9B0) - (#x7023 . #x8FC9B1) - (#x7026 . #xC3F5) - (#x7027 . #xC2ED) - (#x702C . #xC0A5) - (#x702F . #x8FC9B2) - (#x7030 . #xDFD0) - (#x7032 . #xDFD2) - (#x7034 . #x8FC9B3) - (#x7037 . #x8FC9B4) - (#x7039 . #x8FC9B5) - (#x703C . #x8FC9B6) - (#x703E . #xDFD1) - (#x7043 . #x8FC9B7) - (#x7044 . #x8FC9B8) - (#x7048 . #x8FC9B9) - (#x7049 . #x8FC9BA) - (#x704A . #x8FC9BB) - (#x704B . #x8FC9BC) - (#x704C . #xDEF5) - (#x704E . #x8FC9C1) - (#x7051 . #xDFD3) - (#x7054 . #x8FC9BD) - (#x7055 . #x8FC9BE) - (#x7058 . #xC6E7) - (#x705D . #x8FC9BF) - (#x705E . #x8FC9C0) - (#x7063 . #xDFD4) - (#x7064 . #x8FC9C2) - (#x7065 . #x8FC9C3) - (#x706B . #xB2D0) - (#x706C . #x8FC9C4) - (#x706E . #x8FC9C5) - (#x706F . #xC5F4) - (#x7070 . #xB3A5) - (#x7075 . #x8FC9C6) - (#x7076 . #x8FC9C7) - (#x7078 . #xB5E4) - (#x707C . #xBCDE) - (#x707D . #xBAD2) - (#x707E . #x8FC9C8) - (#x7081 . #x8FC9C9) - (#x7085 . #x8FC9CA) - (#x7086 . #x8FC9CB) - (#x7089 . #xCFA7) - (#x708A . #xBFE6) - (#x708E . #xB1EA) - (#x7092 . #xDFD6) - (#x7094 . #x8FC9CC) - (#x7095 . #x8FC9CD) - (#x7096 . #x8FC9CE) - (#x7097 . #x8FC9CF) - (#x7098 . #x8FC9D0) - (#x7099 . #xDFD5) - (#x709B . #x8FC9D1) - (#x70A4 . #x8FC9D2) - (#x70AB . #x8FC9D3) - (#x70AC . #xDFD9) - (#x70AD . #xC3BA) - (#x70AE . #xDFDC) - (#x70AF . #xDFD7) - (#x70B0 . #x8FC9D4) - (#x70B1 . #x8FC9D5) - (#x70B3 . #xDFDB) - (#x70B4 . #x8FC9D6) - (#x70B7 . #x8FC9D7) - (#x70B8 . #xDFDA) - (#x70B9 . #xC5C0) - (#x70BA . #xB0D9) - (#x70C8 . #xCEF5) - (#x70CA . #x8FC9D8) - (#x70CB . #xDFDE) - (#x70CF . #xB1A8) - (#x70D1 . #x8FC9D9) - (#x70D3 . #x8FC9DA) - (#x70D4 . #x8FC9DB) - (#x70D5 . #x8FC9DC) - (#x70D6 . #x8FC9DD) - (#x70D8 . #x8FC9DE) - (#x70D9 . #xDFE0) - (#x70DC . #x8FC9DF) - (#x70DD . #xDFDF) - (#x70DF . #xDFDD) - (#x70E4 . #x8FC9E0) - (#x70F1 . #xDFD8) - (#x70F9 . #xCBA3) - (#x70FA . #x8FC9E1) - (#x70FD . #xDFE2) - (#x7103 . #x8FC9E2) - (#x7104 . #x8FC9E3) - (#x7105 . #x8FC9E4) - (#x7106 . #x8FC9E5) - (#x7107 . #x8FC9E6) - (#x7109 . #xDFE1) - (#x710B . #x8FC9E7) - (#x710C . #x8FC9E8) - (#x710F . #x8FC9E9) - (#x7114 . #xB1EB) - (#x7119 . #xDFE4) - (#x711A . #xCAB2) - (#x711C . #xDFE3) - (#x711E . #x8FC9EA) - (#x7120 . #x8FC9EB) - (#x7121 . #xCCB5) - (#x7126 . #xBEC7) - (#x712B . #x8FC9EC) - (#x712D . #x8FC9ED) - (#x712F . #x8FC9EE) - (#x7130 . #x8FC9EF) - (#x7131 . #x8FC9F0) - (#x7136 . #xC1B3) - (#x7138 . #x8FC9F1) - (#x713C . #xBEC6) - (#x7141 . #x8FC9F2) - (#x7145 . #x8FC9F3) - (#x7146 . #x8FC9F4) - (#x7147 . #x8FC9F5) - (#x7149 . #xCEFB) - (#x714A . #x8FC9F6) - (#x714B . #x8FC9F7) - (#x714C . #xDFEA) - (#x714E . #xC0F9) - (#x7150 . #x8FC9F8) - (#x7152 . #x8FC9F9) - (#x7155 . #xDFE6) - (#x7156 . #xDFEB) - (#x7157 . #x8FC9FA) - (#x7159 . #xB1EC) - (#x715A . #x8FC9FB) - (#x715C . #x8FC9FC) - (#x715E . #x8FC9FD) - (#x7160 . #x8FC9FE) - (#x7162 . #xDFE9) - (#x7164 . #xC7E1) - (#x7165 . #xDFE5) - (#x7166 . #xDFE8) - (#x7167 . #xBEC8) - (#x7168 . #x8FCAA1) - (#x7169 . #xC8D1) - (#x716C . #xDFEC) - (#x716E . #xBCD1) - (#x7179 . #x8FCAA2) - (#x717D . #xC0FA) - (#x7180 . #x8FCAA3) - (#x7184 . #xDFEF) - (#x7185 . #x8FCAA4) - (#x7187 . #x8FCAA5) - (#x7188 . #xDFE7) - (#x718A . #xB7A7) - (#x718C . #x8FCAA6) - (#x718F . #xDFED) - (#x7192 . #x8FCAA7) - (#x7194 . #xCDD0) - (#x7195 . #xDFF0) - (#x7199 . #xF4A6) - (#x719A . #x8FCAA8) - (#x719B . #x8FCAA9) - (#x719F . #xBDCF) - (#x71A0 . #x8FCAAA) - (#x71A2 . #x8FCAAB) - (#x71A8 . #xDFF1) - (#x71AC . #xDFF2) - (#x71AF . #x8FCAAC) - (#x71B0 . #x8FCAAD) - (#x71B1 . #xC7AE) - (#x71B2 . #x8FCAAE) - (#x71B3 . #x8FCAAF) - (#x71B9 . #xDFF4) - (#x71BA . #x8FCAB0) - (#x71BE . #xDFF5) - (#x71BF . #x8FCAB1) - (#x71C0 . #x8FCAB2) - (#x71C1 . #x8FCAB3) - (#x71C3 . #xC7B3) - (#x71C4 . #x8FCAB4) - (#x71C8 . #xC5F5) - (#x71C9 . #xDFF7) - (#x71CB . #x8FCAB5) - (#x71CC . #x8FCAB6) - (#x71CE . #xDFF9) - (#x71D0 . #xCED5) - (#x71D2 . #xDFF6) - (#x71D3 . #x8FCAB7) - (#x71D4 . #xDFF8) - (#x71D5 . #xB1ED) - (#x71D6 . #x8FCAB8) - (#x71D7 . #xDFF3) - (#x71D9 . #x8FCAB9) - (#x71DA . #x8FCABA) - (#x71DC . #x8FCABB) - (#x71DF . #xD3DB) - (#x71E0 . #xDFFA) - (#x71E5 . #xC1E7) - (#x71E6 . #xBBB8) - (#x71E7 . #xDFFC) - (#x71EC . #xDFFB) - (#x71ED . #xBFA4) - (#x71EE . #xD2D9) - (#x71F5 . #xDFFD) - (#x71F8 . #x8FCABC) - (#x71F9 . #xE0A1) - (#x71FB . #xDFEE) - (#x71FC . #xDFFE) - (#x71FE . #x8FCABD) - (#x71FF . #xE0A2) - (#x7200 . #x8FCABE) - (#x7206 . #xC7FA) - (#x7207 . #x8FCABF) - (#x7208 . #x8FCAC0) - (#x7209 . #x8FCAC1) - (#x720D . #xE0A3) - (#x7210 . #xE0A4) - (#x7213 . #x8FCAC2) - (#x7217 . #x8FCAC3) - (#x721A . #x8FCAC4) - (#x721B . #xE0A5) - (#x721D . #x8FCAC5) - (#x721F . #x8FCAC6) - (#x7224 . #x8FCAC7) - (#x7228 . #xE0A6) - (#x722A . #xC4DE) - (#x722B . #x8FCAC8) - (#x722C . #xE0A8) - (#x722D . #xE0A7) - (#x722F . #x8FCAC9) - (#x7230 . #xE0A9) - (#x7232 . #xE0AA) - (#x7234 . #x8FCACA) - (#x7235 . #xBCDF) - (#x7236 . #xC9E3) - (#x7238 . #x8FCACB) - (#x7239 . #x8FCACC) - (#x723A . #xCCEC) - (#x723B . #xE0AB) - (#x723C . #xE0AC) - (#x723D . #xC1D6) - (#x723E . #xBCA4) - (#x723F . #xE0AD) - (#x7240 . #xE0AE) - (#x7241 . #x8FCACD) - (#x7242 . #x8FCACE) - (#x7243 . #x8FCACF) - (#x7245 . #x8FCAD0) - (#x7246 . #xE0AF) - (#x7247 . #xCAD2) - (#x7248 . #xC8C7) - (#x724B . #xE0B0) - (#x724C . #xC7D7) - (#x724E . #x8FCAD1) - (#x724F . #x8FCAD2) - (#x7250 . #x8FCAD3) - (#x7252 . #xC4AD) - (#x7253 . #x8FCAD4) - (#x7255 . #x8FCAD5) - (#x7256 . #x8FCAD6) - (#x7258 . #xE0B1) - (#x7259 . #xB2E7) - (#x725A . #x8FCAD7) - (#x725B . #xB5ED) - (#x725C . #x8FCAD8) - (#x725D . #xCCC6) - (#x725E . #x8FCAD9) - (#x725F . #xCCB6) - (#x7260 . #x8FCADA) - (#x7261 . #xB2B4) - (#x7262 . #xCFB4) - (#x7263 . #x8FCADB) - (#x7267 . #xCBD2) - (#x7268 . #x8FCADC) - (#x7269 . #xCAAA) - (#x726B . #x8FCADD) - (#x726E . #x8FCADE) - (#x726F . #x8FCADF) - (#x7271 . #x8FCAE0) - (#x7272 . #xC0B7) - (#x7274 . #xE0B2) - (#x7277 . #x8FCAE1) - (#x7278 . #x8FCAE2) - (#x7279 . #xC6C3) - (#x727B . #x8FCAE3) - (#x727C . #x8FCAE4) - (#x727D . #xB8A3) - (#x727E . #xE0B3) - (#x727F . #x8FCAE5) - (#x7280 . #xBAD4) - (#x7281 . #xE0B5) - (#x7282 . #xE0B4) - (#x7284 . #x8FCAE6) - (#x7287 . #xE0B6) - (#x7289 . #x8FCAE7) - (#x728D . #x8FCAE8) - (#x728E . #x8FCAE9) - (#x7292 . #xE0B7) - (#x7293 . #x8FCAEA) - (#x7296 . #xE0B8) - (#x729B . #x8FCAEB) - (#x72A0 . #xB5BE) - (#x72A2 . #xE0B9) - (#x72A7 . #xE0BA) - (#x72A8 . #x8FCAEC) - (#x72AC . #xB8A4) - (#x72AD . #x8FCAED) - (#x72AE . #x8FCAEE) - (#x72AF . #xC8C8) - (#x72B1 . #x8FCAEF) - (#x72B2 . #xE0BC) - (#x72B4 . #x8FCAF0) - (#x72B6 . #xBEF5) - (#x72B9 . #xE0BB) - (#x72BE . #x8FCAF1) - (#x72C1 . #x8FCAF2) - (#x72C2 . #xB6B8) - (#x72C3 . #xE0BD) - (#x72C4 . #xE0BF) - (#x72C6 . #xE0BE) - (#x72C7 . #x8FCAF3) - (#x72C9 . #x8FCAF4) - (#x72CC . #x8FCAF5) - (#x72CE . #xE0C0) - (#x72D0 . #xB8D1) - (#x72D2 . #xE0C1) - (#x72D5 . #x8FCAF6) - (#x72D6 . #x8FCAF7) - (#x72D7 . #xB6E9) - (#x72D8 . #x8FCAF8) - (#x72D9 . #xC1C0) - (#x72DB . #xB9FD) - (#x72DF . #x8FCAF9) - (#x72E0 . #xE0C3) - (#x72E1 . #xE0C4) - (#x72E2 . #xE0C2) - (#x72E5 . #x8FCAFA) - (#x72E9 . #xBCED) - (#x72EC . #xC6C8) - (#x72ED . #xB6B9) - (#x72F3 . #x8FCAFB) - (#x72F4 . #x8FCAFC) - (#x72F7 . #xE0C6) - (#x72F8 . #xC3AC) - (#x72F9 . #xE0C5) - (#x72FA . #x8FCAFD) - (#x72FB . #x8FCAFE) - (#x72FC . #xCFB5) - (#x72FD . #xC7E2) - (#x72FE . #x8FCBA1) - (#x7302 . #x8FCBA2) - (#x7304 . #x8FCBA3) - (#x7305 . #x8FCBA4) - (#x7307 . #x8FCBA5) - (#x730A . #xE0C9) - (#x730B . #x8FCBA6) - (#x730D . #x8FCBA7) - (#x7312 . #x8FCBA8) - (#x7313 . #x8FCBA9) - (#x7316 . #xE0CB) - (#x7317 . #xE0C8) - (#x7318 . #x8FCBAA) - (#x7319 . #x8FCBAB) - (#x731B . #xCCD4) - (#x731C . #xE0CA) - (#x731D . #xE0CC) - (#x731E . #x8FCBAC) - (#x731F . #xCEC4) - (#x7322 . #x8FCBAD) - (#x7324 . #x8FCBAE) - (#x7325 . #xE0D0) - (#x7327 . #x8FCBAF) - (#x7328 . #x8FCBB0) - (#x7329 . #xE0CF) - (#x732A . #xC3F6) - (#x732B . #xC7AD) - (#x732C . #x8FCBB1) - (#x732E . #xB8A5) - (#x732F . #xE0CE) - (#x7331 . #x8FCBB2) - (#x7332 . #x8FCBB3) - (#x7334 . #xE0CD) - (#x7335 . #x8FCBB4) - (#x7336 . #xCDB1) - (#x7337 . #xCDB2) - (#x733A . #x8FCBB5) - (#x733B . #x8FCBB6) - (#x733D . #x8FCBB7) - (#x733E . #xE0D1) - (#x733F . #xB1EE) - (#x7343 . #x8FCBB8) - (#x7344 . #xB9F6) - (#x7345 . #xBBE2) - (#x734D . #x8FCBB9) - (#x734E . #xE0D2) - (#x734F . #xE0D3) - (#x7350 . #x8FCBBA) - (#x7352 . #x8FCBBB) - (#x7356 . #x8FCBBC) - (#x7357 . #xE0D5) - (#x7358 . #x8FCBBD) - (#x735D . #x8FCBBE) - (#x735E . #x8FCBBF) - (#x735F . #x8FCBC0) - (#x7360 . #x8FCBC1) - (#x7363 . #xBDC3) - (#x7366 . #x8FCBC2) - (#x7367 . #x8FCBC3) - (#x7368 . #xE0D7) - (#x7369 . #x8FCBC4) - (#x736A . #xE0D6) - (#x736B . #x8FCBC5) - (#x736C . #x8FCBC6) - (#x736E . #x8FCBC7) - (#x736F . #x8FCBC8) - (#x7370 . #xE0D8) - (#x7371 . #x8FCBC9) - (#x7372 . #xB3CD) - (#x7375 . #xE0DA) - (#x7377 . #x8FCBCA) - (#x7378 . #xE0D9) - (#x7379 . #x8FCBCB) - (#x737A . #xE0DC) - (#x737B . #xE0DB) - (#x737C . #x8FCBCC) - (#x7380 . #x8FCBCD) - (#x7381 . #x8FCBCE) - (#x7383 . #x8FCBCF) - (#x7384 . #xB8BC) - (#x7385 . #x8FCBD0) - (#x7386 . #x8FCBD1) - (#x7387 . #xCEA8) - (#x7389 . #xB6CC) - (#x738B . #xB2A6) - (#x738E . #x8FCBD2) - (#x7390 . #x8FCBD3) - (#x7393 . #x8FCBD4) - (#x7395 . #x8FCBD5) - (#x7396 . #xB6EA) - (#x7397 . #x8FCBD6) - (#x7398 . #x8FCBD7) - (#x739C . #x8FCBD8) - (#x739E . #x8FCBD9) - (#x739F . #x8FCBDA) - (#x73A0 . #x8FCBDB) - (#x73A2 . #x8FCBDC) - (#x73A5 . #x8FCBDD) - (#x73A6 . #x8FCBDE) - (#x73A9 . #xB4E1) - (#x73AA . #x8FCBDF) - (#x73AB . #x8FCBE0) - (#x73AD . #x8FCBE1) - (#x73B2 . #xCEE8) - (#x73B3 . #xE0DE) - (#x73B5 . #x8FCBE2) - (#x73B7 . #x8FCBE3) - (#x73B9 . #x8FCBE4) - (#x73BB . #xE0E0) - (#x73BC . #x8FCBE5) - (#x73BD . #x8FCBE6) - (#x73BF . #x8FCBE7) - (#x73C0 . #xE0E1) - (#x73C2 . #xB2D1) - (#x73C5 . #x8FCBE8) - (#x73C6 . #x8FCBE9) - (#x73C8 . #xE0DD) - (#x73C9 . #x8FCBEA) - (#x73CA . #xBBB9) - (#x73CB . #x8FCBEB) - (#x73CC . #x8FCBEC) - (#x73CD . #xC4C1) - (#x73CE . #xE0DF) - (#x73CF . #x8FCBED) - (#x73D2 . #x8FCBEE) - (#x73D3 . #x8FCBEF) - (#x73D6 . #x8FCBF0) - (#x73D9 . #x8FCBF1) - (#x73DD . #x8FCBF2) - (#x73DE . #xE0E4) - (#x73E0 . #xBCEE) - (#x73E1 . #x8FCBF3) - (#x73E3 . #x8FCBF4) - (#x73E5 . #xE0E2) - (#x73E6 . #x8FCBF5) - (#x73E7 . #x8FCBF6) - (#x73E9 . #x8FCBF7) - (#x73EA . #xB7BE) - (#x73ED . #xC8C9) - (#x73EE . #xE0E3) - (#x73F1 . #xE0FE) - (#x73F4 . #x8FCBF8) - (#x73F5 . #x8FCBF9) - (#x73F7 . #x8FCBFA) - (#x73F8 . #xE0E9) - (#x73F9 . #x8FCBFB) - (#x73FA . #x8FCBFC) - (#x73FB . #x8FCBFD) - (#x73FD . #x8FCBFE) - (#x73FE . #xB8BD) - (#x73FF . #x8FCCA1) - (#x7400 . #x8FCCA2) - (#x7401 . #x8FCCA3) - (#x7403 . #xB5E5) - (#x7404 . #x8FCCA4) - (#x7405 . #xE0E6) - (#x7406 . #xCDFD) - (#x7407 . #x8FCCA5) - (#x7409 . #xCEB0) - (#x740A . #x8FCCA6) - (#x7411 . #x8FCCA7) - (#x741A . #x8FCCA8) - (#x741B . #x8FCCA9) - (#x7422 . #xC2F6) - (#x7424 . #x8FCCAA) - (#x7425 . #xE0E8) - (#x7426 . #x8FCCAB) - (#x7428 . #x8FCCAC) - (#x7429 . #x8FCCAD) - (#x742A . #x8FCCAE) - (#x742B . #x8FCCAF) - (#x742C . #x8FCCB0) - (#x742D . #x8FCCB1) - (#x742E . #x8FCCB2) - (#x742F . #x8FCCB3) - (#x7430 . #x8FCCB4) - (#x7431 . #x8FCCB5) - (#x7432 . #xE0EA) - (#x7433 . #xCED6) - (#x7434 . #xB6D7) - (#x7435 . #xC8FC) - (#x7436 . #xC7CA) - (#x7439 . #x8FCCB6) - (#x743A . #xE0EB) - (#x743F . #xE0ED) - (#x7440 . #x8FCCB7) - (#x7441 . #xE0F0) - (#x7443 . #x8FCCB8) - (#x7444 . #x8FCCB9) - (#x7446 . #x8FCCBA) - (#x7447 . #x8FCCBB) - (#x744B . #x8FCCBC) - (#x744D . #x8FCCBD) - (#x7451 . #x8FCCBE) - (#x7452 . #x8FCCBF) - (#x7455 . #xE0EC) - (#x7457 . #x8FCCC0) - (#x7459 . #xE0EF) - (#x745A . #xB8EA) - (#x745B . #xB1CD) - (#x745C . #xE0F1) - (#x745D . #x8FCCC1) - (#x745E . #xBFF0) - (#x745F . #xE0EE) - (#x7460 . #xCEDC) - (#x7462 . #x8FCCC2) - (#x7463 . #xE0F4) - (#x7464 . #xF4A4) - (#x7466 . #x8FCCC3) - (#x7467 . #x8FCCC4) - (#x7468 . #x8FCCC5) - (#x7469 . #xE0F2) - (#x746A . #xE0F5) - (#x746B . #x8FCCC6) - (#x746D . #x8FCCC7) - (#x746E . #x8FCCC8) - (#x746F . #xE0E7) - (#x7470 . #xE0F3) - (#x7471 . #x8FCCC9) - (#x7472 . #x8FCCCA) - (#x7473 . #xBABC) - (#x7476 . #xE0F6) - (#x747E . #xE0F7) - (#x7480 . #x8FCCCB) - (#x7481 . #x8FCCCC) - (#x7483 . #xCDFE) - (#x7485 . #x8FCCCD) - (#x7486 . #x8FCCCE) - (#x7487 . #x8FCCCF) - (#x7489 . #x8FCCD0) - (#x748B . #xE0F8) - (#x748F . #x8FCCD1) - (#x7490 . #x8FCCD2) - (#x7491 . #x8FCCD3) - (#x7492 . #x8FCCD4) - (#x7498 . #x8FCCD5) - (#x7499 . #x8FCCD6) - (#x749A . #x8FCCD7) - (#x749C . #x8FCCD8) - (#x749E . #xE0F9) - (#x749F . #x8FCCD9) - (#x74A0 . #x8FCCDA) - (#x74A1 . #x8FCCDB) - (#x74A2 . #xE0E5) - (#x74A3 . #x8FCCDC) - (#x74A6 . #x8FCCDD) - (#x74A7 . #xE0FA) - (#x74A8 . #x8FCCDE) - (#x74A9 . #x8FCCDF) - (#x74AA . #x8FCCE0) - (#x74AB . #x8FCCE1) - (#x74AE . #x8FCCE2) - (#x74AF . #x8FCCE3) - (#x74B0 . #xB4C4) - (#x74B1 . #x8FCCE4) - (#x74B2 . #x8FCCE5) - (#x74B5 . #x8FCCE6) - (#x74B9 . #x8FCCE7) - (#x74BB . #x8FCCE8) - (#x74BD . #xBCA5) - (#x74BF . #x8FCCE9) - (#x74C8 . #x8FCCEA) - (#x74C9 . #x8FCCEB) - (#x74CA . #xE0FB) - (#x74CC . #x8FCCEC) - (#x74CF . #xE0FC) - (#x74D0 . #x8FCCED) - (#x74D3 . #x8FCCEE) - (#x74D4 . #xE0FD) - (#x74D8 . #x8FCCEF) - (#x74DA . #x8FCCF0) - (#x74DB . #x8FCCF1) - (#x74DC . #xB1BB) - (#x74DE . #x8FCCF2) - (#x74DF . #x8FCCF3) - (#x74E0 . #xE1A1) - (#x74E2 . #xC9BB) - (#x74E3 . #xE1A2) - (#x74E4 . #x8FCCF4) - (#x74E6 . #xB4A4) - (#x74E7 . #xE1A3) - (#x74E8 . #x8FCCF5) - (#x74E9 . #xE1A4) - (#x74EA . #x8FCCF6) - (#x74EB . #x8FCCF7) - (#x74EE . #xE1A5) - (#x74EF . #x8FCCF8) - (#x74F0 . #xE1A7) - (#x74F1 . #xE1A8) - (#x74F2 . #xE1A6) - (#x74F4 . #x8FCCF9) - (#x74F6 . #xC9D3) - (#x74F7 . #xE1AA) - (#x74F8 . #xE1A9) - (#x74FA . #x8FCCFA) - (#x74FB . #x8FCCFB) - (#x74FC . #x8FCCFC) - (#x74FF . #x8FCCFD) - (#x7503 . #xE1AC) - (#x7504 . #xE1AB) - (#x7505 . #xE1AD) - (#x7506 . #x8FCCFE) - (#x750C . #xE1AE) - (#x750D . #xE1B0) - (#x750E . #xE1AF) - (#x7511 . #xB9F9) - (#x7512 . #x8FCDA1) - (#x7513 . #xE1B2) - (#x7515 . #xE1B1) - (#x7516 . #x8FCDA2) - (#x7517 . #x8FCDA3) - (#x7518 . #xB4C5) - (#x751A . #xBFD3) - (#x751C . #xC5BC) - (#x751E . #xE1B3) - (#x751F . #xC0B8) - (#x7520 . #x8FCDA4) - (#x7521 . #x8FCDA5) - (#x7523 . #xBBBA) - (#x7524 . #x8FCDA6) - (#x7525 . #xB1F9) - (#x7526 . #xE1B4) - (#x7527 . #x8FCDA7) - (#x7528 . #xCDD1) - (#x7529 . #x8FCDA8) - (#x752A . #x8FCDA9) - (#x752B . #xCAE3) - (#x752C . #xE1B5) - (#x752F . #x8FCDAA) - (#x7530 . #xC5C4) - (#x7531 . #xCDB3) - (#x7532 . #xB9C3) - (#x7533 . #xBFBD) - (#x7536 . #x8FCDAB) - (#x7537 . #xC3CB) - (#x7538 . #xD2B4) - (#x7539 . #x8FCDAC) - (#x753A . #xC4AE) - (#x753B . #xB2E8) - (#x753C . #xE1B6) - (#x753D . #x8FCDAD) - (#x753E . #x8FCDAE) - (#x753F . #x8FCDAF) - (#x7540 . #x8FCDB0) - (#x7543 . #x8FCDB1) - (#x7544 . #xE1B7) - (#x7546 . #xE1BC) - (#x7547 . #x8FCDB2) - (#x7548 . #x8FCDB3) - (#x7549 . #xE1BA) - (#x754A . #xE1B9) - (#x754B . #xDAC2) - (#x754C . #xB3A6) - (#x754D . #xE1B8) - (#x754E . #x8FCDB4) - (#x754F . #xB0DA) - (#x7550 . #x8FCDB5) - (#x7551 . #xC8AA) - (#x7552 . #x8FCDB6) - (#x7554 . #xC8CA) - (#x7557 . #x8FCDB7) - (#x7559 . #xCEB1) - (#x755A . #xE1BD) - (#x755B . #xE1BB) - (#x755C . #xC3DC) - (#x755D . #xC0A6) - (#x755E . #x8FCDB8) - (#x755F . #x8FCDB9) - (#x7560 . #xC8AB) - (#x7561 . #x8FCDBA) - (#x7562 . #xC9AD) - (#x7564 . #xE1BF) - (#x7565 . #xCEAC) - (#x7566 . #xB7CD) - (#x7567 . #xE1C0) - (#x7569 . #xE1BE) - (#x756A . #xC8D6) - (#x756B . #xE1C1) - (#x756D . #xE1C2) - (#x756F . #x8FCDBB) - (#x7570 . #xB0DB) - (#x7571 . #x8FCDBC) - (#x7573 . #xBEF6) - (#x7574 . #xE1C7) - (#x7576 . #xE1C4) - (#x7577 . #xC6ED) - (#x7578 . #xE1C3) - (#x7579 . #x8FCDBD) - (#x757A . #x8FCDBE) - (#x757B . #x8FCDBF) - (#x757C . #x8FCDC0) - (#x757D . #x8FCDC1) - (#x757E . #x8FCDC2) - (#x757F . #xB5A6) - (#x7581 . #x8FCDC3) - (#x7582 . #xE1CA) - (#x7585 . #x8FCDC4) - (#x7586 . #xE1C5) - (#x7587 . #xE1C6) - (#x7589 . #xE1C9) - (#x758A . #xE1C8) - (#x758B . #xC9A5) - (#x758E . #xC1C2) - (#x758F . #xC1C1) - (#x7590 . #x8FCDC5) - (#x7591 . #xB5BF) - (#x7592 . #x8FCDC6) - (#x7593 . #x8FCDC7) - (#x7594 . #xE1CB) - (#x7595 . #x8FCDC8) - (#x7599 . #x8FCDC9) - (#x759A . #xE1CC) - (#x759C . #x8FCDCA) - (#x759D . #xE1CD) - (#x75A2 . #x8FCDCB) - (#x75A3 . #xE1CF) - (#x75A4 . #x8FCDCC) - (#x75A5 . #xE1CE) - (#x75AB . #xB1D6) - (#x75B1 . #xE1D7) - (#x75B2 . #xC8E8) - (#x75B3 . #xE1D1) - (#x75B4 . #x8FCDCD) - (#x75B5 . #xE1D3) - (#x75B8 . #xE1D5) - (#x75B9 . #xBFBE) - (#x75BA . #x8FCDCE) - (#x75BC . #xE1D6) - (#x75BD . #xE1D4) - (#x75BE . #xBCC0) - (#x75BF . #x8FCDCF) - (#x75C0 . #x8FCDD0) - (#x75C1 . #x8FCDD1) - (#x75C2 . #xE1D0) - (#x75C3 . #xE1D2) - (#x75C4 . #x8FCDD2) - (#x75C5 . #xC9C2) - (#x75C6 . #x8FCDD3) - (#x75C7 . #xBEC9) - (#x75CA . #xE1D9) - (#x75CC . #x8FCDD4) - (#x75CD . #xE1D8) - (#x75CE . #x8FCDD5) - (#x75CF . #x8FCDD6) - (#x75D2 . #xE1DA) - (#x75D4 . #xBCA6) - (#x75D5 . #xBAAF) - (#x75D7 . #x8FCDD7) - (#x75D8 . #xC5F7) - (#x75D9 . #xE1DB) - (#x75DB . #xC4CB) - (#x75DC . #x8FCDD8) - (#x75DE . #xE1DD) - (#x75DF . #x8FCDD9) - (#x75E0 . #x8FCDDA) - (#x75E1 . #x8FCDDB) - (#x75E2 . #xCEA1) - (#x75E3 . #xE1DC) - (#x75E4 . #x8FCDDC) - (#x75E7 . #x8FCDDD) - (#x75E9 . #xC1E9) - (#x75EC . #x8FCDDE) - (#x75EE . #x8FCDDF) - (#x75EF . #x8FCDE0) - (#x75F0 . #xE1E2) - (#x75F1 . #x8FCDE1) - (#x75F2 . #xE1E4) - (#x75F3 . #xE1E5) - (#x75F4 . #xC3D4) - (#x75F9 . #x8FCDE2) - (#x75FA . #xE1E3) - (#x75FC . #xE1E0) - (#x75FE . #xE1DE) - (#x75FF . #xE1DF) - (#x7600 . #x8FCDE3) - (#x7601 . #xE1E1) - (#x7602 . #x8FCDE4) - (#x7603 . #x8FCDE5) - (#x7604 . #x8FCDE6) - (#x7607 . #x8FCDE7) - (#x7608 . #x8FCDE8) - (#x7609 . #xE1E8) - (#x760A . #x8FCDE9) - (#x760B . #xE1E6) - (#x760C . #x8FCDEA) - (#x760D . #xE1E7) - (#x760F . #x8FCDEB) - (#x7612 . #x8FCDEC) - (#x7613 . #x8FCDED) - (#x7615 . #x8FCDEE) - (#x7616 . #x8FCDEF) - (#x7619 . #x8FCDF0) - (#x761B . #x8FCDF1) - (#x761C . #x8FCDF2) - (#x761D . #x8FCDF3) - (#x761E . #x8FCDF4) - (#x761F . #xE1E9) - (#x7620 . #xE1EB) - (#x7621 . #xE1EC) - (#x7622 . #xE1ED) - (#x7623 . #x8FCDF5) - (#x7624 . #xE1EE) - (#x7625 . #x8FCDF6) - (#x7626 . #x8FCDF7) - (#x7627 . #xE1EA) - (#x7629 . #x8FCDF8) - (#x762D . #x8FCDF9) - (#x7630 . #xE1F0) - (#x7632 . #x8FCDFA) - (#x7633 . #x8FCDFB) - (#x7634 . #xE1EF) - (#x7635 . #x8FCDFC) - (#x7638 . #x8FCDFD) - (#x7639 . #x8FCDFE) - (#x763A . #x8FCEA1) - (#x763B . #xE1F1) - (#x763C . #x8FCEA2) - (#x7640 . #x8FCEA4) - (#x7641 . #x8FCEA5) - (#x7642 . #xCEC5) - (#x7643 . #x8FCEA6) - (#x7644 . #x8FCEA7) - (#x7645 . #x8FCEA8) - (#x7646 . #xE1F4) - (#x7647 . #xE1F2) - (#x7648 . #xE1F3) - (#x7649 . #x8FCEA9) - (#x764A . #x8FCEA3) - (#x764B . #x8FCEAA) - (#x764C . #xB4E2) - (#x7652 . #xCCFE) - (#x7655 . #x8FCEAB) - (#x7656 . #xCACA) - (#x7658 . #xE1F6) - (#x7659 . #x8FCEAC) - (#x765C . #xE1F5) - (#x765F . #x8FCEAD) - (#x7661 . #xE1F7) - (#x7662 . #xE1F8) - (#x7664 . #x8FCEAE) - (#x7665 . #x8FCEAF) - (#x7667 . #xE1FC) - (#x7668 . #xE1F9) - (#x7669 . #xE1FA) - (#x766A . #xE1FB) - (#x766C . #xE1FD) - (#x766D . #x8FCEB0) - (#x766E . #x8FCEB1) - (#x766F . #x8FCEB2) - (#x7670 . #xE1FE) - (#x7671 . #x8FCEB3) - (#x7672 . #xE2A1) - (#x7674 . #x8FCEB4) - (#x7676 . #xE2A2) - (#x7678 . #xE2A3) - (#x767A . #xC8AF) - (#x767B . #xC5D0) - (#x767C . #xE2A4) - (#x767D . #xC7F2) - (#x767E . #xC9B4) - (#x7680 . #xE2A5) - (#x7681 . #x8FCEB5) - (#x7683 . #xE2A6) - (#x7684 . #xC5AA) - (#x7685 . #x8FCEB6) - (#x7686 . #xB3A7) - (#x7687 . #xB9C4) - (#x7688 . #xE2A7) - (#x768B . #xE2A8) - (#x768C . #x8FCEB7) - (#x768D . #x8FCEB8) - (#x768E . #xE2A9) - (#x7690 . #xBBA9) - (#x7693 . #xE2AB) - (#x7695 . #x8FCEB9) - (#x7696 . #xE2AA) - (#x7699 . #xE2AC) - (#x769A . #xE2AD) - (#x769B . #x8FCEBA) - (#x769C . #x8FCEBB) - (#x769D . #x8FCEBC) - (#x769F . #x8FCEBD) - (#x76A0 . #x8FCEBE) - (#x76A2 . #x8FCEBF) - (#x76A3 . #x8FCEC0) - (#x76A4 . #x8FCEC1) - (#x76A5 . #x8FCEC2) - (#x76A6 . #x8FCEC3) - (#x76A7 . #x8FCEC4) - (#x76A8 . #x8FCEC5) - (#x76AA . #x8FCEC6) - (#x76AD . #x8FCEC7) - (#x76AE . #xC8E9) - (#x76B0 . #xE2AE) - (#x76B4 . #xE2AF) - (#x76B7 . #xF3E9) - (#x76B8 . #xE2B0) - (#x76B9 . #xE2B1) - (#x76BA . #xE2B2) - (#x76BD . #x8FCEC8) - (#x76BF . #xBBAE) - (#x76C1 . #x8FCEC9) - (#x76C2 . #xE2B3) - (#x76C3 . #xC7D6) - (#x76C5 . #x8FCECA) - (#x76C6 . #xCBDF) - (#x76C8 . #xB1CE) - (#x76C9 . #x8FCECB) - (#x76CA . #xB1D7) - (#x76CB . #x8FCECC) - (#x76CC . #x8FCECD) - (#x76CD . #xE2B4) - (#x76CE . #x8FCECE) - (#x76D2 . #xE2B6) - (#x76D4 . #x8FCECF) - (#x76D6 . #xE2B5) - (#x76D7 . #xC5F0) - (#x76D9 . #x8FCED0) - (#x76DB . #xC0B9) - (#x76DC . #xDDB9) - (#x76DE . #xE2B7) - (#x76DF . #xCCC1) - (#x76E0 . #x8FCED1) - (#x76E1 . #xE2B8) - (#x76E3 . #xB4C6) - (#x76E4 . #xC8D7) - (#x76E5 . #xE2B9) - (#x76E6 . #x8FCED2) - (#x76E7 . #xE2BA) - (#x76E8 . #x8FCED3) - (#x76EA . #xE2BB) - (#x76EC . #x8FCED4) - (#x76EE . #xCCDC) - (#x76F0 . #x8FCED5) - (#x76F1 . #x8FCED6) - (#x76F2 . #xCCD5) - (#x76F4 . #xC4BE) - (#x76F6 . #x8FCED7) - (#x76F8 . #xC1EA) - (#x76F9 . #x8FCED8) - (#x76FB . #xE2BD) - (#x76FC . #x8FCED9) - (#x76FE . #xBDE2) - (#x7700 . #x8FCEDA) - (#x7701 . #xBECA) - (#x7704 . #xE2C0) - (#x7706 . #x8FCEDB) - (#x7707 . #xE2BF) - (#x7708 . #xE2BE) - (#x7709 . #xC8FD) - (#x770A . #x8FCEDC) - (#x770B . #xB4C7) - (#x770C . #xB8A9) - (#x770E . #x8FCEDD) - (#x7712 . #x8FCEDE) - (#x7714 . #x8FCEDF) - (#x7715 . #x8FCEE0) - (#x7717 . #x8FCEE1) - (#x7719 . #x8FCEE2) - (#x771A . #x8FCEE3) - (#x771B . #xE2C6) - (#x771C . #x8FCEE4) - (#x771E . #xE2C3) - (#x771F . #xBFBF) - (#x7720 . #xCCB2) - (#x7722 . #x8FCEE5) - (#x7724 . #xE2C2) - (#x7725 . #xE2C4) - (#x7726 . #xE2C5) - (#x7728 . #x8FCEE6) - (#x7729 . #xE2C1) - (#x772D . #x8FCEE7) - (#x772E . #x8FCEE8) - (#x772F . #x8FCEE9) - (#x7734 . #x8FCEEA) - (#x7735 . #x8FCEEB) - (#x7736 . #x8FCEEC) - (#x7737 . #xE2C7) - (#x7738 . #xE2C8) - (#x7739 . #x8FCEED) - (#x773A . #xC4AF) - (#x773C . #xB4E3) - (#x773D . #x8FCEEE) - (#x773E . #x8FCEEF) - (#x7740 . #xC3E5) - (#x7742 . #x8FCEF0) - (#x7745 . #x8FCEF1) - (#x7746 . #x8FCEF2) - (#x7747 . #xE2C9) - (#x774A . #x8FCEF3) - (#x774D . #x8FCEF4) - (#x774E . #x8FCEF5) - (#x774F . #x8FCEF6) - (#x7752 . #x8FCEF7) - (#x7756 . #x8FCEF8) - (#x7757 . #x8FCEF9) - (#x775A . #xE2CA) - (#x775B . #xE2CD) - (#x775C . #x8FCEFA) - (#x775E . #x8FCEFB) - (#x775F . #x8FCEFC) - (#x7760 . #x8FCEFD) - (#x7761 . #xBFE7) - (#x7762 . #x8FCEFE) - (#x7763 . #xC6C4) - (#x7764 . #x8FCFA1) - (#x7765 . #xE2CE) - (#x7766 . #xCBD3) - (#x7767 . #x8FCFA2) - (#x7768 . #xE2CB) - (#x776A . #x8FCFA3) - (#x776B . #xE2CC) - (#x776C . #x8FCFA4) - (#x7770 . #x8FCFA5) - (#x7772 . #x8FCFA6) - (#x7773 . #x8FCFA7) - (#x7774 . #x8FCFA8) - (#x7779 . #xE2D1) - (#x777A . #x8FCFA9) - (#x777D . #x8FCFAA) - (#x777E . #xE2D0) - (#x777F . #xE2CF) - (#x7780 . #x8FCFAB) - (#x7784 . #x8FCFAC) - (#x778B . #xE2D3) - (#x778C . #x8FCFAD) - (#x778D . #x8FCFAE) - (#x778E . #xE2D2) - (#x7791 . #xE2D4) - (#x7794 . #x8FCFAF) - (#x7795 . #x8FCFB0) - (#x7796 . #x8FCFB1) - (#x779A . #x8FCFB2) - (#x779E . #xE2D6) - (#x779F . #x8FCFB3) - (#x77A0 . #xE2D5) - (#x77A2 . #x8FCFB4) - (#x77A5 . #xCACD) - (#x77A7 . #x8FCFB5) - (#x77AA . #x8FCFB6) - (#x77AC . #xBDD6) - (#x77AD . #xCEC6) - (#x77AE . #x8FCFB7) - (#x77AF . #x8FCFB8) - (#x77B0 . #xE2D7) - (#x77B1 . #x8FCFB9) - (#x77B3 . #xC6B7) - (#x77B5 . #x8FCFBA) - (#x77B6 . #xE2D8) - (#x77B9 . #xE2D9) - (#x77BB . #xE2DD) - (#x77BC . #xE2DB) - (#x77BD . #xE2DC) - (#x77BE . #x8FCFBB) - (#x77BF . #xE2DA) - (#x77C3 . #x8FCFBC) - (#x77C7 . #xE2DE) - (#x77C9 . #x8FCFBD) - (#x77CD . #xE2DF) - (#x77D1 . #x8FCFBE) - (#x77D2 . #x8FCFBF) - (#x77D5 . #x8FCFC0) - (#x77D7 . #xE2E0) - (#x77D9 . #x8FCFC1) - (#x77DA . #xE2E1) - (#x77DB . #xCCB7) - (#x77DC . #xE2E2) - (#x77DE . #x8FCFC2) - (#x77DF . #x8FCFC3) - (#x77E0 . #x8FCFC4) - (#x77E2 . #xCCF0) - (#x77E3 . #xE2E3) - (#x77E4 . #x8FCFC5) - (#x77E5 . #xC3CE) - (#x77E6 . #x8FCFC6) - (#x77E7 . #xC7EA) - (#x77E9 . #xB6EB) - (#x77EA . #x8FCFC7) - (#x77EC . #x8FCFC8) - (#x77ED . #xC3BB) - (#x77EE . #xE2E4) - (#x77EF . #xB6BA) - (#x77F0 . #x8FCFC9) - (#x77F1 . #x8FCFCA) - (#x77F3 . #xC0D0) - (#x77F4 . #x8FCFCB) - (#x77F8 . #x8FCFCC) - (#x77FB . #x8FCFCD) - (#x77FC . #xE2E5) - (#x7802 . #xBABD) - (#x7805 . #x8FCFCE) - (#x7806 . #x8FCFCF) - (#x7809 . #x8FCFD0) - (#x780C . #xE2E6) - (#x780D . #x8FCFD1) - (#x780E . #x8FCFD2) - (#x7811 . #x8FCFD3) - (#x7812 . #xE2E7) - (#x7814 . #xB8A6) - (#x7815 . #xBAD5) - (#x781D . #x8FCFD4) - (#x7820 . #xE2E9) - (#x7821 . #x8FCFD5) - (#x7822 . #x8FCFD6) - (#x7823 . #x8FCFD7) - (#x7825 . #xC5D6) - (#x7826 . #xBAD6) - (#x7827 . #xB5CE) - (#x782D . #x8FCFD8) - (#x782E . #x8FCFD9) - (#x7830 . #x8FCFDA) - (#x7832 . #xCBA4) - (#x7834 . #xC7CB) - (#x7835 . #x8FCFDB) - (#x7837 . #x8FCFDC) - (#x783A . #xC5D7) - (#x783F . #xB9DC) - (#x7843 . #x8FCFDD) - (#x7844 . #x8FCFDE) - (#x7845 . #xE2EB) - (#x7847 . #x8FCFDF) - (#x7848 . #x8FCFE0) - (#x784C . #x8FCFE1) - (#x784E . #x8FCFE2) - (#x7852 . #x8FCFE3) - (#x785C . #x8FCFE4) - (#x785D . #xBECB) - (#x785E . #x8FCFE5) - (#x7860 . #x8FCFE6) - (#x7861 . #x8FCFE7) - (#x7863 . #x8FCFE8) - (#x7864 . #x8FCFE9) - (#x7868 . #x8FCFEA) - (#x786A . #x8FCFEB) - (#x786B . #xCEB2) - (#x786C . #xB9C5) - (#x786E . #x8FCFEC) - (#x786F . #xB8A7) - (#x7872 . #xC8A3) - (#x7874 . #xE2ED) - (#x787A . #x8FCFED) - (#x787C . #xE2EF) - (#x787E . #x8FCFEE) - (#x7881 . #xB8EB) - (#x7886 . #xE2EE) - (#x7887 . #xC4F6) - (#x788A . #x8FCFEF) - (#x788C . #xE2F1) - (#x788D . #xB3B7) - (#x788E . #xE2EC) - (#x788F . #x8FCFF0) - (#x7891 . #xC8EA) - (#x7893 . #xB1B0) - (#x7894 . #x8FCFF1) - (#x7895 . #xBAEC) - (#x7897 . #xCFD2) - (#x7898 . #x8FCFF2) - (#x789A . #xE2F0) - (#x789D . #x8FCFF4) - (#x789E . #x8FCFF5) - (#x789F . #x8FCFF6) - (#x78A1 . #x8FCFF3) - (#x78A3 . #xE2F2) - (#x78A4 . #x8FCFF7) - (#x78A7 . #xCACB) - (#x78A8 . #x8FCFF8) - (#x78A9 . #xC0D9) - (#x78AA . #xE2F4) - (#x78AC . #x8FCFF9) - (#x78AD . #x8FCFFA) - (#x78AF . #xE2F5) - (#x78B0 . #x8FCFFB) - (#x78B1 . #x8FCFFC) - (#x78B2 . #x8FCFFD) - (#x78B3 . #x8FCFFE) - (#x78B5 . #xE2F3) - (#x78BA . #xB3CE) - (#x78BB . #x8FD0A1) - (#x78BC . #xE2FB) - (#x78BD . #x8FD0A2) - (#x78BE . #xE2FA) - (#x78BF . #x8FD0A3) - (#x78C1 . #xBCA7) - (#x78C5 . #xE2FC) - (#x78C6 . #xE2F7) - (#x78C7 . #x8FD0A4) - (#x78C8 . #x8FD0A5) - (#x78C9 . #x8FD0A6) - (#x78CA . #xE2FD) - (#x78CB . #xE2F8) - (#x78CC . #x8FD0A7) - (#x78CE . #x8FD0A8) - (#x78D0 . #xC8D8) - (#x78D1 . #xE2F6) - (#x78D2 . #x8FD0A9) - (#x78D3 . #x8FD0AA) - (#x78D4 . #xE2F9) - (#x78D5 . #x8FD0AB) - (#x78D6 . #x8FD0AC) - (#x78DA . #xE3A2) - (#x78DB . #x8FD0AE) - (#x78DF . #x8FD0AF) - (#x78E0 . #x8FD0B0) - (#x78E1 . #x8FD0B1) - (#x78E4 . #x8FD0AD) - (#x78E6 . #x8FD0B2) - (#x78E7 . #xE3A1) - (#x78E8 . #xCBE1) - (#x78EA . #x8FD0B3) - (#x78EC . #xE2FE) - (#x78EF . #xB0EB) - (#x78F2 . #x8FD0B4) - (#x78F3 . #x8FD0B5) - (#x78F4 . #xE3A4) - (#x78F6 . #x8FD0B7) - (#x78F7 . #x8FD0B8) - (#x78FA . #x8FD0B9) - (#x78FB . #x8FD0BA) - (#x78FD . #xE3A3) - (#x78FF . #x8FD0BB) - (#x7900 . #x8FD0B6) - (#x7901 . #xBECC) - (#x7906 . #x8FD0BC) - (#x7907 . #xE3A5) - (#x790C . #x8FD0BD) - (#x790E . #xC1C3) - (#x7910 . #x8FD0BE) - (#x7911 . #xE3A7) - (#x7912 . #xE3A6) - (#x7919 . #xE3A8) - (#x791A . #x8FD0BF) - (#x791C . #x8FD0C0) - (#x791E . #x8FD0C1) - (#x791F . #x8FD0C2) - (#x7920 . #x8FD0C3) - (#x7925 . #x8FD0C4) - (#x7926 . #xE2E8) - (#x7927 . #x8FD0C5) - (#x7929 . #x8FD0C6) - (#x792A . #xE2EA) - (#x792B . #xE3AA) - (#x792C . #xE3A9) - (#x792D . #x8FD0C7) - (#x7931 . #x8FD0C8) - (#x7934 . #x8FD0C9) - (#x7935 . #x8FD0CA) - (#x793A . #xBCA8) - (#x793B . #x8FD0CB) - (#x793C . #xCEE9) - (#x793D . #x8FD0CC) - (#x793E . #xBCD2) - (#x793F . #x8FD0CD) - (#x7940 . #xE3AB) - (#x7941 . #xB7B7) - (#x7944 . #x8FD0CE) - (#x7945 . #x8FD0CF) - (#x7946 . #x8FD0D0) - (#x7947 . #xB5C0) - (#x7948 . #xB5A7) - (#x7949 . #xBBE3) - (#x794A . #x8FD0D1) - (#x794B . #x8FD0D2) - (#x794F . #x8FD0D3) - (#x7950 . #xCDB4) - (#x7951 . #x8FD0D4) - (#x7953 . #xE3B1) - (#x7954 . #x8FD0D5) - (#x7955 . #xE3B0) - (#x7956 . #xC1C4) - (#x7957 . #xE3AD) - (#x7958 . #x8FD0D6) - (#x795A . #xE3AF) - (#x795B . #x8FD0D7) - (#x795C . #x8FD0D8) - (#x795D . #xBDCB) - (#x795E . #xBFC0) - (#x795F . #xE3AE) - (#x7960 . #xE3AC) - (#x7962 . #xC7AA) - (#x7965 . #xBECD) - (#x7967 . #x8FD0D9) - (#x7968 . #xC9BC) - (#x7969 . #x8FD0DA) - (#x796B . #x8FD0DB) - (#x796D . #xBAD7) - (#x7972 . #x8FD0DC) - (#x7977 . #xC5F8) - (#x7979 . #x8FD0DD) - (#x797A . #xE3B2) - (#x797B . #x8FD0DE) - (#x797C . #x8FD0DF) - (#x797E . #x8FD0E0) - (#x797F . #xE3B3) - (#x7980 . #xE3C9) - (#x7981 . #xB6D8) - (#x7984 . #xCFBD) - (#x7985 . #xC1B5) - (#x798A . #xE3B4) - (#x798B . #x8FD0E1) - (#x798C . #x8FD0E2) - (#x798D . #xB2D2) - (#x798E . #xC4F7) - (#x798F . #xCAA1) - (#x7991 . #x8FD0E3) - (#x7993 . #x8FD0E4) - (#x7994 . #x8FD0E5) - (#x7995 . #x8FD0E6) - (#x7996 . #x8FD0E7) - (#x7998 . #x8FD0E8) - (#x799B . #x8FD0E9) - (#x799C . #x8FD0EA) - (#x799D . #xE3B5) - (#x79A1 . #x8FD0EB) - (#x79A6 . #xB5FA) - (#x79A7 . #xE3B6) - (#x79A8 . #x8FD0EC) - (#x79A9 . #x8FD0ED) - (#x79AA . #xE3B8) - (#x79AB . #x8FD0EE) - (#x79AE . #xE3B9) - (#x79AF . #x8FD0EF) - (#x79B0 . #xC7A9) - (#x79B1 . #x8FD0F0) - (#x79B3 . #xE3BA) - (#x79B4 . #x8FD0F1) - (#x79B8 . #x8FD0F2) - (#x79B9 . #xE3BB) - (#x79BA . #xE3BC) - (#x79BB . #x8FD0F3) - (#x79BD . #xB6D9) - (#x79BE . #xB2D3) - (#x79BF . #xC6C5) - (#x79C0 . #xBDA8) - (#x79C1 . #xBBE4) - (#x79C2 . #x8FD0F4) - (#x79C4 . #x8FD0F5) - (#x79C7 . #x8FD0F6) - (#x79C8 . #x8FD0F7) - (#x79C9 . #xE3BD) - (#x79CA . #x8FD0F8) - (#x79CB . #xBDA9) - (#x79CF . #x8FD0F9) - (#x79D1 . #xB2CA) - (#x79D2 . #xC9C3) - (#x79D4 . #x8FD0FA) - (#x79D5 . #xE3BE) - (#x79D6 . #x8FD0FB) - (#x79D8 . #xC8EB) - (#x79DA . #x8FD0FC) - (#x79DD . #x8FD0FD) - (#x79DE . #x8FD0FE) - (#x79DF . #xC1C5) - (#x79E0 . #x8FD1A1) - (#x79E1 . #xE3C1) - (#x79E2 . #x8FD1A2) - (#x79E3 . #xE3C2) - (#x79E4 . #xC7E9) - (#x79E5 . #x8FD1A3) - (#x79E6 . #xBFC1) - (#x79E7 . #xE3BF) - (#x79E9 . #xC3E1) - (#x79EA . #x8FD1A4) - (#x79EB . #x8FD1A5) - (#x79EC . #xE3C0) - (#x79ED . #x8FD1A6) - (#x79F0 . #xBECE) - (#x79F1 . #x8FD1A7) - (#x79F8 . #x8FD1A8) - (#x79FB . #xB0DC) - (#x79FC . #x8FD1A9) - (#x7A00 . #xB5A9) - (#x7A02 . #x8FD1AA) - (#x7A03 . #x8FD1AB) - (#x7A07 . #x8FD1AC) - (#x7A08 . #xE3C3) - (#x7A09 . #x8FD1AD) - (#x7A0A . #x8FD1AE) - (#x7A0B . #xC4F8) - (#x7A0C . #x8FD1AF) - (#x7A0D . #xE3C4) - (#x7A0E . #xC0C7) - (#x7A11 . #x8FD1B0) - (#x7A14 . #xCCAD) - (#x7A15 . #x8FD1B1) - (#x7A17 . #xC9A3) - (#x7A18 . #xE3C5) - (#x7A19 . #xE3C6) - (#x7A1A . #xC3D5) - (#x7A1B . #x8FD1B2) - (#x7A1C . #xCEC7) - (#x7A1E . #x8FD1B3) - (#x7A1F . #xE3C8) - (#x7A20 . #xE3C7) - (#x7A21 . #x8FD1B4) - (#x7A27 . #x8FD1B5) - (#x7A2B . #x8FD1B6) - (#x7A2D . #x8FD1B7) - (#x7A2E . #xBCEF) - (#x7A2F . #x8FD1B8) - (#x7A30 . #x8FD1B9) - (#x7A31 . #xE3CA) - (#x7A32 . #xB0F0) - (#x7A34 . #x8FD1BA) - (#x7A35 . #x8FD1BB) - (#x7A37 . #xE3CD) - (#x7A38 . #x8FD1BC) - (#x7A39 . #x8FD1BD) - (#x7A3A . #x8FD1BE) - (#x7A3B . #xE3CB) - (#x7A3C . #xB2D4) - (#x7A3D . #xB7CE) - (#x7A3E . #xE3CC) - (#x7A3F . #xB9C6) - (#x7A40 . #xB9F2) - (#x7A42 . #xCAE6) - (#x7A43 . #xE3CE) - (#x7A44 . #x8FD1BF) - (#x7A45 . #x8FD1C0) - (#x7A46 . #xCBD4) - (#x7A47 . #x8FD1C1) - (#x7A48 . #x8FD1C2) - (#x7A49 . #xE3D0) - (#x7A4C . #x8FD1C3) - (#x7A4D . #xC0D1) - (#x7A4E . #xB1CF) - (#x7A4F . #xB2BA) - (#x7A50 . #xB0AC) - (#x7A55 . #x8FD1C4) - (#x7A56 . #x8FD1C5) - (#x7A57 . #xE3CF) - (#x7A59 . #x8FD1C6) - (#x7A5C . #x8FD1C7) - (#x7A5D . #x8FD1C8) - (#x7A5F . #x8FD1C9) - (#x7A60 . #x8FD1CA) - (#x7A61 . #xE3D1) - (#x7A62 . #xE3D2) - (#x7A63 . #xBEF7) - (#x7A65 . #x8FD1CB) - (#x7A67 . #x8FD1CC) - (#x7A69 . #xE3D3) - (#x7A6A . #x8FD1CD) - (#x7A6B . #xB3CF) - (#x7A6D . #x8FD1CE) - (#x7A70 . #xE3D5) - (#x7A74 . #xB7EA) - (#x7A75 . #x8FD1CF) - (#x7A76 . #xB5E6) - (#x7A78 . #x8FD1D0) - (#x7A79 . #xE3D6) - (#x7A7A . #xB6F5) - (#x7A7D . #xE3D7) - (#x7A7E . #x8FD1D1) - (#x7A7F . #xC0FC) - (#x7A80 . #x8FD1D2) - (#x7A81 . #xC6CD) - (#x7A82 . #x8FD1D3) - (#x7A83 . #xC0E0) - (#x7A84 . #xBAF5) - (#x7A85 . #x8FD1D4) - (#x7A86 . #x8FD1D5) - (#x7A88 . #xE3D8) - (#x7A8A . #x8FD1D6) - (#x7A8B . #x8FD1D7) - (#x7A90 . #x8FD1D8) - (#x7A91 . #x8FD1D9) - (#x7A92 . #xC3E2) - (#x7A93 . #xC1EB) - (#x7A94 . #x8FD1DA) - (#x7A95 . #xE3DA) - (#x7A96 . #xE3DC) - (#x7A97 . #xE3D9) - (#x7A98 . #xE3DB) - (#x7A9E . #x8FD1DB) - (#x7A9F . #xB7A2) - (#x7AA0 . #x8FD1DC) - (#x7AA3 . #x8FD1DD) - (#x7AA9 . #xE3DD) - (#x7AAA . #xB7A6) - (#x7AAC . #x8FD1DE) - (#x7AAE . #xB5E7) - (#x7AAF . #xCDD2) - (#x7AB0 . #xE3DF) - (#x7AB3 . #x8FD1DF) - (#x7AB5 . #x8FD1E0) - (#x7AB6 . #xE3E0) - (#x7AB9 . #x8FD1E1) - (#x7ABA . #xB1AE) - (#x7ABB . #x8FD1E2) - (#x7ABC . #x8FD1E3) - (#x7ABF . #xE3E3) - (#x7AC3 . #xB3F6) - (#x7AC4 . #xE3E2) - (#x7AC5 . #xE3E1) - (#x7AC6 . #x8FD1E4) - (#x7AC7 . #xE3E5) - (#x7AC8 . #xE3DE) - (#x7AC9 . #x8FD1E5) - (#x7ACA . #xE3E6) - (#x7ACB . #xCEA9) - (#x7ACC . #x8FD1E6) - (#x7ACD . #xE3E7) - (#x7ACE . #x8FD1E7) - (#x7ACF . #xE3E8) - (#x7AD1 . #x8FD1E8) - (#x7AD2 . #xD4F4) - (#x7AD3 . #xE3EA) - (#x7AD5 . #xE3E9) - (#x7AD9 . #xE3EB) - (#x7ADA . #xE3EC) - (#x7ADB . #x8FD1E9) - (#x7ADC . #xCEB5) - (#x7ADD . #xE3ED) - (#x7ADF . #xF0EF) - (#x7AE0 . #xBECF) - (#x7AE1 . #xE3EE) - (#x7AE2 . #xE3EF) - (#x7AE3 . #xBDD7) - (#x7AE5 . #xC6B8) - (#x7AE6 . #xE3F0) - (#x7AE8 . #x8FD1EA) - (#x7AE9 . #x8FD1EB) - (#x7AEA . #xC3A8) - (#x7AEB . #x8FD1EC) - (#x7AEC . #x8FD1ED) - (#x7AED . #xE3F1) - (#x7AEF . #xC3BC) - (#x7AF0 . #xE3F2) - (#x7AF1 . #x8FD1EE) - (#x7AF4 . #x8FD1EF) - (#x7AF6 . #xB6A5) - (#x7AF8 . #xD1BF) - (#x7AF9 . #xC3DD) - (#x7AFA . #xBCB3) - (#x7AFB . #x8FD1F0) - (#x7AFD . #x8FD1F1) - (#x7AFE . #x8FD1F2) - (#x7AFF . #xB4C8) - (#x7B02 . #xE3F3) - (#x7B04 . #xE4A2) - (#x7B06 . #xE3F6) - (#x7B07 . #x8FD1F3) - (#x7B08 . #xB5E8) - (#x7B0A . #xE3F5) - (#x7B0B . #xE4A4) - (#x7B0F . #xE3F4) - (#x7B11 . #xBED0) - (#x7B14 . #x8FD1F4) - (#x7B18 . #xE3F8) - (#x7B19 . #xE3F9) - (#x7B1B . #xC5AB) - (#x7B1E . #xE3FA) - (#x7B1F . #x8FD1F5) - (#x7B20 . #xB3DE) - (#x7B23 . #x8FD1F6) - (#x7B25 . #xBFDA) - (#x7B26 . #xC9E4) - (#x7B27 . #x8FD1F7) - (#x7B28 . #xE3FC) - (#x7B29 . #x8FD1F8) - (#x7B2A . #x8FD1F9) - (#x7B2B . #x8FD1FA) - (#x7B2C . #xC2E8) - (#x7B2D . #x8FD1FB) - (#x7B2E . #x8FD1FC) - (#x7B2F . #x8FD1FD) - (#x7B30 . #x8FD1FE) - (#x7B31 . #x8FD2A1) - (#x7B33 . #xE3F7) - (#x7B34 . #x8FD2A2) - (#x7B35 . #xE3FB) - (#x7B36 . #xE3FD) - (#x7B39 . #xBAFB) - (#x7B3D . #x8FD2A3) - (#x7B3F . #x8FD2A4) - (#x7B40 . #x8FD2A5) - (#x7B41 . #x8FD2A6) - (#x7B45 . #xE4A6) - (#x7B46 . #xC9AE) - (#x7B47 . #x8FD2A7) - (#x7B48 . #xC8A6) - (#x7B49 . #xC5F9) - (#x7B4B . #xB6DA) - (#x7B4C . #xE4A5) - (#x7B4D . #xE4A3) - (#x7B4E . #x8FD2A8) - (#x7B4F . #xC8B5) - (#x7B50 . #xE3FE) - (#x7B51 . #xC3DE) - (#x7B52 . #xC5FB) - (#x7B54 . #xC5FA) - (#x7B55 . #x8FD2A9) - (#x7B56 . #xBAF6) - (#x7B5D . #xE4B8) - (#x7B60 . #x8FD2AA) - (#x7B64 . #x8FD2AB) - (#x7B65 . #xE4A8) - (#x7B66 . #x8FD2AC) - (#x7B67 . #xE4AA) - (#x7B69 . #x8FD2AD) - (#x7B6A . #x8FD2AE) - (#x7B6C . #xE4AD) - (#x7B6D . #x8FD2AF) - (#x7B6E . #xE4AE) - (#x7B6F . #x8FD2B0) - (#x7B70 . #xE4AB) - (#x7B71 . #xE4AC) - (#x7B72 . #x8FD2B1) - (#x7B73 . #x8FD2B2) - (#x7B74 . #xE4A9) - (#x7B75 . #xE4A7) - (#x7B77 . #x8FD2B3) - (#x7B7A . #xE4A1) - (#x7B84 . #x8FD2B4) - (#x7B86 . #xCACF) - (#x7B87 . #xB2D5) - (#x7B89 . #x8FD2B5) - (#x7B8B . #xE4B5) - (#x7B8D . #xE4B2) - (#x7B8E . #x8FD2B6) - (#x7B8F . #xE4B7) - (#x7B90 . #x8FD2B7) - (#x7B91 . #x8FD2B8) - (#x7B92 . #xE4B6) - (#x7B94 . #xC7F3) - (#x7B95 . #xCCA7) - (#x7B96 . #x8FD2B9) - (#x7B97 . #xBBBB) - (#x7B98 . #xE4B0) - (#x7B99 . #xE4B9) - (#x7B9A . #xE4B4) - (#x7B9B . #x8FD2BA) - (#x7B9C . #xE4B3) - (#x7B9D . #xE4AF) - (#x7B9E . #x8FD2BB) - (#x7B9F . #xE4B1) - (#x7BA0 . #x8FD2BC) - (#x7BA1 . #xB4C9) - (#x7BA5 . #x8FD2BD) - (#x7BAA . #xC3BD) - (#x7BAC . #x8FD2BE) - (#x7BAD . #xC0FD) - (#x7BAF . #x8FD2BF) - (#x7BB0 . #x8FD2C0) - (#x7BB1 . #xC8A2) - (#x7BB2 . #x8FD2C1) - (#x7BB4 . #xE4BE) - (#x7BB5 . #x8FD2C2) - (#x7BB6 . #x8FD2C3) - (#x7BB8 . #xC8A4) - (#x7BBA . #x8FD2C4) - (#x7BBB . #x8FD2C5) - (#x7BBC . #x8FD2C6) - (#x7BBD . #x8FD2C7) - (#x7BC0 . #xC0E1) - (#x7BC1 . #xE4BB) - (#x7BC2 . #x8FD2C8) - (#x7BC4 . #xC8CF) - (#x7BC5 . #x8FD2C9) - (#x7BC6 . #xE4BF) - (#x7BC7 . #xCAD3) - (#x7BC8 . #x8FD2CA) - (#x7BC9 . #xC3DB) - (#x7BCA . #x8FD2CB) - (#x7BCB . #xE4BA) - (#x7BCC . #xE4BC) - (#x7BCF . #xE4BD) - (#x7BD4 . #x8FD2CC) - (#x7BD6 . #x8FD2CD) - (#x7BD7 . #x8FD2CE) - (#x7BD9 . #x8FD2CF) - (#x7BDA . #x8FD2D0) - (#x7BDB . #x8FD2D1) - (#x7BDD . #xE4C0) - (#x7BE0 . #xBCC4) - (#x7BE4 . #xC6C6) - (#x7BE5 . #xE4C5) - (#x7BE6 . #xE4C4) - (#x7BE8 . #x8FD2D2) - (#x7BE9 . #xE4C1) - (#x7BEA . #x8FD2D3) - (#x7BED . #xCFB6) - (#x7BF2 . #x8FD2D4) - (#x7BF3 . #xE4CA) - (#x7BF4 . #x8FD2D5) - (#x7BF5 . #x8FD2D6) - (#x7BF6 . #xE4CE) - (#x7BF7 . #xE4CB) - (#x7BF8 . #x8FD2D7) - (#x7BF9 . #x8FD2D8) - (#x7BFA . #x8FD2D9) - (#x7BFC . #x8FD2DA) - (#x7BFE . #x8FD2DB) - (#x7C00 . #xE4C7) - (#x7C01 . #x8FD2DC) - (#x7C02 . #x8FD2DD) - (#x7C03 . #x8FD2DE) - (#x7C04 . #x8FD2DF) - (#x7C06 . #x8FD2E0) - (#x7C07 . #xE4C8) - (#x7C09 . #x8FD2E1) - (#x7C0B . #x8FD2E2) - (#x7C0C . #x8FD2E3) - (#x7C0D . #xE4CD) - (#x7C0E . #x8FD2E4) - (#x7C0F . #x8FD2E5) - (#x7C11 . #xE4C2) - (#x7C12 . #xD2D5) - (#x7C13 . #xE4C9) - (#x7C14 . #xE4C3) - (#x7C17 . #xE4CC) - (#x7C19 . #x8FD2E6) - (#x7C1B . #x8FD2E7) - (#x7C1F . #xE4D2) - (#x7C20 . #x8FD2E8) - (#x7C21 . #xB4CA) - (#x7C23 . #xE4CF) - (#x7C25 . #x8FD2E9) - (#x7C26 . #x8FD2EA) - (#x7C27 . #xE4D0) - (#x7C28 . #x8FD2EB) - (#x7C2A . #xE4D1) - (#x7C2B . #xE4D4) - (#x7C2C . #x8FD2EC) - (#x7C31 . #x8FD2ED) - (#x7C33 . #x8FD2EE) - (#x7C34 . #x8FD2EF) - (#x7C36 . #x8FD2F0) - (#x7C37 . #xE4D3) - (#x7C38 . #xC8F6) - (#x7C39 . #x8FD2F1) - (#x7C3A . #x8FD2F2) - (#x7C3D . #xE4D5) - (#x7C3E . #xCEFC) - (#x7C3F . #xCAED) - (#x7C40 . #xE4DA) - (#x7C43 . #xE4D7) - (#x7C46 . #x8FD2F3) - (#x7C4A . #x8FD2F4) - (#x7C4C . #xE4D6) - (#x7C4D . #xC0D2) - (#x7C4F . #xE4D9) - (#x7C50 . #xE4DB) - (#x7C51 . #x8FD2F6) - (#x7C52 . #x8FD2F7) - (#x7C53 . #x8FD2F8) - (#x7C54 . #xE4D8) - (#x7C55 . #x8FD2F5) - (#x7C56 . #xE4DF) - (#x7C58 . #xE4DC) - (#x7C59 . #x8FD2F9) - (#x7C5A . #x8FD2FA) - (#x7C5B . #x8FD2FB) - (#x7C5C . #x8FD2FC) - (#x7C5D . #x8FD2FD) - (#x7C5E . #x8FD2FE) - (#x7C5F . #xE4DD) - (#x7C60 . #xE4C6) - (#x7C61 . #x8FD3A1) - (#x7C63 . #x8FD3A2) - (#x7C64 . #xE4DE) - (#x7C65 . #xE4E0) - (#x7C67 . #x8FD3A3) - (#x7C69 . #x8FD3A4) - (#x7C6C . #xE4E1) - (#x7C6D . #x8FD3A5) - (#x7C6E . #x8FD3A6) - (#x7C70 . #x8FD3A7) - (#x7C72 . #x8FD3A8) - (#x7C73 . #xCAC6) - (#x7C75 . #xE4E2) - (#x7C79 . #x8FD3A9) - (#x7C7C . #x8FD3AA) - (#x7C7D . #x8FD3AB) - (#x7C7E . #xCCE2) - (#x7C81 . #xB6CE) - (#x7C82 . #xB7A9) - (#x7C83 . #xE4E3) - (#x7C86 . #x8FD3AC) - (#x7C87 . #x8FD3AD) - (#x7C89 . #xCAB4) - (#x7C8B . #xBFE8) - (#x7C8D . #xCCB0) - (#x7C8F . #x8FD3AE) - (#x7C90 . #xE4E4) - (#x7C92 . #xCEB3) - (#x7C94 . #x8FD3AF) - (#x7C95 . #xC7F4) - (#x7C97 . #xC1C6) - (#x7C98 . #xC7B4) - (#x7C9B . #xBDCD) - (#x7C9E . #x8FD3B0) - (#x7C9F . #xB0C0) - (#x7CA0 . #x8FD3B1) - (#x7CA1 . #xE4E9) - (#x7CA2 . #xE4E7) - (#x7CA4 . #xE4E5) - (#x7CA5 . #xB4A1) - (#x7CA6 . #x8FD3B2) - (#x7CA7 . #xBED1) - (#x7CA8 . #xE4EA) - (#x7CAB . #xE4E8) - (#x7CAD . #xE4E6) - (#x7CAE . #xE4EE) - (#x7CB0 . #x8FD3B3) - (#x7CB1 . #xE4ED) - (#x7CB2 . #xE4EC) - (#x7CB3 . #xE4EB) - (#x7CB6 . #x8FD3B4) - (#x7CB7 . #x8FD3B5) - (#x7CB9 . #xE4EF) - (#x7CBA . #x8FD3B6) - (#x7CBB . #x8FD3B7) - (#x7CBC . #x8FD3B8) - (#x7CBD . #xE4F0) - (#x7CBE . #xC0BA) - (#x7CBF . #x8FD3B9) - (#x7CC0 . #xE4F1) - (#x7CC2 . #xE4F3) - (#x7CC4 . #x8FD3BA) - (#x7CC5 . #xE4F2) - (#x7CC7 . #x8FD3BB) - (#x7CC8 . #x8FD3BC) - (#x7CC9 . #x8FD3BD) - (#x7CCA . #xB8D2) - (#x7CCD . #x8FD3BE) - (#x7CCE . #xC1B8) - (#x7CCF . #x8FD3BF) - (#x7CD2 . #xE4F5) - (#x7CD3 . #x8FD3C0) - (#x7CD4 . #x8FD3C1) - (#x7CD5 . #x8FD3C2) - (#x7CD6 . #xC5FC) - (#x7CD7 . #x8FD3C3) - (#x7CD8 . #xE4F4) - (#x7CD9 . #x8FD3C4) - (#x7CDA . #x8FD3C5) - (#x7CDC . #xE4F6) - (#x7CDD . #x8FD3C6) - (#x7CDE . #xCAB5) - (#x7CDF . #xC1EC) - (#x7CE0 . #xB9C7) - (#x7CE2 . #xE4F7) - (#x7CE6 . #x8FD3C7) - (#x7CE7 . #xCEC8) - (#x7CE9 . #x8FD3C8) - (#x7CEB . #x8FD3C9) - (#x7CEF . #xE4F9) - (#x7CF2 . #xE4FA) - (#x7CF4 . #xE4FB) - (#x7CF5 . #x8FD3CA) - (#x7CF6 . #xE4FC) - (#x7CF8 . #xBBE5) - (#x7CFA . #xE4FD) - (#x7CFB . #xB7CF) - (#x7CFE . #xB5EA) - (#x7D00 . #xB5AA) - (#x7D02 . #xE5A1) - (#x7D03 . #x8FD3CB) - (#x7D04 . #xCCF3) - (#x7D05 . #xB9C8) - (#x7D06 . #xE4FE) - (#x7D07 . #x8FD3CC) - (#x7D08 . #x8FD3CD) - (#x7D09 . #x8FD3CE) - (#x7D0A . #xE5A4) - (#x7D0B . #xCCE6) - (#x7D0D . #xC7BC) - (#x7D0F . #x8FD3CF) - (#x7D10 . #xC9B3) - (#x7D11 . #x8FD3D0) - (#x7D12 . #x8FD3D1) - (#x7D13 . #x8FD3D2) - (#x7D14 . #xBDE3) - (#x7D15 . #xE5A3) - (#x7D16 . #x8FD3D3) - (#x7D17 . #xBCD3) - (#x7D18 . #xB9C9) - (#x7D19 . #xBBE6) - (#x7D1A . #xB5E9) - (#x7D1B . #xCAB6) - (#x7D1C . #xE5A2) - (#x7D1D . #x8FD3D4) - (#x7D1E . #x8FD3D5) - (#x7D20 . #xC1C7) - (#x7D21 . #xCBC2) - (#x7D22 . #xBAF7) - (#x7D23 . #x8FD3D6) - (#x7D26 . #x8FD3D7) - (#x7D2A . #x8FD3D8) - (#x7D2B . #xBBE7) - (#x7D2C . #xC4DD) - (#x7D2D . #x8FD3D9) - (#x7D2E . #xE5A7) - (#x7D2F . #xCEDF) - (#x7D30 . #xBAD9) - (#x7D31 . #x8FD3DA) - (#x7D32 . #xE5A8) - (#x7D33 . #xBFC2) - (#x7D35 . #xE5AA) - (#x7D39 . #xBED2) - (#x7D3A . #xBAB0) - (#x7D3C . #x8FD3DB) - (#x7D3D . #x8FD3DC) - (#x7D3E . #x8FD3DD) - (#x7D3F . #xE5A9) - (#x7D40 . #x8FD3DE) - (#x7D41 . #x8FD3DF) - (#x7D42 . #xBDAA) - (#x7D43 . #xB8BE) - (#x7D44 . #xC1C8) - (#x7D45 . #xE5A5) - (#x7D46 . #xE5AB) - (#x7D47 . #x8FD3E0) - (#x7D48 . #x8FD3E1) - (#x7D4B . #xE5A6) - (#x7D4C . #xB7D0) - (#x7D4D . #x8FD3E2) - (#x7D4E . #xE5AE) - (#x7D4F . #xE5B2) - (#x7D50 . #xB7EB) - (#x7D51 . #x8FD3E3) - (#x7D53 . #x8FD3E4) - (#x7D56 . #xE5AD) - (#x7D57 . #x8FD3E5) - (#x7D59 . #x8FD3E6) - (#x7D5A . #x8FD3E7) - (#x7D5B . #xE5B6) - (#x7D5C . #x8FD3E8) - (#x7D5D . #x8FD3E9) - (#x7D5E . #xB9CA) - (#x7D61 . #xCDED) - (#x7D62 . #xB0BC) - (#x7D63 . #xE5B3) - (#x7D65 . #x8FD3EA) - (#x7D66 . #xB5EB) - (#x7D67 . #x8FD3EB) - (#x7D68 . #xE5B0) - (#x7D6A . #x8FD3EC) - (#x7D6E . #xE5B1) - (#x7D70 . #x8FD3ED) - (#x7D71 . #xC5FD) - (#x7D72 . #xE5AF) - (#x7D73 . #xE5AC) - (#x7D75 . #xB3A8) - (#x7D76 . #xC0E4) - (#x7D78 . #x8FD3EE) - (#x7D79 . #xB8A8) - (#x7D7A . #x8FD3EF) - (#x7D7B . #x8FD3F0) - (#x7D7D . #xE5B8) - (#x7D7F . #x8FD3F1) - (#x7D81 . #x8FD3F2) - (#x7D82 . #x8FD3F3) - (#x7D83 . #x8FD3F4) - (#x7D85 . #x8FD3F5) - (#x7D86 . #x8FD3F6) - (#x7D88 . #x8FD3F7) - (#x7D89 . #xE5B5) - (#x7D8B . #x8FD3F8) - (#x7D8C . #x8FD3F9) - (#x7D8D . #x8FD3FA) - (#x7D8F . #xE5B7) - (#x7D91 . #x8FD3FB) - (#x7D93 . #xE5B4) - (#x7D96 . #x8FD3FC) - (#x7D97 . #x8FD3FD) - (#x7D99 . #xB7D1) - (#x7D9A . #xC2B3) - (#x7D9B . #xE5B9) - (#x7D9C . #xC1EE) - (#x7D9D . #x8FD3FE) - (#x7D9E . #x8FD4A1) - (#x7D9F . #xE5C6) - (#x7DA2 . #xE5C2) - (#x7DA3 . #xE5BC) - (#x7DA6 . #x8FD4A2) - (#x7DA7 . #x8FD4A3) - (#x7DAA . #x8FD4A4) - (#x7DAB . #xE5C0) - (#x7DAC . #xBCFA) - (#x7DAD . #xB0DD) - (#x7DAE . #xE5BB) - (#x7DAF . #xE5C3) - (#x7DB0 . #xE5C7) - (#x7DB1 . #xB9CB) - (#x7DB2 . #xCCD6) - (#x7DB3 . #x8FD4A5) - (#x7DB4 . #xC4D6) - (#x7DB5 . #xE5BD) - (#x7DB6 . #x8FD4A6) - (#x7DB7 . #x8FD4A7) - (#x7DB8 . #xE5C5) - (#x7DB9 . #x8FD4A8) - (#x7DBA . #xE5BA) - (#x7DBB . #xC3BE) - (#x7DBD . #xE5BF) - (#x7DBE . #xB0BD) - (#x7DBF . #xCCCA) - (#x7DC2 . #x8FD4A9) - (#x7DC3 . #x8FD4AA) - (#x7DC4 . #x8FD4AB) - (#x7DC5 . #x8FD4AC) - (#x7DC6 . #x8FD4AD) - (#x7DC7 . #xE5BE) - (#x7DCA . #xB6DB) - (#x7DCB . #xC8EC) - (#x7DCC . #x8FD4AE) - (#x7DCD . #x8FD4AF) - (#x7DCE . #x8FD4B0) - (#x7DCF . #xC1ED) - (#x7DD1 . #xCED0) - (#x7DD2 . #xBDEF) - (#x7DD5 . #xE5EE) - (#x7DD7 . #x8FD4B1) - (#x7DD8 . #xE5C8) - (#x7DD9 . #x8FD4B2) - (#x7DDA . #xC0FE) - (#x7DDC . #xE5C4) - (#x7DDD . #xE5C9) - (#x7DDE . #xE5CB) - (#x7DE0 . #xC4F9) - (#x7DE1 . #xE5CE) - (#x7DE2 . #x8FD4B4) - (#x7DE4 . #xE5CA) - (#x7DE5 . #x8FD4B5) - (#x7DE6 . #x8FD4B6) - (#x7DE8 . #xCAD4) - (#x7DE9 . #xB4CB) - (#x7DEA . #x8FD4B7) - (#x7DEB . #x8FD4B8) - (#x7DEC . #xCCCB) - (#x7DED . #x8FD4B9) - (#x7DEF . #xB0DE) - (#x7DF1 . #x8FD4BA) - (#x7DF2 . #xE5CD) - (#x7DF4 . #xCEFD) - (#x7DF5 . #x8FD4BB) - (#x7DF6 . #x8FD4BC) - (#x7DF9 . #x8FD4BD) - (#x7DFA . #x8FD4BE) - (#x7DFB . #xE5CC) - (#x7E00 . #x8FD4B3) - (#x7E01 . #xB1EF) - (#x7E04 . #xC6EC) - (#x7E05 . #xE5CF) - (#x7E08 . #x8FD4BF) - (#x7E09 . #xE5D6) - (#x7E0A . #xE5D0) - (#x7E0B . #xE5D7) - (#x7E10 . #x8FD4C0) - (#x7E11 . #x8FD4C1) - (#x7E12 . #xE5D3) - (#x7E15 . #x8FD4C2) - (#x7E17 . #x8FD4C3) - (#x7E1B . #xC7FB) - (#x7E1C . #x8FD4C4) - (#x7E1D . #x8FD4C5) - (#x7E1E . #xBCCA) - (#x7E1F . #xE5D5) - (#x7E20 . #x8FD4C6) - (#x7E21 . #xE5D2) - (#x7E22 . #xE5D8) - (#x7E23 . #xE5D1) - (#x7E26 . #xBDC4) - (#x7E27 . #x8FD4C7) - (#x7E28 . #x8FD4C8) - (#x7E2B . #xCBA5) - (#x7E2C . #x8FD4C9) - (#x7E2D . #x8FD4CA) - (#x7E2E . #xBDCC) - (#x7E2F . #x8FD4CB) - (#x7E31 . #xE5D4) - (#x7E32 . #xE5E0) - (#x7E33 . #x8FD4CC) - (#x7E35 . #xE5DC) - (#x7E36 . #x8FD4CD) - (#x7E37 . #xE5DF) - (#x7E39 . #xE5DD) - (#x7E3A . #xE5E1) - (#x7E3B . #xE5DB) - (#x7E3D . #xE5C1) - (#x7E3E . #xC0D3) - (#x7E3F . #x8FD4CE) - (#x7E41 . #xC8CB) - (#x7E43 . #xE5DE) - (#x7E44 . #x8FD4CF) - (#x7E45 . #x8FD4D0) - (#x7E46 . #xE5D9) - (#x7E47 . #x8FD4D1) - (#x7E4A . #xC1A1) - (#x7E4B . #xB7D2) - (#x7E4D . #xBDAB) - (#x7E4E . #x8FD4D2) - (#x7E50 . #x8FD4D3) - (#x7E52 . #x8FD4D4) - (#x7E54 . #xBFA5) - (#x7E55 . #xC1B6) - (#x7E56 . #xE5E4) - (#x7E58 . #x8FD4D5) - (#x7E59 . #xE5E6) - (#x7E5A . #xE5E7) - (#x7E5D . #xE5E3) - (#x7E5E . #xE5E5) - (#x7E5F . #x8FD4D6) - (#x7E61 . #x8FD4D7) - (#x7E62 . #x8FD4D8) - (#x7E65 . #x8FD4D9) - (#x7E66 . #xE5DA) - (#x7E67 . #xE5E2) - (#x7E69 . #xE5EA) - (#x7E6A . #xE5E9) - (#x7E6B . #x8FD4DA) - (#x7E6D . #xCBFA) - (#x7E6E . #x8FD4DB) - (#x7E6F . #x8FD4DC) - (#x7E70 . #xB7AB) - (#x7E73 . #x8FD4DD) - (#x7E78 . #x8FD4DE) - (#x7E79 . #xE5E8) - (#x7E7B . #xE5EC) - (#x7E7C . #xE5EB) - (#x7E7D . #xE5EF) - (#x7E7E . #x8FD4DF) - (#x7E7F . #xE5F1) - (#x7E81 . #x8FD4E0) - (#x7E82 . #xBBBC) - (#x7E83 . #xE5ED) - (#x7E86 . #x8FD4E1) - (#x7E87 . #x8FD4E2) - (#x7E88 . #xE5F2) - (#x7E89 . #xE5F3) - (#x7E8A . #x8FD4E3) - (#x7E8C . #xE5F4) - (#x7E8D . #x8FD4E4) - (#x7E8E . #xE5FA) - (#x7E8F . #xC5BB) - (#x7E90 . #xE5F6) - (#x7E91 . #x8FD4E5) - (#x7E92 . #xE5F5) - (#x7E93 . #xE5F7) - (#x7E94 . #xE5F8) - (#x7E95 . #x8FD4E6) - (#x7E96 . #xE5F9) - (#x7E98 . #x8FD4E7) - (#x7E9A . #x8FD4E8) - (#x7E9B . #xE5FB) - (#x7E9C . #xE5FC) - (#x7E9D . #x8FD4E9) - (#x7E9E . #x8FD4EA) - (#x7F36 . #xB4CC) - (#x7F38 . #xE5FD) - (#x7F3A . #xE5FE) - (#x7F3B . #x8FD4EC) - (#x7F3C . #x8FD4EB) - (#x7F3D . #x8FD4ED) - (#x7F3E . #x8FD4EE) - (#x7F3F . #x8FD4EF) - (#x7F43 . #x8FD4F0) - (#x7F44 . #x8FD4F1) - (#x7F45 . #xE6A1) - (#x7F47 . #x8FD4F2) - (#x7F4C . #xE6A2) - (#x7F4D . #xE6A3) - (#x7F4E . #xE6A4) - (#x7F4F . #x8FD4F3) - (#x7F50 . #xE6A5) - (#x7F51 . #xE6A6) - (#x7F52 . #x8FD4F4) - (#x7F53 . #x8FD4F5) - (#x7F54 . #xE6A8) - (#x7F55 . #xE6A7) - (#x7F58 . #xE6A9) - (#x7F5B . #x8FD4F6) - (#x7F5C . #x8FD4F7) - (#x7F5D . #x8FD4F8) - (#x7F5F . #xE6AA) - (#x7F60 . #xE6AB) - (#x7F61 . #x8FD4F9) - (#x7F63 . #x8FD4FA) - (#x7F64 . #x8FD4FB) - (#x7F65 . #x8FD4FC) - (#x7F66 . #x8FD4FD) - (#x7F67 . #xE6AE) - (#x7F68 . #xE6AC) - (#x7F69 . #xE6AD) - (#x7F6A . #xBAE1) - (#x7F6B . #xB7D3) - (#x7F6D . #x8FD4FE) - (#x7F6E . #xC3D6) - (#x7F70 . #xC8B3) - (#x7F71 . #x8FD5A1) - (#x7F72 . #xBDF0) - (#x7F75 . #xC7CD) - (#x7F77 . #xC8ED) - (#x7F78 . #xE6AF) - (#x7F79 . #xD8ED) - (#x7F7D . #x8FD5A2) - (#x7F7E . #x8FD5A3) - (#x7F7F . #x8FD5A4) - (#x7F80 . #x8FD5A5) - (#x7F82 . #xE6B0) - (#x7F83 . #xE6B2) - (#x7F85 . #xCDE5) - (#x7F86 . #xE6B1) - (#x7F87 . #xE6B4) - (#x7F88 . #xE6B3) - (#x7F8A . #xCDD3) - (#x7F8B . #x8FD5A6) - (#x7F8C . #xE6B5) - (#x7F8D . #x8FD5A7) - (#x7F8E . #xC8FE) - (#x7F8F . #x8FD5A8) - (#x7F90 . #x8FD5A9) - (#x7F91 . #x8FD5AA) - (#x7F94 . #xE6B6) - (#x7F96 . #x8FD5AB) - (#x7F97 . #x8FD5AC) - (#x7F9A . #xE6B9) - (#x7F9C . #x8FD5AD) - (#x7F9D . #xE6B8) - (#x7F9E . #xE6B7) - (#x7FA1 . #x8FD5AE) - (#x7FA2 . #x8FD5AF) - (#x7FA3 . #xE6BA) - (#x7FA4 . #xB7B2) - (#x7FA6 . #x8FD5B0) - (#x7FA8 . #xC1A2) - (#x7FA9 . #xB5C1) - (#x7FAA . #x8FD5B1) - (#x7FAD . #x8FD5B2) - (#x7FAE . #xE6BE) - (#x7FAF . #xE6BB) - (#x7FB2 . #xE6BC) - (#x7FB4 . #x8FD5B3) - (#x7FB6 . #xE6BF) - (#x7FB8 . #xE6C0) - (#x7FB9 . #xE6BD) - (#x7FBC . #x8FD5B4) - (#x7FBD . #xB1A9) - (#x7FBF . #x8FD5B5) - (#x7FC0 . #x8FD5B6) - (#x7FC1 . #xB2A7) - (#x7FC3 . #x8FD5B7) - (#x7FC5 . #xE6C2) - (#x7FC6 . #xE6C3) - (#x7FC8 . #x8FD5B8) - (#x7FCA . #xE6C4) - (#x7FCC . #xCDE2) - (#x7FCE . #x8FD5B9) - (#x7FCF . #x8FD5BA) - (#x7FD2 . #xBDAC) - (#x7FD4 . #xE6C6) - (#x7FD5 . #xE6C5) - (#x7FDB . #x8FD5BB) - (#x7FDF . #x8FD5BC) - (#x7FE0 . #xBFE9) - (#x7FE1 . #xE6C7) - (#x7FE3 . #x8FD5BD) - (#x7FE5 . #x8FD5BE) - (#x7FE6 . #xE6C8) - (#x7FE8 . #x8FD5BF) - (#x7FE9 . #xE6C9) - (#x7FEB . #xB4E5) - (#x7FEC . #x8FD5C0) - (#x7FEE . #x8FD5C1) - (#x7FEF . #x8FD5C2) - (#x7FF0 . #xB4CD) - (#x7FF2 . #x8FD5C3) - (#x7FF3 . #xE6CA) - (#x7FF9 . #xE6CB) - (#x7FFA . #x8FD5C4) - (#x7FFB . #xCBDD) - (#x7FFC . #xCDE3) - (#x7FFD . #x8FD5C5) - (#x7FFE . #x8FD5C6) - (#x7FFF . #x8FD5C7) - (#x8000 . #xCDD4) - (#x8001 . #xCFB7) - (#x8003 . #xB9CD) - (#x8004 . #xE6CE) - (#x8005 . #xBCD4) - (#x8006 . #xE6CD) - (#x8007 . #x8FD5C8) - (#x8008 . #x8FD5C9) - (#x800A . #x8FD5CA) - (#x800B . #xE6CF) - (#x800C . #xBCA9) - (#x800D . #x8FD5CB) - (#x800E . #x8FD5CC) - (#x800F . #x8FD5CD) - (#x8010 . #xC2D1) - (#x8011 . #x8FD5CE) - (#x8012 . #xE6D0) - (#x8013 . #x8FD5CF) - (#x8014 . #x8FD5D0) - (#x8015 . #xB9CC) - (#x8016 . #x8FD5D1) - (#x8017 . #xCCD7) - (#x8018 . #xE6D1) - (#x8019 . #xE6D2) - (#x801C . #xE6D3) - (#x801D . #x8FD5D2) - (#x801E . #x8FD5D3) - (#x801F . #x8FD5D4) - (#x8020 . #x8FD5D5) - (#x8021 . #xE6D4) - (#x8024 . #x8FD5D6) - (#x8026 . #x8FD5D7) - (#x8028 . #xE6D5) - (#x802C . #x8FD5D8) - (#x802E . #x8FD5D9) - (#x8030 . #x8FD5DA) - (#x8033 . #xBCAA) - (#x8034 . #x8FD5DB) - (#x8035 . #x8FD5DC) - (#x8036 . #xCCED) - (#x8037 . #x8FD5DD) - (#x8039 . #x8FD5DE) - (#x803A . #x8FD5DF) - (#x803B . #xE6D7) - (#x803C . #x8FD5E0) - (#x803D . #xC3BF) - (#x803E . #x8FD5E1) - (#x803F . #xE6D6) - (#x8040 . #x8FD5E2) - (#x8044 . #x8FD5E3) - (#x8046 . #xE6D9) - (#x804A . #xE6D8) - (#x8052 . #xE6DA) - (#x8056 . #xC0BB) - (#x8058 . #xE6DB) - (#x805A . #xE6DC) - (#x805E . #xCAB9) - (#x805F . #xE6DD) - (#x8060 . #x8FD5E4) - (#x8061 . #xC1EF) - (#x8062 . #xE6DE) - (#x8064 . #x8FD5E5) - (#x8066 . #x8FD5E6) - (#x8068 . #xE6DF) - (#x806D . #x8FD5E7) - (#x806F . #xCEFE) - (#x8070 . #xE6E2) - (#x8071 . #x8FD5E8) - (#x8072 . #xE6E1) - (#x8073 . #xE6E0) - (#x8074 . #xC4B0) - (#x8075 . #x8FD5E9) - (#x8076 . #xE6E3) - (#x8077 . #xBFA6) - (#x8079 . #xE6E4) - (#x807D . #xE6E5) - (#x807E . #xCFB8) - (#x807F . #xE6E6) - (#x8081 . #x8FD5EA) - (#x8084 . #xE6E7) - (#x8085 . #xE6E9) - (#x8086 . #xE6E8) - (#x8087 . #xC8A5) - (#x8088 . #x8FD5EB) - (#x8089 . #xC6F9) - (#x808B . #xCFBE) - (#x808C . #xC8A9) - (#x808E . #x8FD5EC) - (#x8093 . #xE6EB) - (#x8096 . #xBED3) - (#x8098 . #xC9AA) - (#x809A . #xE6EC) - (#x809B . #xE6EA) - (#x809C . #x8FD5ED) - (#x809D . #xB4CE) - (#x809E . #x8FD5EE) - (#x80A1 . #xB8D4) - (#x80A2 . #xBBE8) - (#x80A5 . #xC8EE) - (#x80A6 . #x8FD5EF) - (#x80A7 . #x8FD5F0) - (#x80A9 . #xB8AA) - (#x80AA . #xCBC3) - (#x80AB . #x8FD5F1) - (#x80AC . #xE6EF) - (#x80AD . #xE6ED) - (#x80AF . #xB9CE) - (#x80B1 . #xB9CF) - (#x80B2 . #xB0E9) - (#x80B4 . #xBAE8) - (#x80B8 . #x8FD5F2) - (#x80B9 . #x8FD5F3) - (#x80BA . #xC7D9) - (#x80C3 . #xB0DF) - (#x80C4 . #xE6F4) - (#x80C6 . #xC3C0) - (#x80C8 . #x8FD5F4) - (#x80CC . #xC7D8) - (#x80CD . #x8FD5F5) - (#x80CE . #xC2DB) - (#x80CF . #x8FD5F6) - (#x80D2 . #x8FD5F7) - (#x80D4 . #x8FD5F8) - (#x80D5 . #x8FD5F9) - (#x80D6 . #xE6F6) - (#x80D7 . #x8FD5FA) - (#x80D8 . #x8FD5FB) - (#x80D9 . #xE6F2) - (#x80DA . #xE6F5) - (#x80DB . #xE6F0) - (#x80DD . #xE6F3) - (#x80DE . #xCBA6) - (#x80E0 . #x8FD5FC) - (#x80E1 . #xB8D5) - (#x80E4 . #xB0FD) - (#x80E5 . #xE6F1) - (#x80ED . #x8FD5FD) - (#x80EE . #x8FD5FE) - (#x80EF . #xE6F8) - (#x80F0 . #x8FD6A1) - (#x80F1 . #xE6F9) - (#x80F2 . #x8FD6A2) - (#x80F3 . #x8FD6A3) - (#x80F4 . #xC6B9) - (#x80F6 . #x8FD6A4) - (#x80F8 . #xB6BB) - (#x80F9 . #x8FD6A5) - (#x80FA . #x8FD6A6) - (#x80FC . #xE7A6) - (#x80FD . #xC7BD) - (#x80FE . #x8FD6A7) - (#x8102 . #xBBE9) - (#x8103 . #x8FD6A8) - (#x8105 . #xB6BC) - (#x8106 . #xC0C8) - (#x8107 . #xCFC6) - (#x8108 . #xCCAE) - (#x8109 . #xE6F7) - (#x810A . #xC0D4) - (#x810B . #x8FD6A9) - (#x8116 . #x8FD6AA) - (#x8117 . #x8FD6AB) - (#x8118 . #x8FD6AC) - (#x811A . #xB5D3) - (#x811B . #xE6FA) - (#x811C . #x8FD6AD) - (#x811E . #x8FD6AE) - (#x8120 . #x8FD6AF) - (#x8123 . #xE6FC) - (#x8124 . #x8FD6B0) - (#x8127 . #x8FD6B1) - (#x8129 . #xE6FB) - (#x812C . #x8FD6B2) - (#x812F . #xE6FD) - (#x8130 . #x8FD6B3) - (#x8131 . #xC3A6) - (#x8133 . #xC7BE) - (#x8135 . #x8FD6B4) - (#x8139 . #xC4B1) - (#x813A . #x8FD6B5) - (#x813C . #x8FD6B6) - (#x813E . #xE7A3) - (#x8145 . #x8FD6B7) - (#x8146 . #xE7A2) - (#x8147 . #x8FD6B8) - (#x814A . #x8FD6B9) - (#x814B . #xE6FE) - (#x814C . #x8FD6BA) - (#x814E . #xBFD5) - (#x8150 . #xC9E5) - (#x8151 . #xE7A5) - (#x8152 . #x8FD6BB) - (#x8153 . #xE7A4) - (#x8154 . #xB9D0) - (#x8155 . #xCFD3) - (#x8157 . #x8FD6BC) - (#x815F . #xE7B5) - (#x8160 . #x8FD6BD) - (#x8161 . #x8FD6BE) - (#x8165 . #xE7A9) - (#x8166 . #xE7AA) - (#x8167 . #x8FD6BF) - (#x8168 . #x8FD6C0) - (#x8169 . #x8FD6C1) - (#x816B . #xBCF0) - (#x816D . #x8FD6C2) - (#x816E . #xE7A8) - (#x816F . #x8FD6C3) - (#x8170 . #xB9F8) - (#x8171 . #xE7A7) - (#x8174 . #xE7AB) - (#x8177 . #x8FD6C4) - (#x8178 . #xC4B2) - (#x8179 . #xCAA2) - (#x817A . #xC1A3) - (#x817F . #xC2DC) - (#x8180 . #xE7AF) - (#x8181 . #x8FD6C5) - (#x8182 . #xE7B0) - (#x8183 . #xE7AC) - (#x8184 . #x8FD6C7) - (#x8185 . #x8FD6C8) - (#x8186 . #x8FD6C9) - (#x8188 . #xE7AD) - (#x818A . #xE7AE) - (#x818B . #x8FD6CA) - (#x818E . #x8FD6CB) - (#x818F . #xB9D1) - (#x8190 . #x8FD6C6) - (#x8193 . #xE7B6) - (#x8195 . #xE7B2) - (#x8196 . #x8FD6CC) - (#x8198 . #x8FD6CD) - (#x819A . #xC9E6) - (#x819B . #x8FD6CE) - (#x819C . #xCBEC) - (#x819D . #xC9A8) - (#x819E . #x8FD6CF) - (#x81A0 . #xE7B1) - (#x81A2 . #x8FD6D0) - (#x81A3 . #xE7B4) - (#x81A4 . #xE7B3) - (#x81A8 . #xCBC4) - (#x81A9 . #xE7B7) - (#x81AE . #x8FD6D1) - (#x81B0 . #xE7B8) - (#x81B2 . #x8FD6D2) - (#x81B3 . #xC1B7) - (#x81B4 . #x8FD6D3) - (#x81B5 . #xE7B9) - (#x81B8 . #xE7BB) - (#x81BA . #xE7BF) - (#x81BB . #x8FD6D4) - (#x81BD . #xE7BC) - (#x81BE . #xE7BA) - (#x81BF . #xC7BF) - (#x81C0 . #xE7BD) - (#x81C2 . #xE7BE) - (#x81C3 . #x8FD6D6) - (#x81C5 . #x8FD6D7) - (#x81C6 . #xB2B2) - (#x81C8 . #xE7C5) - (#x81C9 . #xE7C0) - (#x81CA . #x8FD6D8) - (#x81CB . #x8FD6D5) - (#x81CD . #xE7C1) - (#x81CE . #x8FD6D9) - (#x81CF . #x8FD6DA) - (#x81D1 . #xE7C2) - (#x81D3 . #xC2A1) - (#x81D5 . #x8FD6DB) - (#x81D7 . #x8FD6DC) - (#x81D8 . #xE7C4) - (#x81D9 . #xE7C3) - (#x81DA . #xE7C6) - (#x81DB . #x8FD6DD) - (#x81DD . #x8FD6DE) - (#x81DE . #x8FD6DF) - (#x81DF . #xE7C7) - (#x81E0 . #xE7C8) - (#x81E1 . #x8FD6E0) - (#x81E3 . #xBFC3) - (#x81E4 . #x8FD6E1) - (#x81E5 . #xB2E9) - (#x81E7 . #xE7C9) - (#x81E8 . #xCED7) - (#x81EA . #xBCAB) - (#x81EB . #x8FD6E2) - (#x81EC . #x8FD6E3) - (#x81ED . #xBDAD) - (#x81F0 . #x8FD6E4) - (#x81F1 . #x8FD6E5) - (#x81F2 . #x8FD6E6) - (#x81F3 . #xBBEA) - (#x81F4 . #xC3D7) - (#x81F5 . #x8FD6E7) - (#x81F6 . #x8FD6E8) - (#x81F8 . #x8FD6E9) - (#x81F9 . #x8FD6EA) - (#x81FA . #xE7CA) - (#x81FB . #xE7CB) - (#x81FC . #xB1B1) - (#x81FD . #x8FD6EB) - (#x81FE . #xE7CC) - (#x81FF . #x8FD6EC) - (#x8200 . #x8FD6ED) - (#x8201 . #xE7CD) - (#x8202 . #xE7CE) - (#x8203 . #x8FD6EE) - (#x8205 . #xE7CF) - (#x8207 . #xE7D0) - (#x8208 . #xB6BD) - (#x8209 . #xDAAA) - (#x820A . #xE7D1) - (#x820C . #xC0E5) - (#x820D . #xE7D2) - (#x820E . #xBCCB) - (#x820F . #x8FD6EF) - (#x8210 . #xE7D3) - (#x8212 . #xD0B0) - (#x8213 . #x8FD6F0) - (#x8214 . #x8FD6F1) - (#x8216 . #xE7D4) - (#x8217 . #xCADE) - (#x8218 . #xB4DC) - (#x8219 . #x8FD6F2) - (#x821A . #x8FD6F3) - (#x821B . #xC1A4) - (#x821C . #xBDD8) - (#x821D . #x8FD6F4) - (#x821E . #xC9F1) - (#x821F . #xBDAE) - (#x8221 . #x8FD6F5) - (#x8222 . #x8FD6F6) - (#x8228 . #x8FD6F7) - (#x8229 . #xE7D5) - (#x822A . #xB9D2) - (#x822B . #xE7D6) - (#x822C . #xC8CC) - (#x822E . #xE7E4) - (#x8232 . #x8FD6F8) - (#x8233 . #xE7D8) - (#x8234 . #x8FD6F9) - (#x8235 . #xC2C9) - (#x8236 . #xC7F5) - (#x8237 . #xB8BF) - (#x8238 . #xE7D7) - (#x8239 . #xC1A5) - (#x823A . #x8FD6FA) - (#x8240 . #xE7D9) - (#x8243 . #x8FD6FB) - (#x8244 . #x8FD6FC) - (#x8245 . #x8FD6FD) - (#x8246 . #x8FD6FE) - (#x8247 . #xC4FA) - (#x824B . #x8FD7A1) - (#x824E . #x8FD7A2) - (#x824F . #x8FD7A3) - (#x8251 . #x8FD7A4) - (#x8256 . #x8FD7A5) - (#x8258 . #xE7DB) - (#x8259 . #xE7DA) - (#x825A . #xE7DD) - (#x825C . #x8FD7A6) - (#x825D . #xE7DC) - (#x825F . #xE7DE) - (#x8260 . #x8FD7A7) - (#x8262 . #xE7E0) - (#x8263 . #x8FD7A8) - (#x8264 . #xE7DF) - (#x8266 . #xB4CF) - (#x8267 . #x8FD7A9) - (#x8268 . #xE7E1) - (#x826A . #xE7E2) - (#x826B . #xE7E3) - (#x826D . #x8FD7AA) - (#x826E . #xBAB1) - (#x826F . #xCEC9) - (#x8271 . #xE7E5) - (#x8272 . #xBFA7) - (#x8274 . #x8FD7AB) - (#x8276 . #xB1F0) - (#x8277 . #xE7E6) - (#x8278 . #xE7E7) - (#x827B . #x8FD7AC) - (#x827D . #x8FD7AD) - (#x827E . #xE7E8) - (#x827F . #x8FD7AE) - (#x8280 . #x8FD7AF) - (#x8281 . #x8FD7B0) - (#x8283 . #x8FD7B1) - (#x8284 . #x8FD7B2) - (#x8287 . #x8FD7B3) - (#x8289 . #x8FD7B4) - (#x828A . #x8FD7B5) - (#x828B . #xB0F2) - (#x828D . #xE7E9) - (#x828E . #x8FD7B6) - (#x8291 . #x8FD7B7) - (#x8292 . #xE7EA) - (#x8294 . #x8FD7B8) - (#x8296 . #x8FD7B9) - (#x8298 . #x8FD7BA) - (#x8299 . #xC9E7) - (#x829A . #x8FD7BB) - (#x829B . #x8FD7BC) - (#x829D . #xBCC7) - (#x829F . #xE7EC) - (#x82A0 . #x8FD7BD) - (#x82A1 . #x8FD7BE) - (#x82A3 . #x8FD7BF) - (#x82A4 . #x8FD7C0) - (#x82A5 . #xB3A9) - (#x82A6 . #xB0B2) - (#x82A7 . #x8FD7C1) - (#x82A8 . #x8FD7C2) - (#x82A9 . #x8FD7C3) - (#x82AA . #x8FD7C4) - (#x82AB . #xE7EB) - (#x82AC . #xE7EE) - (#x82AD . #xC7CE) - (#x82AE . #x8FD7C5) - (#x82AF . #xBFC4) - (#x82B0 . #x8FD7C6) - (#x82B1 . #xB2D6) - (#x82B2 . #x8FD7C7) - (#x82B3 . #xCBA7) - (#x82B4 . #x8FD7C8) - (#x82B7 . #x8FD7C9) - (#x82B8 . #xB7DD) - (#x82B9 . #xB6DC) - (#x82BA . #x8FD7CA) - (#x82BB . #xE7ED) - (#x82BC . #x8FD7CB) - (#x82BD . #xB2EA) - (#x82BE . #x8FD7CC) - (#x82BF . #x8FD7CD) - (#x82C5 . #xB4A3) - (#x82C6 . #x8FD7CE) - (#x82D0 . #x8FD7CF) - (#x82D1 . #xB1F1) - (#x82D2 . #xE7F2) - (#x82D3 . #xCEEA) - (#x82D4 . #xC2DD) - (#x82D5 . #x8FD7D0) - (#x82D7 . #xC9C4) - (#x82D9 . #xE7FE) - (#x82DA . #x8FD7D1) - (#x82DB . #xB2D7) - (#x82DC . #xE7FC) - (#x82DE . #xE7FA) - (#x82DF . #xE7F1) - (#x82E0 . #x8FD7D2) - (#x82E1 . #xE7EF) - (#x82E2 . #x8FD7D3) - (#x82E3 . #xE7F0) - (#x82E4 . #x8FD7D4) - (#x82E5 . #xBCE3) - (#x82E6 . #xB6EC) - (#x82E7 . #xC3F7) - (#x82E8 . #x8FD7D5) - (#x82EA . #x8FD7D6) - (#x82EB . #xC6D1) - (#x82ED . #x8FD7D7) - (#x82EF . #x8FD7D8) - (#x82F1 . #xB1D1) - (#x82F3 . #xE7F4) - (#x82F4 . #xE7F3) - (#x82F6 . #x8FD7D9) - (#x82F7 . #x8FD7DA) - (#x82F9 . #xE7F9) - (#x82FA . #xE7F5) - (#x82FB . #xE7F8) - (#x82FD . #x8FD7DB) - (#x82FE . #x8FD7DC) - (#x8300 . #x8FD7DD) - (#x8301 . #x8FD7DE) - (#x8302 . #xCCD0) - (#x8303 . #xE7F7) - (#x8304 . #xB2D8) - (#x8305 . #xB3FD) - (#x8306 . #xE7FB) - (#x8307 . #x8FD7DF) - (#x8308 . #x8FD7E0) - (#x8309 . #xE7FD) - (#x830A . #x8FD7E1) - (#x830B . #x8FD7E2) - (#x830E . #xB7D4) - (#x8316 . #xE8A3) - (#x8317 . #xE8AC) - (#x8318 . #xE8AD) - (#x831B . #x8FD7E4) - (#x831C . #xB0AB) - (#x831D . #x8FD7E5) - (#x831E . #x8FD7E6) - (#x831F . #x8FD7E7) - (#x8321 . #x8FD7E8) - (#x8322 . #x8FD7E9) - (#x8323 . #xE8B4) - (#x8328 . #xB0F1) - (#x832B . #xE8AB) - (#x832C . #x8FD7EA) - (#x832D . #x8FD7EB) - (#x832E . #x8FD7EC) - (#x832F . #xE8AA) - (#x8330 . #x8FD7ED) - (#x8331 . #xE8A5) - (#x8332 . #xE8A4) - (#x8333 . #x8FD7EE) - (#x8334 . #xE8A2) - (#x8335 . #xE8A1) - (#x8336 . #xC3E3) - (#x8337 . #x8FD7EF) - (#x8338 . #xC2FB) - (#x8339 . #xE8A7) - (#x833A . #x8FD7F0) - (#x833C . #x8FD7F1) - (#x833D . #x8FD7F2) - (#x8340 . #xE8A6) - (#x8342 . #x8FD7F3) - (#x8343 . #x8FD7F4) - (#x8344 . #x8FD7F5) - (#x8345 . #xE8A9) - (#x8347 . #x8FD7F6) - (#x8349 . #xC1F0) - (#x834A . #xB7D5) - (#x834D . #x8FD7F7) - (#x834E . #x8FD7F8) - (#x834F . #xB1C1) - (#x8350 . #xE8A8) - (#x8351 . #x8FD7F9) - (#x8352 . #xB9D3) - (#x8353 . #x8FD8BE) - (#x8354 . #x8FD7E3) - (#x8355 . #x8FD7FA) - (#x8356 . #x8FD7FB) - (#x8357 . #x8FD7FC) - (#x8358 . #xC1F1) - (#x8370 . #x8FD7FD) - (#x8373 . #xE8BA) - (#x8375 . #xE8BB) - (#x8377 . #xB2D9) - (#x8378 . #x8FD7FE) - (#x837B . #xB2AE) - (#x837C . #xE8B8) - (#x837D . #x8FD8A1) - (#x837F . #x8FD8A2) - (#x8380 . #x8FD8A3) - (#x8382 . #x8FD8A4) - (#x8384 . #x8FD8A5) - (#x8385 . #xE8AE) - (#x8386 . #x8FD8A6) - (#x8387 . #xE8B6) - (#x8389 . #xE8BD) - (#x838A . #xE8B7) - (#x838D . #x8FD8A7) - (#x838E . #xE8B5) - (#x8392 . #x8FD8A8) - (#x8393 . #xE7F6) - (#x8394 . #x8FD8A9) - (#x8395 . #x8FD8AA) - (#x8396 . #xE8B3) - (#x8398 . #x8FD8AB) - (#x8399 . #x8FD8AC) - (#x839A . #xE8AF) - (#x839B . #x8FD8AD) - (#x839C . #x8FD8AE) - (#x839D . #x8FD8AF) - (#x839E . #xB4D0) - (#x839F . #xE8B1) - (#x83A0 . #xE8BC) - (#x83A2 . #xE8B2) - (#x83A6 . #x8FD8B0) - (#x83A7 . #x8FD8B1) - (#x83A8 . #xE8BE) - (#x83A9 . #x8FD8B2) - (#x83AA . #xE8B0) - (#x83AB . #xC7FC) - (#x83AC . #x8FD8B3) - (#x83AD . #x8FD8CC) - (#x83B1 . #xCDE9) - (#x83B5 . #xE8B9) - (#x83BD . #xE8CF) - (#x83BE . #x8FD8B4) - (#x83BF . #x8FD8B5) - (#x83C0 . #x8FD8B6) - (#x83C1 . #xE8C7) - (#x83C5 . #xBFFB) - (#x83C7 . #x8FD8B7) - (#x83C9 . #x8FD8B8) - (#x83CA . #xB5C6) - (#x83CC . #xB6DD) - (#x83CE . #xE8C2) - (#x83CF . #x8FD8B9) - (#x83D0 . #x8FD8BA) - (#x83D1 . #x8FD8BB) - (#x83D3 . #xB2DB) - (#x83D4 . #x8FD8BC) - (#x83D6 . #xBED4) - (#x83D8 . #xE8C5) - (#x83DC . #xBADA) - (#x83DD . #x8FD8BD) - (#x83DF . #xC5D1) - (#x83E0 . #xE8CA) - (#x83E8 . #x8FD8BF) - (#x83E9 . #xCAEE) - (#x83EA . #x8FD8C0) - (#x83EB . #xE8C1) - (#x83EF . #xB2DA) - (#x83F0 . #xB8D6) - (#x83F1 . #xC9A9) - (#x83F2 . #xE8CB) - (#x83F4 . #xE8BF) - (#x83F6 . #x8FD8C1) - (#x83F7 . #xE8C8) - (#x83F8 . #x8FD8C2) - (#x83F9 . #x8FD8C3) - (#x83FB . #xE8D2) - (#x83FC . #x8FD8C4) - (#x83FD . #xE8C3) - (#x8401 . #x8FD8C5) - (#x8403 . #xE8C4) - (#x8404 . #xC6BA) - (#x8406 . #x8FD8C6) - (#x8407 . #xE8C9) - (#x840A . #x8FD8C7) - (#x840B . #xE8C6) - (#x840C . #xCBA8) - (#x840D . #xE8CC) - (#x840E . #xB0E0) - (#x840F . #x8FD8C8) - (#x8411 . #x8FD8C9) - (#x8413 . #xE8C0) - (#x8415 . #x8FD8CA) - (#x8419 . #x8FD8CB) - (#x8420 . #xE8CE) - (#x8422 . #xE8CD) - (#x8429 . #xC7EB) - (#x842A . #xE8D4) - (#x842C . #xE8DF) - (#x842F . #x8FD8CD) - (#x8431 . #xB3FE) - (#x8435 . #xE8E2) - (#x8438 . #xE8D0) - (#x8439 . #x8FD8CE) - (#x843C . #xE8D5) - (#x843D . #xCDEE) - (#x8445 . #x8FD8CF) - (#x8446 . #xE8DE) - (#x8447 . #x8FD8D0) - (#x8448 . #x8FD8D1) - (#x8449 . #xCDD5) - (#x844A . #x8FD8D2) - (#x844D . #x8FD8D3) - (#x844E . #xCEAA) - (#x844F . #x8FD8D4) - (#x8451 . #x8FD8D5) - (#x8452 . #x8FD8D6) - (#x8456 . #x8FD8D7) - (#x8457 . #xC3F8) - (#x8458 . #x8FD8D8) - (#x8459 . #x8FD8D9) - (#x845A . #x8FD8DA) - (#x845B . #xB3EB) - (#x845C . #x8FD8DB) - (#x8460 . #x8FD8DC) - (#x8461 . #xC9F2) - (#x8462 . #xE8E4) - (#x8463 . #xC6A1) - (#x8464 . #x8FD8DD) - (#x8465 . #x8FD8DE) - (#x8466 . #xB0B1) - (#x8467 . #x8FD8DF) - (#x8469 . #xE8DD) - (#x846A . #x8FD8E0) - (#x846B . #xE8D9) - (#x846C . #xC1F2) - (#x846D . #xE8D3) - (#x846E . #xE8DB) - (#x846F . #xE8E0) - (#x8470 . #x8FD8E1) - (#x8471 . #xC7AC) - (#x8473 . #x8FD8E2) - (#x8474 . #x8FD8E3) - (#x8475 . #xB0AA) - (#x8476 . #x8FD8E4) - (#x8477 . #xE8D8) - (#x8478 . #x8FD8E5) - (#x8479 . #xE8E1) - (#x847A . #xC9F8) - (#x847C . #x8FD8E6) - (#x847D . #x8FD8E7) - (#x8481 . #x8FD8E8) - (#x8482 . #xE8DC) - (#x8484 . #xE8D7) - (#x8485 . #x8FD8E9) - (#x848B . #xBED5) - (#x8490 . #xBDAF) - (#x8492 . #x8FD8EA) - (#x8493 . #x8FD8EB) - (#x8494 . #xBCAC) - (#x8495 . #x8FD8EC) - (#x8499 . #xCCD8) - (#x849C . #xC9C7) - (#x849E . #x8FD8ED) - (#x849F . #xE8E7) - (#x84A1 . #xE8F0) - (#x84A6 . #x8FD8EE) - (#x84A8 . #x8FD8EF) - (#x84A9 . #x8FD8F0) - (#x84AA . #x8FD8F1) - (#x84AD . #xE8DA) - (#x84AF . #x8FD8F2) - (#x84B1 . #x8FD8F3) - (#x84B2 . #xB3F7) - (#x84B4 . #x8FD8F4) - (#x84B8 . #xBEF8) - (#x84B9 . #xE8E5) - (#x84BA . #x8FD8F5) - (#x84BB . #xE8EA) - (#x84BC . #xC1F3) - (#x84BD . #x8FD8F6) - (#x84BE . #x8FD8F7) - (#x84BF . #xE8E6) - (#x84C0 . #x8FD8F8) - (#x84C1 . #xE8ED) - (#x84C2 . #x8FD8F9) - (#x84C4 . #xC3DF) - (#x84C6 . #xE8EE) - (#x84C7 . #x8FD8FA) - (#x84C8 . #x8FD8FB) - (#x84C9 . #xCDD6) - (#x84CA . #xE8E3) - (#x84CB . #xB3B8) - (#x84CC . #x8FD8FC) - (#x84CD . #xE8E9) - (#x84CF . #x8FD8FD) - (#x84D0 . #xE8EC) - (#x84D1 . #xCCAC) - (#x84D3 . #x8FD8FE) - (#x84D6 . #xE8EF) - (#x84D9 . #xE8E8) - (#x84DA . #xE8EB) - (#x84DC . #x8FD9A1) - (#x84E7 . #x8FD9A2) - (#x84EA . #x8FD9A3) - (#x84EC . #xCBA9) - (#x84EE . #xCFA1) - (#x84EF . #x8FD9A4) - (#x84F0 . #x8FD9A5) - (#x84F1 . #x8FD9A6) - (#x84F2 . #x8FD9A7) - (#x84F4 . #xE8F3) - (#x84F7 . #x8FD9A8) - (#x84FA . #x8FD9AA) - (#x84FB . #x8FD9AB) - (#x84FC . #xE8FA) - (#x84FD . #x8FD9AC) - (#x84FF . #xE8F2) - (#x8500 . #xBCC3) - (#x8502 . #x8FD9AD) - (#x8503 . #x8FD9AE) - (#x8506 . #xE8D1) - (#x8507 . #x8FD9AF) - (#x850C . #x8FD9B0) - (#x850E . #x8FD9B1) - (#x8510 . #x8FD9B2) - (#x8511 . #xCACE) - (#x8513 . #xCCA2) - (#x8514 . #xE8F9) - (#x8515 . #xE8F8) - (#x8517 . #xE8F4) - (#x8518 . #xE8F5) - (#x851A . #xB1B6) - (#x851C . #x8FD9B3) - (#x851E . #x8FD9B4) - (#x851F . #xE8F7) - (#x8521 . #xE8F1) - (#x8522 . #x8FD9B5) - (#x8523 . #x8FD9B6) - (#x8524 . #x8FD9B7) - (#x8525 . #x8FD9B8) - (#x8526 . #xC4D5) - (#x8527 . #x8FD9B9) - (#x852A . #x8FD9BA) - (#x852B . #x8FD9BB) - (#x852C . #xE8F6) - (#x852D . #xB0FE) - (#x852F . #x8FD9BC) - (#x8532 . #x8FD9A9) - (#x8533 . #x8FD9BD) - (#x8534 . #x8FD9BE) - (#x8535 . #xC2A2) - (#x8536 . #x8FD9BF) - (#x853D . #xCAC3) - (#x853F . #x8FD9C0) - (#x8540 . #xE8FB) - (#x8541 . #xE9A1) - (#x8543 . #xC8D9) - (#x8546 . #x8FD9C1) - (#x8548 . #xE8FE) - (#x8549 . #xBED6) - (#x854A . #xBCC9) - (#x854B . #xE9A3) - (#x854E . #xB6BE) - (#x854F . #x8FD9C2) - (#x8550 . #x8FD9C3) - (#x8551 . #x8FD9C4) - (#x8552 . #x8FD9C5) - (#x8553 . #x8FD9C6) - (#x8555 . #xE9A4) - (#x8556 . #x8FD9C7) - (#x8557 . #xC9F9) - (#x8558 . #xE8FD) - (#x8559 . #x8FD9C8) - (#x855A . #xE8D6) - (#x855C . #x8FD9C9) - (#x855D . #x8FD9CA) - (#x855E . #x8FD9CB) - (#x855F . #x8FD9CC) - (#x8560 . #x8FD9CD) - (#x8561 . #x8FD9CE) - (#x8562 . #x8FD9CF) - (#x8563 . #xE8FC) - (#x8564 . #x8FD9D0) - (#x8568 . #xCFCF) - (#x8569 . #xC6A2) - (#x856A . #xC9F3) - (#x856B . #x8FD9D1) - (#x856D . #xE9AB) - (#x856F . #x8FD9D2) - (#x8577 . #xE9B1) - (#x8579 . #x8FD9D3) - (#x857A . #x8FD9D4) - (#x857B . #x8FD9D5) - (#x857D . #x8FD9D6) - (#x857E . #xE9B2) - (#x857F . #x8FD9D7) - (#x8580 . #xE9A5) - (#x8581 . #x8FD9D8) - (#x8584 . #xC7F6) - (#x8585 . #x8FD9D9) - (#x8586 . #x8FD9DA) - (#x8587 . #xE9AF) - (#x8588 . #xE9A7) - (#x8589 . #x8FD9DB) - (#x858A . #xE9A9) - (#x858B . #x8FD9DC) - (#x858C . #x8FD9DD) - (#x858F . #x8FD9DE) - (#x8590 . #xE9B3) - (#x8591 . #xE9A8) - (#x8593 . #x8FD9DF) - (#x8594 . #xE9AC) - (#x8597 . #xB1F2) - (#x8598 . #x8FD9E0) - (#x8599 . #xC6E5) - (#x859B . #xE9AD) - (#x859C . #xE9B0) - (#x859D . #x8FD9E1) - (#x859F . #x8FD9E2) - (#x85A0 . #x8FD9E3) - (#x85A2 . #x8FD9E4) - (#x85A4 . #xE9A6) - (#x85A5 . #x8FD9E5) - (#x85A6 . #xC1A6) - (#x85A7 . #x8FD9E6) - (#x85A8 . #xE9AA) - (#x85A9 . #xBBA7) - (#x85AA . #xBFC5) - (#x85AB . #xB7B0) - (#x85AC . #xCCF4) - (#x85AD . #x8FD9F4) - (#x85AE . #xCCF9) - (#x85AF . #xBDF2) - (#x85B4 . #x8FD9E7) - (#x85B6 . #x8FD9E8) - (#x85B7 . #x8FD9E9) - (#x85B8 . #x8FD9EA) - (#x85B9 . #xE9B7) - (#x85BA . #xE9B5) - (#x85BC . #x8FD9EB) - (#x85BD . #x8FD9EC) - (#x85BE . #x8FD9ED) - (#x85BF . #x8FD9EE) - (#x85C1 . #xCFCE) - (#x85C2 . #x8FD9EF) - (#x85C7 . #x8FD9F0) - (#x85C9 . #xE9B4) - (#x85CA . #x8FD9F1) - (#x85CB . #x8FD9F2) - (#x85CD . #xCDF5) - (#x85CE . #x8FD9F3) - (#x85CF . #xE9B6) - (#x85D0 . #xE9B8) - (#x85D5 . #xE9B9) - (#x85D8 . #x8FD9F5) - (#x85DA . #x8FD9F6) - (#x85DC . #xE9BC) - (#x85DD . #xE9BA) - (#x85DF . #x8FD9F7) - (#x85E0 . #x8FD9F8) - (#x85E4 . #xC6A3) - (#x85E5 . #xE9BB) - (#x85E6 . #x8FD9F9) - (#x85E8 . #x8FD9FA) - (#x85E9 . #xC8CD) - (#x85EA . #xE9AE) - (#x85ED . #x8FD9FB) - (#x85F3 . #x8FD9FC) - (#x85F6 . #x8FD9FD) - (#x85F7 . #xBDF3) - (#x85F9 . #xE9BD) - (#x85FA . #xE9C2) - (#x85FB . #xC1F4) - (#x85FC . #x8FD9FE) - (#x85FE . #xE9C1) - (#x85FF . #x8FDAA1) - (#x8600 . #x8FDAA2) - (#x8602 . #xE9A2) - (#x8604 . #x8FDAA3) - (#x8605 . #x8FDAA4) - (#x8606 . #xE9C3) - (#x8607 . #xC1C9) - (#x860A . #xE9BE) - (#x860B . #xE9C0) - (#x860D . #x8FDAA5) - (#x860E . #x8FDAA6) - (#x8610 . #x8FDAA7) - (#x8611 . #x8FDAA8) - (#x8612 . #x8FDAA9) - (#x8613 . #xE9BF) - (#x8616 . #xDDB1) - (#x8617 . #xDDA2) - (#x8618 . #x8FDAAA) - (#x8619 . #x8FDAAB) - (#x861A . #xE9C5) - (#x861B . #x8FDAAC) - (#x861E . #x8FDAAD) - (#x8621 . #x8FDAAE) - (#x8622 . #xE9C4) - (#x8627 . #x8FDAAF) - (#x8629 . #x8FDAB0) - (#x862D . #xCDF6) - (#x862F . #xE2BC) - (#x8630 . #xE9C6) - (#x8636 . #x8FDAB1) - (#x8638 . #x8FDAB2) - (#x863A . #x8FDAB3) - (#x863C . #x8FDAB4) - (#x863D . #x8FDAB5) - (#x863F . #xE9C7) - (#x8640 . #x8FDAB6) - (#x8641 . #x8FB8E6) - (#x8642 . #x8FDAB7) - (#x8646 . #x8FDAB8) - (#x864D . #xE9C8) - (#x864E . #xB8D7) - (#x8650 . #xB5D4) - (#x8652 . #x8FDAB9) - (#x8653 . #x8FDABA) - (#x8654 . #xE9CA) - (#x8655 . #xD1DD) - (#x8656 . #x8FDABB) - (#x8657 . #x8FDABC) - (#x8658 . #x8FDABD) - (#x8659 . #x8FDABE) - (#x865A . #xB5F5) - (#x865C . #xCEBA) - (#x865D . #x8FDABF) - (#x865E . #xB6F3) - (#x865F . #xE9CB) - (#x8660 . #x8FDAC0) - (#x8661 . #x8FDAC1) - (#x8662 . #x8FDAC2) - (#x8663 . #x8FDAC3) - (#x8664 . #x8FDAC4) - (#x8667 . #xE9CC) - (#x8669 . #x8FDAC5) - (#x866B . #xC3EE) - (#x866C . #x8FDAC6) - (#x866F . #x8FDAC7) - (#x8671 . #xE9CD) - (#x8675 . #x8FDAC8) - (#x8676 . #x8FDAC9) - (#x8677 . #x8FDACA) - (#x8679 . #xC6FA) - (#x867A . #x8FDACB) - (#x867B . #xB0BA) - (#x8688 . #x8FDAED) - (#x868A . #xB2E3) - (#x868B . #xE9D2) - (#x868C . #xE9D3) - (#x868D . #x8FDACC) - (#x8691 . #x8FDACD) - (#x8693 . #xE9CE) - (#x8695 . #xBBBD) - (#x8696 . #x8FDACE) - (#x8698 . #x8FDACF) - (#x869A . #x8FDAD0) - (#x869C . #x8FDAD1) - (#x86A1 . #x8FDAD2) - (#x86A3 . #xE9CF) - (#x86A4 . #xC7C2) - (#x86A6 . #x8FDAD3) - (#x86A7 . #x8FDAD4) - (#x86A8 . #x8FDAD5) - (#x86A9 . #xE9D0) - (#x86AA . #xE9D1) - (#x86AB . #xE9DB) - (#x86AD . #x8FDAD6) - (#x86AF . #xE9D5) - (#x86B0 . #xE9D8) - (#x86B1 . #x8FDAD7) - (#x86B3 . #x8FDAD8) - (#x86B4 . #x8FDAD9) - (#x86B5 . #x8FDADA) - (#x86B6 . #xE9D4) - (#x86B7 . #x8FDADB) - (#x86B8 . #x8FDADC) - (#x86B9 . #x8FDADD) - (#x86BF . #x8FDADE) - (#x86C0 . #x8FDADF) - (#x86C1 . #x8FDAE0) - (#x86C3 . #x8FDAE1) - (#x86C4 . #xE9D6) - (#x86C5 . #x8FDAE2) - (#x86C6 . #xE9D7) - (#x86C7 . #xBCD8) - (#x86C9 . #xE9D9) - (#x86CB . #xC3C1) - (#x86CD . #xB7D6) - (#x86CE . #xB3C2) - (#x86D1 . #x8FDAE3) - (#x86D2 . #x8FDAE4) - (#x86D4 . #xE9DC) - (#x86D5 . #x8FDAE5) - (#x86D7 . #x8FDAE6) - (#x86D9 . #xB3BF) - (#x86DA . #x8FDAE7) - (#x86DB . #xE9E1) - (#x86DC . #x8FDAE8) - (#x86DE . #xE9DD) - (#x86DF . #xE9E0) - (#x86E0 . #x8FDAE9) - (#x86E3 . #x8FDAEA) - (#x86E4 . #xC8BA) - (#x86E5 . #x8FDAEB) - (#x86E7 . #x8FDAEC) - (#x86E9 . #xE9DE) - (#x86EC . #xE9DF) - (#x86ED . #xC9C8) - (#x86EE . #xC8DA) - (#x86EF . #xE9E2) - (#x86F8 . #xC2FD) - (#x86F9 . #xE9EC) - (#x86FA . #x8FDAEE) - (#x86FB . #xE9E8) - (#x86FC . #x8FDAEF) - (#x86FD . #x8FDAF0) - (#x86FE . #xB2EB) - (#x8700 . #xE9E6) - (#x8702 . #xCBAA) - (#x8703 . #xE9E7) - (#x8704 . #x8FDAF1) - (#x8705 . #x8FDAF2) - (#x8706 . #xE9E4) - (#x8707 . #x8FDAF3) - (#x8708 . #xE9E5) - (#x8709 . #xE9EA) - (#x870A . #xE9ED) - (#x870B . #x8FDAF4) - (#x870D . #xE9EB) - (#x870E . #x8FDAF5) - (#x870F . #x8FDAF6) - (#x8710 . #x8FDAF7) - (#x8711 . #xE9E9) - (#x8712 . #xE9E3) - (#x8713 . #x8FDAF8) - (#x8714 . #x8FDAF9) - (#x8718 . #xC3D8) - (#x8719 . #x8FDAFA) - (#x871A . #xE9F4) - (#x871C . #xCCAA) - (#x871E . #x8FDAFB) - (#x871F . #x8FDAFC) - (#x8721 . #x8FDAFD) - (#x8723 . #x8FDAFE) - (#x8725 . #xE9F2) - (#x8728 . #x8FDBA1) - (#x8729 . #xE9F3) - (#x872E . #x8FDBA2) - (#x872F . #x8FDBA3) - (#x8731 . #x8FDBA4) - (#x8732 . #x8FDBA5) - (#x8734 . #xE9EE) - (#x8737 . #xE9F0) - (#x8739 . #x8FDBA6) - (#x873A . #x8FDBA7) - (#x873B . #xE9F1) - (#x873C . #x8FDBA8) - (#x873D . #x8FDBA9) - (#x873E . #x8FDBAA) - (#x873F . #xE9EF) - (#x8740 . #x8FDBAB) - (#x8743 . #x8FDBAC) - (#x8745 . #x8FDBAD) - (#x8749 . #xC0E6) - (#x874B . #xCFB9) - (#x874C . #xE9F8) - (#x874D . #x8FDBAE) - (#x874E . #xE9F9) - (#x8753 . #xEAA1) - (#x8755 . #xBFAA) - (#x8757 . #xE9FB) - (#x8758 . #x8FDBAF) - (#x8759 . #xE9FE) - (#x875D . #x8FDBB0) - (#x875F . #xE9F6) - (#x8760 . #xE9F5) - (#x8761 . #x8FDBB1) - (#x8763 . #xEAA2) - (#x8764 . #x8FDBB2) - (#x8765 . #x8FDBB3) - (#x8766 . #xB2DC) - (#x8768 . #xE9FC) - (#x876A . #xEAA3) - (#x876E . #xE9FD) - (#x876F . #x8FDBB4) - (#x8771 . #x8FDBB5) - (#x8772 . #x8FDBB6) - (#x8774 . #xE9FA) - (#x8776 . #xC4B3) - (#x8778 . #xE9F7) - (#x877B . #x8FDBB7) - (#x877F . #xC7E8) - (#x8782 . #xEAA7) - (#x8783 . #x8FDBB8) - (#x8784 . #x8FDBB9) - (#x8785 . #x8FDBBA) - (#x8786 . #x8FDBBB) - (#x8787 . #x8FDBBC) - (#x8788 . #x8FDBBD) - (#x8789 . #x8FDBBE) - (#x878B . #x8FDBBF) - (#x878C . #x8FDBC0) - (#x878D . #xCDBB) - (#x8790 . #x8FDBC1) - (#x8793 . #x8FDBC2) - (#x8795 . #x8FDBC3) - (#x8797 . #x8FDBC4) - (#x8798 . #x8FDBC5) - (#x8799 . #x8FDBC6) - (#x879E . #x8FDBC7) - (#x879F . #xEAA6) - (#x87A0 . #x8FDBC8) - (#x87A2 . #xEAA5) - (#x87A3 . #x8FDBC9) - (#x87A7 . #x8FDBCA) - (#x87AB . #xEAAE) - (#x87AC . #x8FDBCB) - (#x87AD . #x8FDBCC) - (#x87AE . #x8FDBCD) - (#x87AF . #xEAA8) - (#x87B1 . #x8FDBCE) - (#x87B3 . #xEAB0) - (#x87B5 . #x8FDBCF) - (#x87BA . #xCDE6) - (#x87BB . #xEAB3) - (#x87BD . #xEAAA) - (#x87BE . #x8FDBD0) - (#x87BF . #x8FDBD1) - (#x87C0 . #xEAAB) - (#x87C1 . #x8FDBD2) - (#x87C4 . #xEAAF) - (#x87C6 . #xEAB2) - (#x87C7 . #xEAB1) - (#x87C8 . #x8FDBD3) - (#x87C9 . #x8FDBD4) - (#x87CA . #x8FDBD5) - (#x87CB . #xEAA9) - (#x87CE . #x8FDBD6) - (#x87D0 . #xEAAC) - (#x87D2 . #xEABD) - (#x87D5 . #x8FDBD7) - (#x87D6 . #x8FDBD8) - (#x87D9 . #x8FDBD9) - (#x87DA . #x8FDBDA) - (#x87DC . #x8FDBDB) - (#x87DF . #x8FDBDC) - (#x87E0 . #xEAB6) - (#x87E2 . #x8FDBDD) - (#x87E3 . #x8FDBDE) - (#x87E4 . #x8FDBDF) - (#x87EA . #x8FDBE0) - (#x87EB . #x8FDBE1) - (#x87ED . #x8FDBE2) - (#x87EF . #xEAB4) - (#x87F1 . #x8FDBE3) - (#x87F2 . #xEAB5) - (#x87F3 . #x8FDBE4) - (#x87F6 . #xEABA) - (#x87F7 . #xEABB) - (#x87F8 . #x8FDBE5) - (#x87F9 . #xB3AA) - (#x87FA . #x8FDBE6) - (#x87FB . #xB5C2) - (#x87FE . #xEAB9) - (#x87FF . #x8FDBE7) - (#x8801 . #x8FDBE8) - (#x8803 . #x8FDBE9) - (#x8805 . #xEAA4) - (#x8806 . #x8FDBEA) - (#x8809 . #x8FDBEB) - (#x880A . #x8FDBEC) - (#x880B . #x8FDBED) - (#x880D . #xEAB8) - (#x880E . #xEABC) - (#x880F . #xEAB7) - (#x8810 . #x8FDBEE) - (#x8811 . #xEABE) - (#x8812 . #x8FDBF0) - (#x8813 . #x8FDBF1) - (#x8814 . #x8FDBF2) - (#x8815 . #xEAC0) - (#x8816 . #xEABF) - (#x8818 . #x8FDBF3) - (#x8819 . #x8FDBEF) - (#x881A . #x8FDBF4) - (#x881B . #x8FDBF5) - (#x881C . #x8FDBF6) - (#x881E . #x8FDBF7) - (#x881F . #x8FDBF8) - (#x8821 . #xEAC2) - (#x8822 . #xEAC1) - (#x8823 . #xE9DA) - (#x8827 . #xEAC6) - (#x8828 . #x8FDBF9) - (#x882D . #x8FDBFA) - (#x882E . #x8FDBFB) - (#x8830 . #x8FDBFC) - (#x8831 . #xEAC3) - (#x8832 . #x8FDBFD) - (#x8835 . #x8FDBFE) - (#x8836 . #xEAC4) - (#x8839 . #xEAC5) - (#x883A . #x8FDCA1) - (#x883B . #xEAC7) - (#x883C . #x8FDCA2) - (#x8840 . #xB7EC) - (#x8841 . #x8FDCA3) - (#x8842 . #xEAC9) - (#x8843 . #x8FDCA4) - (#x8844 . #xEAC8) - (#x8845 . #x8FDCA5) - (#x8846 . #xBDB0) - (#x8848 . #x8FDCA6) - (#x8849 . #x8FDCA7) - (#x884A . #x8FDCA8) - (#x884B . #x8FDCA9) - (#x884C . #xB9D4) - (#x884D . #xDEA7) - (#x884E . #x8FDCAA) - (#x8851 . #x8FDCAB) - (#x8852 . #xEACA) - (#x8853 . #xBDD1) - (#x8855 . #x8FDCAC) - (#x8856 . #x8FDCAD) - (#x8857 . #xB3B9) - (#x8858 . #x8FDCAE) - (#x8859 . #xEACB) - (#x885A . #x8FDCAF) - (#x885B . #xB1D2) - (#x885C . #x8FDCB0) - (#x885D . #xBED7) - (#x885E . #xEACC) - (#x885F . #x8FDCB1) - (#x8860 . #x8FDCB2) - (#x8861 . #xB9D5) - (#x8862 . #xEACD) - (#x8863 . #xB0E1) - (#x8864 . #x8FDCB3) - (#x8868 . #xC9BD) - (#x8869 . #x8FDCB4) - (#x886B . #xEACE) - (#x8870 . #xBFEA) - (#x8871 . #x8FDCB5) - (#x8872 . #xEAD5) - (#x8875 . #xEAD2) - (#x8877 . #xC3EF) - (#x8879 . #x8FDCB6) - (#x887B . #x8FDCB7) - (#x887D . #xEAD3) - (#x887E . #xEAD0) - (#x887F . #xB6DE) - (#x8880 . #x8FDCB8) - (#x8881 . #xEACF) - (#x8882 . #xEAD6) - (#x8888 . #xB7B6) - (#x888B . #xC2DE) - (#x888D . #xEADC) - (#x8892 . #xEAD8) - (#x8896 . #xC2B5) - (#x8897 . #xEAD7) - (#x8898 . #x8FDCB9) - (#x8899 . #xEADA) - (#x889A . #x8FDCBA) - (#x889B . #x8FDCBB) - (#x889C . #x8FDCBC) - (#x889E . #xEAD1) - (#x889F . #x8FDCBD) - (#x88A0 . #x8FDCBE) - (#x88A2 . #xEADB) - (#x88A4 . #xEADD) - (#x88A8 . #x8FDCBF) - (#x88AA . #x8FDCC0) - (#x88AB . #xC8EF) - (#x88AE . #xEAD9) - (#x88B0 . #xEADE) - (#x88B1 . #xEAE0) - (#x88B4 . #xB8D3) - (#x88B5 . #xEAD4) - (#x88B7 . #xB0C1) - (#x88BA . #x8FDCC1) - (#x88BD . #x8FDCC2) - (#x88BE . #x8FDCC3) - (#x88BF . #xEADF) - (#x88C0 . #x8FDCC4) - (#x88C1 . #xBADB) - (#x88C2 . #xCEF6) - (#x88C3 . #xEAE1) - (#x88C4 . #xEAE2) - (#x88C5 . #xC1F5) - (#x88CA . #x8FDCC5) - (#x88CB . #x8FDCC6) - (#x88CC . #x8FDCC7) - (#x88CD . #x8FDCC8) - (#x88CE . #x8FDCC9) - (#x88CF . #xCEA2) - (#x88D1 . #x8FDCCA) - (#x88D2 . #x8FDCCB) - (#x88D3 . #x8FDCCC) - (#x88D4 . #xEAE3) - (#x88D5 . #xCDB5) - (#x88D8 . #xEAE4) - (#x88D9 . #xEAE5) - (#x88DB . #x8FDCCD) - (#x88DC . #xCAE4) - (#x88DD . #xEAE6) - (#x88DE . #x8FDCCE) - (#x88DF . #xBAC0) - (#x88E1 . #xCEA3) - (#x88E7 . #x8FDCCF) - (#x88E8 . #xEAEB) - (#x88EF . #x8FDCD0) - (#x88F0 . #x8FDCD1) - (#x88F1 . #x8FDCD2) - (#x88F2 . #xEAEC) - (#x88F3 . #xBED8) - (#x88F4 . #xEAEA) - (#x88F5 . #x8FDCD3) - (#x88F7 . #x8FDCD4) - (#x88F8 . #xCDE7) - (#x88F9 . #xEAE7) - (#x88FC . #xEAE9) - (#x88FD . #xC0BD) - (#x88FE . #xBFFE) - (#x8901 . #x8FDCD5) - (#x8902 . #xEAE8) - (#x8904 . #xEAED) - (#x8906 . #x8FDCD6) - (#x8907 . #xCAA3) - (#x890A . #xEAEF) - (#x890C . #xEAEE) - (#x890D . #x8FDCD7) - (#x890E . #x8FDCD8) - (#x890F . #x8FDCD9) - (#x8910 . #xB3EC) - (#x8912 . #xCBAB) - (#x8913 . #xEAF0) - (#x8915 . #x8FDCDA) - (#x8916 . #x8FDCDB) - (#x8918 . #x8FDCDC) - (#x8919 . #x8FDCDD) - (#x891A . #x8FDCDE) - (#x891C . #x8FDCDF) - (#x891D . #xEAFC) - (#x891E . #xEAF2) - (#x8920 . #x8FDCE0) - (#x8925 . #xEAF3) - (#x8926 . #x8FDCE1) - (#x8927 . #x8FDCE2) - (#x8928 . #x8FDCE3) - (#x892A . #xEAF4) - (#x892B . #xEAF5) - (#x8930 . #x8FDCE4) - (#x8931 . #x8FDCE5) - (#x8932 . #x8FDCE6) - (#x8935 . #x8FDCE7) - (#x8936 . #xEAF9) - (#x8938 . #xEAFA) - (#x8939 . #x8FDCE8) - (#x893A . #x8FDCE9) - (#x893B . #xEAF8) - (#x893E . #x8FDCEA) - (#x8940 . #x8FDCEB) - (#x8941 . #xEAF6) - (#x8942 . #x8FDCEC) - (#x8943 . #xEAF1) - (#x8944 . #xEAF7) - (#x8945 . #x8FDCED) - (#x8946 . #x8FDCEE) - (#x8949 . #x8FDCEF) - (#x894C . #xEAFB) - (#x894D . #xF0B7) - (#x894F . #x8FDCF0) - (#x8952 . #x8FDCF1) - (#x8956 . #xB2A8) - (#x8957 . #x8FDCF2) - (#x895A . #x8FDCF3) - (#x895B . #x8FDCF4) - (#x895C . #x8FDCF5) - (#x895E . #xEAFE) - (#x895F . #xB6DF) - (#x8960 . #xEAFD) - (#x8961 . #x8FDCF6) - (#x8962 . #x8FDCF7) - (#x8963 . #x8FDCF8) - (#x8964 . #xEBA2) - (#x8966 . #xEBA1) - (#x896A . #xEBA4) - (#x896B . #x8FDCF9) - (#x896D . #xEBA3) - (#x896E . #x8FDCFA) - (#x896F . #xEBA5) - (#x8970 . #x8FDCFB) - (#x8972 . #xBDB1) - (#x8973 . #x8FDCFC) - (#x8974 . #xEBA6) - (#x8975 . #x8FDCFD) - (#x8977 . #xEBA7) - (#x897A . #x8FDCFE) - (#x897B . #x8FDDA1) - (#x897C . #x8FDDA2) - (#x897D . #x8FDDA3) - (#x897E . #xEBA8) - (#x897F . #xC0BE) - (#x8981 . #xCDD7) - (#x8983 . #xEBA9) - (#x8986 . #xCAA4) - (#x8987 . #xC7C6) - (#x8988 . #xEBAA) - (#x8989 . #x8FDDA4) - (#x898A . #xEBAB) - (#x898B . #xB8AB) - (#x898D . #x8FDDA5) - (#x898F . #xB5AC) - (#x8990 . #x8FDDA6) - (#x8993 . #xEBAC) - (#x8994 . #x8FDDA7) - (#x8995 . #x8FDDA8) - (#x8996 . #xBBEB) - (#x8997 . #xC7C1) - (#x8998 . #xEBAD) - (#x899A . #xB3D0) - (#x899B . #x8FDDA9) - (#x899C . #x8FDDAA) - (#x899F . #x8FDDAB) - (#x89A0 . #x8FDDAC) - (#x89A1 . #xEBAE) - (#x89A5 . #x8FDDAD) - (#x89A6 . #xEBB0) - (#x89A7 . #xCDF7) - (#x89A9 . #xEBAF) - (#x89AA . #xBFC6) - (#x89AC . #xEBB1) - (#x89AF . #xEBB2) - (#x89B0 . #x8FDDAE) - (#x89B2 . #xEBB3) - (#x89B3 . #xB4D1) - (#x89B4 . #x8FDDAF) - (#x89B5 . #x8FDDB0) - (#x89B6 . #x8FDDB1) - (#x89B7 . #x8FDDB2) - (#x89BA . #xEBB4) - (#x89BC . #x8FDDB3) - (#x89BD . #xEBB5) - (#x89BF . #xEBB6) - (#x89C0 . #xEBB7) - (#x89D2 . #xB3D1) - (#x89D4 . #x8FDDB4) - (#x89D5 . #x8FDDB5) - (#x89D6 . #x8FDDB6) - (#x89D7 . #x8FDDB7) - (#x89D8 . #x8FDDB8) - (#x89DA . #xEBB8) - (#x89DC . #xEBB9) - (#x89DD . #xEBBA) - (#x89E3 . #xB2F2) - (#x89E5 . #x8FDDB9) - (#x89E6 . #xBFA8) - (#x89E7 . #xEBBB) - (#x89E9 . #x8FDDBA) - (#x89EB . #x8FDDBB) - (#x89ED . #x8FDDBC) - (#x89F1 . #x8FDDBD) - (#x89F3 . #x8FDDBE) - (#x89F4 . #xEBBC) - (#x89F6 . #x8FDDBF) - (#x89F8 . #xEBBD) - (#x89F9 . #x8FDDC0) - (#x89FD . #x8FDDC1) - (#x89FF . #x8FDDC2) - (#x8A00 . #xB8C0) - (#x8A02 . #xC4FB) - (#x8A03 . #xEBBE) - (#x8A04 . #x8FDDC3) - (#x8A05 . #x8FDDC4) - (#x8A07 . #x8FDDC5) - (#x8A08 . #xB7D7) - (#x8A0A . #xBFD6) - (#x8A0C . #xEBC1) - (#x8A0E . #xC6A4) - (#x8A0F . #x8FDDC6) - (#x8A10 . #xEBC0) - (#x8A11 . #x8FDDC7) - (#x8A12 . #x8FDDC8) - (#x8A13 . #xB7B1) - (#x8A14 . #x8FDDC9) - (#x8A15 . #x8FDDCA) - (#x8A16 . #xEBBF) - (#x8A17 . #xC2F7) - (#x8A18 . #xB5AD) - (#x8A1B . #xEBC2) - (#x8A1D . #xEBC3) - (#x8A1E . #x8FDDCB) - (#x8A1F . #xBED9) - (#x8A20 . #x8FDDCC) - (#x8A22 . #x8FDDCD) - (#x8A23 . #xB7ED) - (#x8A24 . #x8FDDCE) - (#x8A25 . #xEBC4) - (#x8A26 . #x8FDDCF) - (#x8A2A . #xCBAC) - (#x8A2B . #x8FDDD0) - (#x8A2C . #x8FDDD1) - (#x8A2D . #xC0DF) - (#x8A2F . #x8FDDD2) - (#x8A31 . #xB5F6) - (#x8A33 . #xCCF5) - (#x8A34 . #xC1CA) - (#x8A35 . #x8FDDD3) - (#x8A36 . #xEBC5) - (#x8A37 . #x8FDDD4) - (#x8A3A . #xBFC7) - (#x8A3B . #xC3F0) - (#x8A3C . #xBEDA) - (#x8A3D . #x8FDDD5) - (#x8A3E . #x8FDDD6) - (#x8A40 . #x8FDDD7) - (#x8A41 . #xEBC6) - (#x8A43 . #x8FDDD8) - (#x8A45 . #x8FDDD9) - (#x8A46 . #xEBC9) - (#x8A47 . #x8FDDDA) - (#x8A48 . #xEBCA) - (#x8A49 . #x8FDDDB) - (#x8A4D . #x8FDDDC) - (#x8A4E . #x8FDDDD) - (#x8A50 . #xBABE) - (#x8A51 . #xC2C2) - (#x8A52 . #xEBC8) - (#x8A53 . #x8FDDDE) - (#x8A54 . #xBEDB) - (#x8A55 . #xC9BE) - (#x8A56 . #x8FDDDF) - (#x8A57 . #x8FDDE0) - (#x8A58 . #x8FDDE1) - (#x8A5B . #xEBC7) - (#x8A5C . #x8FDDE2) - (#x8A5D . #x8FDDE3) - (#x8A5E . #xBBEC) - (#x8A60 . #xB1D3) - (#x8A61 . #x8FDDE4) - (#x8A62 . #xEBCE) - (#x8A63 . #xB7D8) - (#x8A65 . #x8FDDE5) - (#x8A66 . #xBBEE) - (#x8A67 . #x8FDDE6) - (#x8A69 . #xBBED) - (#x8A6B . #xCFCD) - (#x8A6C . #xEBCD) - (#x8A6D . #xEBCC) - (#x8A6E . #xC1A7) - (#x8A70 . #xB5CD) - (#x8A71 . #xCFC3) - (#x8A72 . #xB3BA) - (#x8A73 . #xBEDC) - (#x8A75 . #x8FDDE7) - (#x8A76 . #x8FDDE8) - (#x8A77 . #x8FDDE9) - (#x8A79 . #x8FDDEA) - (#x8A7A . #x8FDDEB) - (#x8A7B . #x8FDDEC) - (#x8A7C . #xEBCB) - (#x8A7E . #x8FDDED) - (#x8A7F . #x8FDDEE) - (#x8A80 . #x8FDDEF) - (#x8A82 . #xEBD0) - (#x8A83 . #x8FDDF0) - (#x8A84 . #xEBD1) - (#x8A85 . #xEBCF) - (#x8A86 . #x8FDDF1) - (#x8A87 . #xB8D8) - (#x8A89 . #xCDC0) - (#x8A8B . #x8FDDF2) - (#x8A8C . #xBBEF) - (#x8A8D . #xC7A7) - (#x8A8F . #x8FDDF3) - (#x8A90 . #x8FDDF4) - (#x8A91 . #xEBD4) - (#x8A92 . #x8FDDF5) - (#x8A93 . #xC0C0) - (#x8A95 . #xC3C2) - (#x8A96 . #x8FDDF6) - (#x8A97 . #x8FDDF7) - (#x8A98 . #xCDB6) - (#x8A99 . #x8FDDF8) - (#x8A9A . #xEBD7) - (#x8A9E . #xB8EC) - (#x8A9F . #x8FDDF9) - (#x8AA0 . #xC0BF) - (#x8AA1 . #xEBD3) - (#x8AA3 . #xEBD8) - (#x8AA4 . #xB8ED) - (#x8AA5 . #xEBD5) - (#x8AA6 . #xEBD6) - (#x8AA7 . #x8FDDFA) - (#x8AA8 . #xEBD2) - (#x8AA9 . #x8FDDFB) - (#x8AAC . #xC0E2) - (#x8AAD . #xC6C9) - (#x8AAE . #x8FDDFC) - (#x8AAF . #x8FDDFD) - (#x8AB0 . #xC3AF) - (#x8AB2 . #xB2DD) - (#x8AB3 . #x8FDDFE) - (#x8AB6 . #x8FDEA1) - (#x8AB7 . #x8FDEA2) - (#x8AB9 . #xC8F0) - (#x8ABB . #x8FDEA3) - (#x8ABC . #xB5C3) - (#x8ABE . #x8FDEA4) - (#x8ABF . #xC4B4) - (#x8AC2 . #xEBDB) - (#x8AC3 . #x8FDEA5) - (#x8AC4 . #xEBD9) - (#x8AC6 . #x8FDEA6) - (#x8AC7 . #xC3CC) - (#x8AC8 . #x8FDEA7) - (#x8AC9 . #x8FDEA8) - (#x8ACA . #x8FDEA9) - (#x8ACB . #xC0C1) - (#x8ACC . #xB4D2) - (#x8ACD . #xEBDA) - (#x8ACF . #xBFDB) - (#x8AD1 . #x8FDEAA) - (#x8AD2 . #xCECA) - (#x8AD3 . #x8FDEAB) - (#x8AD4 . #x8FDEAC) - (#x8AD5 . #x8FDEAD) - (#x8AD6 . #xCFC0) - (#x8AD7 . #x8FDEAE) - (#x8ADA . #xEBDC) - (#x8ADB . #xEBE7) - (#x8ADC . #xC4B5) - (#x8ADD . #x8FDEAF) - (#x8ADE . #xEBE6) - (#x8ADF . #x8FDEB0) - (#x8AE0 . #xEBE3) - (#x8AE1 . #xEBEB) - (#x8AE2 . #xEBE4) - (#x8AE4 . #xEBE0) - (#x8AE6 . #xC4FC) - (#x8AE7 . #xEBDF) - (#x8AEB . #xEBDD) - (#x8AEC . #x8FDEB1) - (#x8AED . #xCDA1) - (#x8AEE . #xBBF0) - (#x8AF0 . #x8FDEB2) - (#x8AF1 . #xEBE1) - (#x8AF3 . #xEBDE) - (#x8AF4 . #x8FDEB3) - (#x8AF5 . #x8FDEB4) - (#x8AF6 . #x8FDEB5) - (#x8AF7 . #xEBE5) - (#x8AF8 . #xBDF4) - (#x8AFA . #xB8C1) - (#x8AFC . #x8FDEB6) - (#x8AFE . #xC2FA) - (#x8AFF . #x8FDEB7) - (#x8B00 . #xCBC5) - (#x8B01 . #xB1DA) - (#x8B02 . #xB0E2) - (#x8B04 . #xC6A5) - (#x8B05 . #x8FDEB8) - (#x8B06 . #x8FDEB9) - (#x8B07 . #xEBE9) - (#x8B0A . #x8FDEBF) - (#x8B0B . #x8FDEBA) - (#x8B0C . #xEBE8) - (#x8B0E . #xC6E6) - (#x8B10 . #xEBED) - (#x8B11 . #x8FDEBB) - (#x8B14 . #xEBE2) - (#x8B16 . #xEBEC) - (#x8B17 . #xEBEE) - (#x8B19 . #xB8AC) - (#x8B1A . #xEBEA) - (#x8B1B . #xB9D6) - (#x8B1C . #x8FDEBC) - (#x8B1D . #xBCD5) - (#x8B1E . #x8FDEBD) - (#x8B1F . #x8FDEBE) - (#x8B20 . #xEBEF) - (#x8B21 . #xCDD8) - (#x8B26 . #xEBF2) - (#x8B28 . #xEBF5) - (#x8B2B . #xEBF3) - (#x8B2C . #xC9B5) - (#x8B2D . #x8FDEC0) - (#x8B30 . #x8FDEC1) - (#x8B33 . #xEBF0) - (#x8B37 . #x8FDEC2) - (#x8B39 . #xB6E0) - (#x8B3C . #x8FDEC3) - (#x8B3E . #xEBF4) - (#x8B41 . #xEBF6) - (#x8B42 . #x8FDEC4) - (#x8B43 . #x8FDEC5) - (#x8B44 . #x8FDEC6) - (#x8B45 . #x8FDEC7) - (#x8B46 . #x8FDEC8) - (#x8B48 . #x8FDEC9) - (#x8B49 . #xEBFA) - (#x8B4C . #xEBF7) - (#x8B4D . #x8FDECE) - (#x8B4E . #xEBF9) - (#x8B4F . #xEBF8) - (#x8B52 . #x8FDECA) - (#x8B53 . #x8FDECB) - (#x8B54 . #x8FDECC) - (#x8B56 . #xEBFB) - (#x8B58 . #xBCB1) - (#x8B59 . #x8FDECD) - (#x8B5A . #xEBFD) - (#x8B5B . #xEBFC) - (#x8B5C . #xC9E8) - (#x8B5E . #x8FDECF) - (#x8B5F . #xECA1) - (#x8B63 . #x8FDED0) - (#x8B66 . #xB7D9) - (#x8B6B . #xEBFE) - (#x8B6C . #xECA2) - (#x8B6D . #x8FDED1) - (#x8B6F . #xECA3) - (#x8B70 . #xB5C4) - (#x8B71 . #xE6C1) - (#x8B72 . #xBEF9) - (#x8B74 . #xECA4) - (#x8B76 . #x8FDED2) - (#x8B77 . #xB8EE) - (#x8B78 . #x8FDED3) - (#x8B79 . #x8FDED4) - (#x8B7C . #x8FDED5) - (#x8B7D . #xECA5) - (#x8B7E . #x8FDED6) - (#x8B80 . #xECA6) - (#x8B81 . #x8FDED7) - (#x8B83 . #xBBBE) - (#x8B84 . #x8FDED8) - (#x8B85 . #x8FDED9) - (#x8B8A . #xDACE) - (#x8B8B . #x8FDEDA) - (#x8B8C . #xECA7) - (#x8B8D . #x8FDEDB) - (#x8B8E . #xECA8) - (#x8B8F . #x8FDEDC) - (#x8B90 . #xBDB2) - (#x8B92 . #xECA9) - (#x8B93 . #xECAA) - (#x8B94 . #x8FDEDD) - (#x8B95 . #x8FDEDE) - (#x8B96 . #xECAB) - (#x8B99 . #xECAC) - (#x8B9A . #xECAD) - (#x8B9C . #x8FDEDF) - (#x8B9E . #x8FDEE0) - (#x8B9F . #x8FDEE1) - (#x8C37 . #xC3AB) - (#x8C38 . #x8FDEE2) - (#x8C39 . #x8FDEE3) - (#x8C3A . #xECAE) - (#x8C3D . #x8FDEE4) - (#x8C3E . #x8FDEE5) - (#x8C3F . #xECB0) - (#x8C41 . #xECAF) - (#x8C45 . #x8FDEE6) - (#x8C46 . #xC6A6) - (#x8C47 . #x8FDEE7) - (#x8C48 . #xECB1) - (#x8C49 . #x8FDEE8) - (#x8C4A . #xCBAD) - (#x8C4B . #x8FDEE9) - (#x8C4C . #xECB2) - (#x8C4E . #xECB3) - (#x8C4F . #x8FDEEA) - (#x8C50 . #xECB4) - (#x8C51 . #x8FDEEB) - (#x8C53 . #x8FDEEC) - (#x8C54 . #x8FDEED) - (#x8C55 . #xECB5) - (#x8C57 . #x8FDEEE) - (#x8C58 . #x8FDEEF) - (#x8C59 . #x8FDEF2) - (#x8C5A . #xC6DA) - (#x8C5B . #x8FDEF0) - (#x8C5D . #x8FDEF1) - (#x8C61 . #xBEDD) - (#x8C62 . #xECB6) - (#x8C63 . #x8FDEF3) - (#x8C64 . #x8FDEF4) - (#x8C66 . #x8FDEF5) - (#x8C68 . #x8FDEF6) - (#x8C69 . #x8FDEF7) - (#x8C6A . #xB9EB) - (#x8C6B . #xD0AE) - (#x8C6C . #xECB7) - (#x8C6D . #x8FDEF8) - (#x8C73 . #x8FDEF9) - (#x8C75 . #x8FDEFA) - (#x8C76 . #x8FDEFB) - (#x8C78 . #xECB8) - (#x8C79 . #xC9BF) - (#x8C7A . #xECB9) - (#x8C7B . #x8FDEFC) - (#x8C7C . #xECC1) - (#x8C7E . #x8FDEFD) - (#x8C82 . #xECBA) - (#x8C85 . #xECBC) - (#x8C86 . #x8FDEFE) - (#x8C87 . #x8FDFA1) - (#x8C89 . #xECBB) - (#x8C8A . #xECBD) - (#x8C8B . #x8FDFA2) - (#x8C8C . #xCBC6) - (#x8C8D . #xECBE) - (#x8C8E . #xECBF) - (#x8C90 . #x8FDFA3) - (#x8C92 . #x8FDFA4) - (#x8C93 . #x8FDFA5) - (#x8C94 . #xECC0) - (#x8C98 . #xECC2) - (#x8C99 . #x8FDFA6) - (#x8C9B . #x8FDFA7) - (#x8C9C . #x8FDFA8) - (#x8C9D . #xB3AD) - (#x8C9E . #xC4E7) - (#x8CA0 . #xC9E9) - (#x8CA1 . #xBAE2) - (#x8CA2 . #xB9D7) - (#x8CA4 . #x8FDFA9) - (#x8CA7 . #xC9CF) - (#x8CA8 . #xB2DF) - (#x8CA9 . #xC8CE) - (#x8CAA . #xECC5) - (#x8CAB . #xB4D3) - (#x8CAC . #xC0D5) - (#x8CAD . #xECC4) - (#x8CAE . #xECC9) - (#x8CAF . #xC3F9) - (#x8CB0 . #xCCE3) - (#x8CB2 . #xECC7) - (#x8CB3 . #xECC8) - (#x8CB4 . #xB5AE) - (#x8CB6 . #xECCA) - (#x8CB7 . #xC7E3) - (#x8CB8 . #xC2DF) - (#x8CB9 . #x8FDFAA) - (#x8CBA . #x8FDFAB) - (#x8CBB . #xC8F1) - (#x8CBC . #xC5BD) - (#x8CBD . #xECC6) - (#x8CBF . #xCBC7) - (#x8CC0 . #xB2EC) - (#x8CC1 . #xECCC) - (#x8CC2 . #xCFA8) - (#x8CC3 . #xC4C2) - (#x8CC4 . #xCFC5) - (#x8CC5 . #x8FDFAC) - (#x8CC6 . #x8FDFAD) - (#x8CC7 . #xBBF1) - (#x8CC8 . #xECCB) - (#x8CC9 . #x8FDFAE) - (#x8CCA . #xC2B1) - (#x8CCB . #x8FDFAF) - (#x8CCD . #xECDC) - (#x8CCE . #xC1A8) - (#x8CCF . #x8FDFB0) - (#x8CD1 . #xC6F8) - (#x8CD3 . #xC9D0) - (#x8CD5 . #x8FDFB2) - (#x8CD6 . #x8FDFB1) - (#x8CD9 . #x8FDFB3) - (#x8CDA . #xECCF) - (#x8CDB . #xBBBF) - (#x8CDC . #xBBF2) - (#x8CDD . #x8FDFB4) - (#x8CDE . #xBEDE) - (#x8CE0 . #xC7E5) - (#x8CE1 . #x8FDFB5) - (#x8CE2 . #xB8AD) - (#x8CE3 . #xECCE) - (#x8CE4 . #xECCD) - (#x8CE6 . #xC9EA) - (#x8CE8 . #x8FDFB6) - (#x8CEA . #xBCC1) - (#x8CEC . #x8FDFB7) - (#x8CED . #xC5D2) - (#x8CEF . #x8FDFB8) - (#x8CF0 . #x8FDFB9) - (#x8CF2 . #x8FDFBA) - (#x8CF5 . #x8FDFBB) - (#x8CF7 . #x8FDFBC) - (#x8CF8 . #x8FDFBD) - (#x8CFA . #xECD1) - (#x8CFB . #xECD2) - (#x8CFC . #xB9D8) - (#x8CFD . #xECD0) - (#x8CFE . #x8FDFBE) - (#x8CFF . #x8FDFBF) - (#x8D01 . #x8FDFC0) - (#x8D03 . #x8FDFC1) - (#x8D04 . #xECD3) - (#x8D05 . #xECD4) - (#x8D07 . #xECD6) - (#x8D08 . #xC2A3) - (#x8D09 . #x8FDFC2) - (#x8D0A . #xECD5) - (#x8D0B . #xB4E6) - (#x8D0D . #xECD8) - (#x8D0F . #xECD7) - (#x8D10 . #xECD9) - (#x8D12 . #x8FDFC3) - (#x8D13 . #xECDB) - (#x8D14 . #xECDD) - (#x8D16 . #xECDE) - (#x8D17 . #x8FDFC4) - (#x8D1B . #x8FDFC5) - (#x8D64 . #xC0D6) - (#x8D65 . #x8FDFC6) - (#x8D66 . #xBCCF) - (#x8D67 . #xECDF) - (#x8D69 . #x8FDFC7) - (#x8D6B . #xB3D2) - (#x8D6C . #x8FDFC8) - (#x8D6D . #xECE0) - (#x8D6E . #x8FDFC9) - (#x8D70 . #xC1F6) - (#x8D71 . #xECE1) - (#x8D73 . #xECE2) - (#x8D74 . #xC9EB) - (#x8D77 . #xB5AF) - (#x8D7F . #x8FDFCA) - (#x8D81 . #xECE3) - (#x8D82 . #x8FDFCB) - (#x8D84 . #x8FDFCC) - (#x8D85 . #xC4B6) - (#x8D88 . #x8FDFCD) - (#x8D8A . #xB1DB) - (#x8D8D . #x8FDFCE) - (#x8D90 . #x8FDFCF) - (#x8D91 . #x8FDFD0) - (#x8D95 . #x8FDFD1) - (#x8D99 . #xECE4) - (#x8D9E . #x8FDFD2) - (#x8D9F . #x8FDFD3) - (#x8DA0 . #x8FDFD4) - (#x8DA3 . #xBCF1) - (#x8DA6 . #x8FDFD5) - (#x8DA8 . #xBFF6) - (#x8DAB . #x8FDFD6) - (#x8DAC . #x8FDFD7) - (#x8DAF . #x8FDFD8) - (#x8DB2 . #x8FDFD9) - (#x8DB3 . #xC2AD) - (#x8DB5 . #x8FDFDA) - (#x8DB7 . #x8FDFDB) - (#x8DB9 . #x8FDFDC) - (#x8DBA . #xECE7) - (#x8DBB . #x8FDFDD) - (#x8DBC . #x8FDFEF) - (#x8DBE . #xECE6) - (#x8DC0 . #x8FDFDE) - (#x8DC2 . #xECE5) - (#x8DC5 . #x8FDFDF) - (#x8DC6 . #x8FDFE0) - (#x8DC7 . #x8FDFE1) - (#x8DC8 . #x8FDFE2) - (#x8DCA . #x8FDFE3) - (#x8DCB . #xECED) - (#x8DCC . #xECEB) - (#x8DCE . #x8FDFE4) - (#x8DCF . #xECE8) - (#x8DD1 . #x8FDFE5) - (#x8DD4 . #x8FDFE6) - (#x8DD5 . #x8FDFE7) - (#x8DD6 . #xECEA) - (#x8DD7 . #x8FDFE8) - (#x8DD9 . #x8FDFE9) - (#x8DDA . #xECE9) - (#x8DDB . #xECEC) - (#x8DDD . #xB5F7) - (#x8DDF . #xECF0) - (#x8DE1 . #xC0D7) - (#x8DE3 . #xECF1) - (#x8DE4 . #x8FDFEA) - (#x8DE5 . #x8FDFEB) - (#x8DE7 . #x8FDFEC) - (#x8DE8 . #xB8D9) - (#x8DEA . #xECEE) - (#x8DEB . #xECEF) - (#x8DEC . #x8FDFED) - (#x8DEF . #xCFA9) - (#x8DF0 . #x8FDFEE) - (#x8DF1 . #x8FDFF0) - (#x8DF2 . #x8FDFF1) - (#x8DF3 . #xC4B7) - (#x8DF4 . #x8FDFF2) - (#x8DF5 . #xC1A9) - (#x8DFC . #xECF2) - (#x8DFD . #x8FDFF3) - (#x8DFF . #xECF5) - (#x8E01 . #x8FDFF4) - (#x8E04 . #x8FDFF5) - (#x8E05 . #x8FDFF6) - (#x8E06 . #x8FDFF7) - (#x8E08 . #xECF3) - (#x8E09 . #xECF4) - (#x8E0A . #xCDD9) - (#x8E0B . #x8FDFF8) - (#x8E0F . #xC6A7) - (#x8E10 . #xECF8) - (#x8E11 . #x8FDFF9) - (#x8E14 . #x8FDFFA) - (#x8E16 . #x8FDFFB) - (#x8E1D . #xECF6) - (#x8E1E . #xECF7) - (#x8E1F . #xECF9) - (#x8E20 . #x8FDFFC) - (#x8E21 . #x8FDFFD) - (#x8E22 . #x8FDFFE) - (#x8E23 . #x8FE0A1) - (#x8E26 . #x8FE0A2) - (#x8E27 . #x8FE0A3) - (#x8E2A . #xEDA9) - (#x8E30 . #xECFC) - (#x8E31 . #x8FE0A4) - (#x8E33 . #x8FE0A5) - (#x8E34 . #xECFD) - (#x8E35 . #xECFB) - (#x8E36 . #x8FE0A6) - (#x8E37 . #x8FE0A7) - (#x8E38 . #x8FE0A8) - (#x8E39 . #x8FE0A9) - (#x8E3D . #x8FE0AA) - (#x8E40 . #x8FE0AB) - (#x8E41 . #x8FE0AC) - (#x8E42 . #xECFA) - (#x8E44 . #xC4FD) - (#x8E47 . #xEDA1) - (#x8E48 . #xEDA5) - (#x8E49 . #xEDA2) - (#x8E4A . #xECFE) - (#x8E4B . #x8FE0AD) - (#x8E4C . #xEDA3) - (#x8E4D . #x8FE0AE) - (#x8E4E . #x8FE0AF) - (#x8E4F . #x8FE0B0) - (#x8E50 . #xEDA4) - (#x8E54 . #x8FE0B1) - (#x8E55 . #xEDAB) - (#x8E59 . #xEDA6) - (#x8E5B . #x8FE0B2) - (#x8E5C . #x8FE0B3) - (#x8E5D . #x8FE0B4) - (#x8E5E . #x8FE0B5) - (#x8E5F . #xC0D8) - (#x8E60 . #xEDA8) - (#x8E61 . #x8FE0B6) - (#x8E62 . #x8FE0B7) - (#x8E63 . #xEDAA) - (#x8E64 . #xEDA7) - (#x8E69 . #x8FE0B8) - (#x8E6C . #x8FE0B9) - (#x8E6D . #x8FE0BA) - (#x8E6F . #x8FE0BB) - (#x8E70 . #x8FE0BC) - (#x8E71 . #x8FE0BD) - (#x8E72 . #xEDAD) - (#x8E74 . #xBDB3) - (#x8E76 . #xEDAC) - (#x8E79 . #x8FE0BE) - (#x8E7A . #x8FE0BF) - (#x8E7B . #x8FE0C0) - (#x8E7C . #xEDAE) - (#x8E81 . #xEDAF) - (#x8E82 . #x8FE0C1) - (#x8E83 . #x8FE0C2) - (#x8E84 . #xEDB2) - (#x8E85 . #xEDB1) - (#x8E87 . #xEDB0) - (#x8E89 . #x8FE0C3) - (#x8E8A . #xEDB4) - (#x8E8B . #xEDB3) - (#x8E8D . #xCCF6) - (#x8E90 . #x8FE0C4) - (#x8E91 . #xEDB6) - (#x8E92 . #x8FE0C5) - (#x8E93 . #xEDB5) - (#x8E94 . #xEDB7) - (#x8E95 . #x8FE0C6) - (#x8E99 . #xEDB8) - (#x8E9A . #x8FE0C7) - (#x8E9B . #x8FE0C8) - (#x8E9D . #x8FE0C9) - (#x8E9E . #x8FE0CA) - (#x8EA1 . #xEDBA) - (#x8EA2 . #x8FE0CB) - (#x8EA7 . #x8FE0CC) - (#x8EA9 . #x8FE0CD) - (#x8EAA . #xEDB9) - (#x8EAB . #xBFC8) - (#x8EAC . #xEDBB) - (#x8EAD . #x8FE0CE) - (#x8EAE . #x8FE0CF) - (#x8EAF . #xB6ED) - (#x8EB0 . #xEDBC) - (#x8EB1 . #xEDBE) - (#x8EB3 . #x8FE0D0) - (#x8EB5 . #x8FE0D1) - (#x8EBA . #x8FE0D2) - (#x8EBB . #x8FE0D3) - (#x8EBE . #xEDBF) - (#x8EC0 . #x8FE0D4) - (#x8EC1 . #x8FE0D5) - (#x8EC3 . #x8FE0D6) - (#x8EC4 . #x8FE0D7) - (#x8EC5 . #xEDC0) - (#x8EC6 . #xEDBD) - (#x8EC7 . #x8FE0D8) - (#x8EC8 . #xEDC1) - (#x8ECA . #xBCD6) - (#x8ECB . #xEDC2) - (#x8ECC . #xB5B0) - (#x8ECD . #xB7B3) - (#x8ECF . #x8FE0D9) - (#x8ED1 . #x8FE0DA) - (#x8ED2 . #xB8AE) - (#x8ED4 . #x8FE0DB) - (#x8EDB . #xEDC3) - (#x8EDC . #x8FE0DC) - (#x8EDF . #xC6F0) - (#x8EE2 . #xC5BE) - (#x8EE3 . #xEDC4) - (#x8EE8 . #x8FE0DD) - (#x8EEB . #xEDC7) - (#x8EED . #x8FE0E4) - (#x8EEE . #x8FE0DE) - (#x8EF0 . #x8FE0DF) - (#x8EF1 . #x8FE0E0) - (#x8EF7 . #x8FE0E1) - (#x8EF8 . #xBCB4) - (#x8EF9 . #x8FE0E2) - (#x8EFA . #x8FE0E3) - (#x8EFB . #xEDC6) - (#x8EFC . #xEDC5) - (#x8EFD . #xB7DA) - (#x8EFE . #xEDC8) - (#x8F00 . #x8FE0E5) - (#x8F02 . #x8FE0E6) - (#x8F03 . #xB3D3) - (#x8F05 . #xEDCA) - (#x8F07 . #x8FE0E7) - (#x8F08 . #x8FE0E8) - (#x8F09 . #xBADC) - (#x8F0A . #xEDC9) - (#x8F0C . #xEDD2) - (#x8F0F . #x8FE0E9) - (#x8F10 . #x8FE0EA) - (#x8F12 . #xEDCC) - (#x8F13 . #xEDCE) - (#x8F14 . #xCAE5) - (#x8F15 . #xEDCB) - (#x8F16 . #x8FE0EB) - (#x8F17 . #x8FE0EC) - (#x8F18 . #x8FE0ED) - (#x8F19 . #xEDCD) - (#x8F1B . #xEDD1) - (#x8F1C . #xEDCF) - (#x8F1D . #xB5B1) - (#x8F1E . #x8FE0EE) - (#x8F1F . #xEDD0) - (#x8F20 . #x8FE0EF) - (#x8F21 . #x8FE0F0) - (#x8F23 . #x8FE0F1) - (#x8F25 . #x8FE0F2) - (#x8F26 . #xEDD3) - (#x8F27 . #x8FE0F3) - (#x8F28 . #x8FE0F4) - (#x8F29 . #xC7DA) - (#x8F2A . #xCED8) - (#x8F2C . #x8FE0F5) - (#x8F2D . #x8FE0F6) - (#x8F2E . #x8FE0F7) - (#x8F2F . #xBDB4) - (#x8F33 . #xEDD4) - (#x8F34 . #x8FE0F8) - (#x8F35 . #x8FE0F9) - (#x8F36 . #x8FE0FA) - (#x8F37 . #x8FE0FB) - (#x8F38 . #xCDA2) - (#x8F39 . #xEDD6) - (#x8F3A . #x8FE0FC) - (#x8F3B . #xEDD5) - (#x8F3E . #xEDD9) - (#x8F3F . #xCDC1) - (#x8F40 . #x8FE0FD) - (#x8F41 . #x8FE0FE) - (#x8F42 . #xEDD8) - (#x8F43 . #x8FE1A1) - (#x8F44 . #xB3ED) - (#x8F45 . #xEDD7) - (#x8F46 . #xEDDC) - (#x8F47 . #x8FE1A2) - (#x8F49 . #xEDDB) - (#x8F4C . #xEDDA) - (#x8F4D . #xC5B2) - (#x8F4E . #xEDDD) - (#x8F4F . #x8FE1A3) - (#x8F51 . #x8FE1A4) - (#x8F52 . #x8FE1A5) - (#x8F53 . #x8FE1A6) - (#x8F54 . #x8FE1A7) - (#x8F55 . #x8FE1A8) - (#x8F57 . #xEDDE) - (#x8F58 . #x8FE1A9) - (#x8F5C . #xEDDF) - (#x8F5D . #x8FE1AA) - (#x8F5E . #x8FE1AB) - (#x8F5F . #xB9EC) - (#x8F61 . #xB7A5) - (#x8F62 . #xEDE0) - (#x8F63 . #xEDE1) - (#x8F64 . #xEDE2) - (#x8F65 . #x8FE1AC) - (#x8F9B . #xBFC9) - (#x8F9C . #xEDE3) - (#x8F9D . #x8FE1AD) - (#x8F9E . #xBCAD) - (#x8F9F . #xEDE4) - (#x8FA0 . #x8FE1AE) - (#x8FA1 . #x8FE1AF) - (#x8FA3 . #xEDE5) - (#x8FA4 . #x8FE1B0) - (#x8FA5 . #x8FE1B1) - (#x8FA6 . #x8FE1B2) - (#x8FA7 . #xD2A1) - (#x8FA8 . #xD1FE) - (#x8FAD . #xEDE6) - (#x8FAE . #xE5F0) - (#x8FAF . #xEDE7) - (#x8FB0 . #xC3A4) - (#x8FB1 . #xBFAB) - (#x8FB2 . #xC7C0) - (#x8FB5 . #x8FE1B3) - (#x8FB6 . #x8FE1B4) - (#x8FB7 . #xEDE8) - (#x8FB8 . #x8FE1B5) - (#x8FBA . #xCAD5) - (#x8FBB . #xC4D4) - (#x8FBC . #xB9FE) - (#x8FBE . #x8FE1B6) - (#x8FBF . #xC3A9) - (#x8FC0 . #x8FE1B7) - (#x8FC1 . #x8FE1B8) - (#x8FC2 . #xB1AA) - (#x8FC4 . #xCBF8) - (#x8FC5 . #xBFD7) - (#x8FC6 . #x8FE1B9) - (#x8FCA . #x8FE1BA) - (#x8FCB . #x8FE1BB) - (#x8FCD . #x8FE1BC) - (#x8FCE . #xB7DE) - (#x8FD0 . #x8FE1BD) - (#x8FD1 . #xB6E1) - (#x8FD2 . #x8FE1BE) - (#x8FD3 . #x8FE1BF) - (#x8FD4 . #xCAD6) - (#x8FD5 . #x8FE1C0) - (#x8FDA . #xEDE9) - (#x8FE0 . #x8FE1C1) - (#x8FE2 . #xEDEB) - (#x8FE3 . #x8FE1C2) - (#x8FE4 . #x8FE1C3) - (#x8FE5 . #xEDEA) - (#x8FE6 . #xB2E0) - (#x8FE8 . #x8FE1C4) - (#x8FE9 . #xC6F6) - (#x8FEA . #xEDEC) - (#x8FEB . #xC7F7) - (#x8FED . #xC5B3) - (#x8FEE . #x8FE1C5) - (#x8FEF . #xEDED) - (#x8FF0 . #xBDD2) - (#x8FF1 . #x8FE1C6) - (#x8FF4 . #xEDEF) - (#x8FF5 . #x8FE1C7) - (#x8FF6 . #x8FE1C8) - (#x8FF7 . #xCCC2) - (#x8FF8 . #xEDFE) - (#x8FF9 . #xEDF1) - (#x8FFA . #xEDF2) - (#x8FFB . #x8FE1C9) - (#x8FFD . #xC4C9) - (#x8FFE . #x8FE1CA) - (#x9000 . #xC2E0) - (#x9001 . #xC1F7) - (#x9002 . #x8FE1CB) - (#x9003 . #xC6A8) - (#x9004 . #x8FE1CC) - (#x9005 . #xEDF0) - (#x9006 . #xB5D5) - (#x9008 . #x8FE1CD) - (#x900B . #xEDF9) - (#x900C . #x8FE1CE) - (#x900D . #xEDF6) - (#x900E . #xEEA5) - (#x900F . #xC6A9) - (#x9010 . #xC3E0) - (#x9011 . #xEDF3) - (#x9013 . #xC4FE) - (#x9014 . #xC5D3) - (#x9015 . #xEDF4) - (#x9016 . #xEDF8) - (#x9017 . #xBFE0) - (#x9018 . #x8FE1CF) - (#x9019 . #xC7E7) - (#x901A . #xC4CC) - (#x901B . #x8FE1D0) - (#x901D . #xC0C2) - (#x901E . #xEDF7) - (#x901F . #xC2AE) - (#x9020 . #xC2A4) - (#x9021 . #xEDF5) - (#x9022 . #xB0A9) - (#x9023 . #xCFA2) - (#x9027 . #xEDFA) - (#x9028 . #x8FE1D1) - (#x9029 . #x8FE1D2) - (#x902A . #x8FE1D4) - (#x902C . #x8FE1D5) - (#x902D . #x8FE1D6) - (#x902E . #xC2E1) - (#x902F . #x8FE1D3) - (#x9031 . #xBDB5) - (#x9032 . #xBFCA) - (#x9033 . #x8FE1D7) - (#x9034 . #x8FE1D8) - (#x9035 . #xEDFC) - (#x9036 . #xEDFB) - (#x9037 . #x8FE1D9) - (#x9038 . #xB0EF) - (#x9039 . #xEDFD) - (#x903C . #xC9AF) - (#x903E . #xEEA7) - (#x903F . #x8FE1DA) - (#x9041 . #xC6DB) - (#x9042 . #xBFEB) - (#x9043 . #x8FE1DB) - (#x9044 . #x8FE1DC) - (#x9045 . #xC3D9) - (#x9047 . #xB6F8) - (#x9049 . #xEEA6) - (#x904A . #xCDB7) - (#x904B . #xB1BF) - (#x904C . #x8FE1DD) - (#x904D . #xCAD7) - (#x904E . #xB2E1) - (#x904F . #xEEA1) - (#x9050 . #xEEA2) - (#x9051 . #xEEA3) - (#x9052 . #xEEA4) - (#x9053 . #xC6BB) - (#x9054 . #xC3A3) - (#x9055 . #xB0E3) - (#x9056 . #xEEA8) - (#x9058 . #xEEA9) - (#x9059 . #xF4A3) - (#x905B . #x8FE1DE) - (#x905C . #xC2BD) - (#x905D . #x8FE1DF) - (#x905E . #xEEAA) - (#x9060 . #xB1F3) - (#x9061 . #xC1CC) - (#x9062 . #x8FE1E0) - (#x9063 . #xB8AF) - (#x9065 . #xCDDA) - (#x9066 . #x8FE1E1) - (#x9067 . #x8FE1E2) - (#x9068 . #xEEAB) - (#x9069 . #xC5AC) - (#x906C . #x8FE1E3) - (#x906D . #xC1F8) - (#x906E . #xBCD7) - (#x906F . #xEEAC) - (#x9070 . #x8FE1E4) - (#x9072 . #xEEAF) - (#x9074 . #x8FE1E5) - (#x9075 . #xBDE5) - (#x9076 . #xEEAD) - (#x9077 . #xC1AB) - (#x9078 . #xC1AA) - (#x9079 . #x8FE1E6) - (#x907A . #xB0E4) - (#x907C . #xCECB) - (#x907D . #xEEB1) - (#x907F . #xC8F2) - (#x9080 . #xEEB3) - (#x9081 . #xEEB2) - (#x9082 . #xEEB0) - (#x9083 . #xE3E4) - (#x9084 . #xB4D4) - (#x9085 . #x8FE1E7) - (#x9087 . #xEDEE) - (#x9088 . #x8FE1E8) - (#x9089 . #xEEB5) - (#x908A . #xEEB4) - (#x908B . #x8FE1E9) - (#x908C . #x8FE1EA) - (#x908E . #x8FE1EB) - (#x908F . #xEEB6) - (#x9090 . #x8FE1EC) - (#x9091 . #xCDB8) - (#x9095 . #x8FE1ED) - (#x9097 . #x8FE1EE) - (#x9098 . #x8FE1EF) - (#x9099 . #x8FE1F0) - (#x909B . #x8FE1F1) - (#x90A0 . #x8FE1F2) - (#x90A1 . #x8FE1F3) - (#x90A2 . #x8FE1F4) - (#x90A3 . #xC6E1) - (#x90A5 . #x8FE1F5) - (#x90A6 . #xCBAE) - (#x90A8 . #xEEB7) - (#x90AA . #xBCD9) - (#x90AF . #xEEB8) - (#x90B0 . #x8FE1F6) - (#x90B1 . #xEEB9) - (#x90B2 . #x8FE1F7) - (#x90B3 . #x8FE1F8) - (#x90B4 . #x8FE1F9) - (#x90B5 . #xEEBA) - (#x90B6 . #x8FE1FA) - (#x90B8 . #xC5A1) - (#x90BD . #x8FE1FB) - (#x90BE . #x8FE1FD) - (#x90C1 . #xB0EA) - (#x90C3 . #x8FE1FE) - (#x90C4 . #x8FE2A1) - (#x90C5 . #x8FE2A2) - (#x90C7 . #x8FE2A3) - (#x90C8 . #x8FE2A4) - (#x90CA . #xB9D9) - (#x90CC . #x8FE1FC) - (#x90CE . #xCFBA) - (#x90D2 . #x8FE2AD) - (#x90D5 . #x8FE2A5) - (#x90D7 . #x8FE2A6) - (#x90D8 . #x8FE2A7) - (#x90D9 . #x8FE2A8) - (#x90DB . #xEEBE) - (#x90DC . #x8FE2A9) - (#x90DD . #x8FE2AA) - (#x90DF . #x8FE2AB) - (#x90E1 . #xB7B4) - (#x90E2 . #xEEBB) - (#x90E4 . #xEEBC) - (#x90E5 . #x8FE2AC) - (#x90E8 . #xC9F4) - (#x90EB . #x8FE2AF) - (#x90ED . #xB3D4) - (#x90EF . #x8FE2B0) - (#x90F0 . #x8FE2B1) - (#x90F4 . #x8FE2B2) - (#x90F5 . #xCDB9) - (#x90F6 . #x8FE2AE) - (#x90F7 . #xB6BF) - (#x90FD . #xC5D4) - (#x90FE . #x8FE2B3) - (#x90FF . #x8FE2B4) - (#x9100 . #x8FE2B5) - (#x9102 . #xEEBF) - (#x9104 . #x8FE2B6) - (#x9105 . #x8FE2B7) - (#x9106 . #x8FE2B8) - (#x9108 . #x8FE2B9) - (#x910D . #x8FE2BA) - (#x9110 . #x8FE2BB) - (#x9112 . #xEEC0) - (#x9114 . #x8FE2BC) - (#x9116 . #x8FE2BD) - (#x9117 . #x8FE2BE) - (#x9118 . #x8FE2BF) - (#x9119 . #xEEC1) - (#x911A . #x8FE2C0) - (#x911C . #x8FE2C1) - (#x911E . #x8FE2C2) - (#x9120 . #x8FE2C3) - (#x9122 . #x8FE2C5) - (#x9123 . #x8FE2C6) - (#x9125 . #x8FE2C4) - (#x9127 . #x8FE2C7) - (#x9129 . #x8FE2C8) - (#x912D . #xC5A2) - (#x912E . #x8FE2C9) - (#x912F . #x8FE2CA) - (#x9130 . #xEEC3) - (#x9131 . #x8FE2CB) - (#x9132 . #xEEC2) - (#x9134 . #x8FE2CC) - (#x9136 . #x8FE2CD) - (#x9137 . #x8FE2CE) - (#x9139 . #x8FE2CF) - (#x913A . #x8FE2D0) - (#x913C . #x8FE2D1) - (#x913D . #x8FE2D2) - (#x9143 . #x8FE2D3) - (#x9147 . #x8FE2D4) - (#x9148 . #x8FE2D5) - (#x9149 . #xC6D3) - (#x914A . #xEEC4) - (#x914B . #xBDB6) - (#x914C . #xBCE0) - (#x914D . #xC7DB) - (#x914E . #xC3F1) - (#x914F . #x8FE2D6) - (#x9152 . #xBCF2) - (#x9153 . #x8FE2D7) - (#x9154 . #xBFEC) - (#x9156 . #xEEC5) - (#x9157 . #x8FE2D8) - (#x9158 . #xEEC6) - (#x9159 . #x8FE2D9) - (#x915A . #x8FE2DA) - (#x915B . #x8FE2DB) - (#x9161 . #x8FE2DC) - (#x9162 . #xBFDD) - (#x9163 . #xEEC7) - (#x9164 . #x8FE2DD) - (#x9165 . #xEEC8) - (#x9167 . #x8FE2DE) - (#x9169 . #xEEC9) - (#x916A . #xCDEF) - (#x916C . #xBDB7) - (#x916D . #x8FE2DF) - (#x9172 . #xEECB) - (#x9173 . #xEECA) - (#x9174 . #x8FE2E0) - (#x9175 . #xB9DA) - (#x9177 . #xB9F3) - (#x9178 . #xBBC0) - (#x9179 . #x8FE2E1) - (#x917A . #x8FE2E2) - (#x917B . #x8FE2E3) - (#x9181 . #x8FE2E4) - (#x9182 . #xEECE) - (#x9183 . #x8FE2E5) - (#x9185 . #x8FE2E6) - (#x9186 . #x8FE2E7) - (#x9187 . #xBDE6) - (#x9189 . #xEECD) - (#x918A . #x8FE2E8) - (#x918B . #xEECC) - (#x918D . #xC2E9) - (#x918E . #x8FE2E9) - (#x9190 . #xB8EF) - (#x9191 . #x8FE2EA) - (#x9192 . #xC0C3) - (#x9193 . #x8FE2EB) - (#x9194 . #x8FE2EC) - (#x9195 . #x8FE2ED) - (#x9197 . #xC8B0) - (#x9198 . #x8FE2EE) - (#x919C . #xBDB9) - (#x919E . #x8FE2EF) - (#x91A1 . #x8FE2F0) - (#x91A2 . #xEECF) - (#x91A4 . #xBEDF) - (#x91A6 . #x8FE2F1) - (#x91A8 . #x8FE2F2) - (#x91AA . #xEED2) - (#x91AB . #xEED0) - (#x91AC . #x8FE2F3) - (#x91AD . #x8FE2F4) - (#x91AE . #x8FE2F5) - (#x91AF . #xEED1) - (#x91B0 . #x8FE2F6) - (#x91B1 . #x8FE2F7) - (#x91B2 . #x8FE2F8) - (#x91B3 . #x8FE2F9) - (#x91B4 . #xEED4) - (#x91B5 . #xEED3) - (#x91B6 . #x8FE2FA) - (#x91B8 . #xBEFA) - (#x91BA . #xEED5) - (#x91BB . #x8FE2FB) - (#x91BC . #x8FE2FC) - (#x91BD . #x8FE2FD) - (#x91BF . #x8FE2FE) - (#x91C0 . #xEED6) - (#x91C1 . #xEED7) - (#x91C2 . #x8FE3A1) - (#x91C3 . #x8FE3A2) - (#x91C5 . #x8FE3A3) - (#x91C6 . #xC8D0) - (#x91C7 . #xBAD3) - (#x91C8 . #xBCE1) - (#x91C9 . #xEED8) - (#x91CB . #xEED9) - (#x91CC . #xCEA4) - (#x91CD . #xBDC5) - (#x91CE . #xCCEE) - (#x91CF . #xCECC) - (#x91D0 . #xEEDA) - (#x91D1 . #xB6E2) - (#x91D3 . #x8FE3A4) - (#x91D4 . #x8FE3A5) - (#x91D6 . #xEEDB) - (#x91D7 . #x8FE3A6) - (#x91D8 . #xC5A3) - (#x91D9 . #x8FE3A7) - (#x91DA . #x8FE3A8) - (#x91DB . #xEEDE) - (#x91DC . #xB3F8) - (#x91DD . #xBFCB) - (#x91DE . #x8FE3A9) - (#x91DF . #xEEDC) - (#x91E1 . #xEEDD) - (#x91E3 . #xC4E0) - (#x91E4 . #x8FE3AA) - (#x91E5 . #x8FE3AB) - (#x91E6 . #xCBD5) - (#x91E7 . #xB6FC) - (#x91E9 . #x8FE3AC) - (#x91EA . #x8FE3AD) - (#x91EC . #x8FE3AE) - (#x91ED . #x8FE3AF) - (#x91EE . #x8FE3B0) - (#x91EF . #x8FE3B1) - (#x91F0 . #x8FE3B2) - (#x91F1 . #x8FE3B3) - (#x91F5 . #xEEE0) - (#x91F6 . #xEEE1) - (#x91F7 . #x8FE3B4) - (#x91F9 . #x8FE3B5) - (#x91FB . #x8FE3B6) - (#x91FC . #xEEDF) - (#x91FD . #x8FE3B7) - (#x91FF . #xEEE3) - (#x9200 . #x8FE3B8) - (#x9201 . #x8FE3B9) - (#x9204 . #x8FE3BA) - (#x9205 . #x8FE3BB) - (#x9206 . #x8FE3BC) - (#x9207 . #x8FE3BD) - (#x9209 . #x8FE3BE) - (#x920A . #x8FE3BF) - (#x920C . #x8FE3C0) - (#x920D . #xC6DF) - (#x920E . #xB3C3) - (#x9210 . #x8FE3C1) - (#x9211 . #xEEE7) - (#x9212 . #x8FE3C2) - (#x9213 . #x8FE3C3) - (#x9214 . #xEEE4) - (#x9215 . #xEEE6) - (#x9216 . #x8FE3C4) - (#x9218 . #x8FE3C5) - (#x921C . #x8FE3C6) - (#x921D . #x8FE3C7) - (#x921E . #xEEE2) - (#x9223 . #x8FE3C8) - (#x9224 . #x8FE3C9) - (#x9225 . #x8FE3CA) - (#x9226 . #x8FE3CB) - (#x9228 . #x8FE3CC) - (#x9229 . #xEFCF) - (#x922C . #xEEE5) - (#x922E . #x8FE3CD) - (#x922F . #x8FE3CE) - (#x9230 . #x8FE3CF) - (#x9233 . #x8FE3D0) - (#x9234 . #xCEEB) - (#x9235 . #x8FE3D1) - (#x9236 . #x8FE3D2) - (#x9237 . #xB8DA) - (#x9238 . #x8FE3D3) - (#x9239 . #x8FE3D4) - (#x923A . #x8FE3D5) - (#x923C . #x8FE3D6) - (#x923E . #x8FE3D7) - (#x923F . #xEEEF) - (#x9240 . #x8FE3D8) - (#x9242 . #x8FE3D9) - (#x9243 . #x8FE3DA) - (#x9244 . #xC5B4) - (#x9245 . #xEEEA) - (#x9246 . #x8FE3DB) - (#x9247 . #x8FE3DC) - (#x9248 . #xEEED) - (#x9249 . #xEEEB) - (#x924A . #x8FE3DD) - (#x924B . #xEEF0) - (#x924D . #x8FE3DE) - (#x924E . #x8FE3DF) - (#x924F . #x8FE3E0) - (#x9250 . #xEEF1) - (#x9251 . #x8FE3E1) - (#x9257 . #xEEE9) - (#x9258 . #x8FE3E2) - (#x9259 . #x8FE3E3) - (#x925A . #xEEF6) - (#x925B . #xB1F4) - (#x925C . #x8FE3E4) - (#x925D . #x8FE3E5) - (#x925E . #xEEE8) - (#x9260 . #x8FE3E6) - (#x9261 . #x8FE3E7) - (#x9262 . #xC8AD) - (#x9264 . #xEEEC) - (#x9265 . #x8FE3E8) - (#x9266 . #xBEE0) - (#x9267 . #x8FE3E9) - (#x9268 . #x8FE3EA) - (#x9269 . #x8FE3EB) - (#x926E . #x8FE3EC) - (#x926F . #x8FE3ED) - (#x9270 . #x8FE3EE) - (#x9271 . #xB9DB) - (#x9275 . #x8FE3EF) - (#x9276 . #x8FE3F0) - (#x9277 . #x8FE3F1) - (#x9278 . #x8FE3F2) - (#x9279 . #x8FE3F3) - (#x927B . #x8FE3F4) - (#x927C . #x8FE3F5) - (#x927D . #x8FE3F6) - (#x927E . #xCBC8) - (#x927F . #x8FE3F7) - (#x9280 . #xB6E4) - (#x9283 . #xBDC6) - (#x9285 . #xC6BC) - (#x9288 . #x8FE3F8) - (#x9289 . #x8FE3F9) - (#x928A . #x8FE3FA) - (#x928D . #x8FE3FB) - (#x928E . #x8FE3FC) - (#x9291 . #xC1AD) - (#x9292 . #x8FE3FD) - (#x9293 . #xEEF4) - (#x9295 . #xEEEE) - (#x9296 . #xEEF3) - (#x9297 . #x8FE3FE) - (#x9298 . #xCCC3) - (#x9299 . #x8FE4A1) - (#x929A . #xC4B8) - (#x929B . #xEEF5) - (#x929C . #xEEF2) - (#x929F . #x8FE4A2) - (#x92A0 . #x8FE4A3) - (#x92A4 . #x8FE4A4) - (#x92A5 . #x8FE4A5) - (#x92A7 . #x8FE4A6) - (#x92A8 . #x8FE4A7) - (#x92AB . #x8FE4A8) - (#x92AD . #xC1AC) - (#x92AF . #x8FE4A9) - (#x92B2 . #x8FE4AA) - (#x92B6 . #x8FE4AB) - (#x92B7 . #xEEF9) - (#x92B8 . #x8FE4AC) - (#x92B9 . #xEEF8) - (#x92BA . #x8FE4AD) - (#x92BB . #x8FE4AE) - (#x92BC . #x8FE4AF) - (#x92BD . #x8FE4B0) - (#x92BF . #x8FE4B1) - (#x92C0 . #x8FE4B2) - (#x92C1 . #x8FE4B3) - (#x92C2 . #x8FE4B4) - (#x92C3 . #x8FE4B5) - (#x92C5 . #x8FE4B6) - (#x92C6 . #x8FE4B7) - (#x92C7 . #x8FE4B8) - (#x92C8 . #x8FE4B9) - (#x92CB . #x8FE4BA) - (#x92CC . #x8FE4BB) - (#x92CD . #x8FE4BC) - (#x92CE . #x8FE4BD) - (#x92CF . #xEEF7) - (#x92D0 . #x8FE4BE) - (#x92D2 . #xCBAF) - (#x92D3 . #x8FE4BF) - (#x92D5 . #x8FE4C0) - (#x92D7 . #x8FE4C1) - (#x92D8 . #x8FE4C2) - (#x92D9 . #x8FE4C3) - (#x92DC . #x8FE4C4) - (#x92DD . #x8FE4C5) - (#x92DF . #x8FE4C6) - (#x92E0 . #x8FE4C7) - (#x92E1 . #x8FE4C8) - (#x92E3 . #x8FE4C9) - (#x92E4 . #xBDFB) - (#x92E5 . #x8FE4CA) - (#x92E7 . #x8FE4CB) - (#x92E8 . #x8FE4CC) - (#x92E9 . #xEEFA) - (#x92EA . #xCADF) - (#x92EC . #x8FE4CD) - (#x92ED . #xB1D4) - (#x92EE . #x8FE4CE) - (#x92F0 . #x8FE4CF) - (#x92F2 . #xC9C6) - (#x92F3 . #xC3F2) - (#x92F8 . #xB5F8) - (#x92F9 . #x8FE4D0) - (#x92FA . #xEEFC) - (#x92FB . #x8FE4D1) - (#x92FC . #xB9DD) - (#x92FF . #x8FE4D2) - (#x9300 . #x8FE4D3) - (#x9302 . #x8FE4D4) - (#x9306 . #xBBAC) - (#x9308 . #x8FE4D5) - (#x930D . #x8FE4D6) - (#x930F . #xEEFB) - (#x9310 . #xBFED) - (#x9311 . #x8FE4D7) - (#x9314 . #x8FE4D8) - (#x9315 . #x8FE4D9) - (#x9318 . #xBFEE) - (#x9319 . #xEFA1) - (#x931A . #xEFA3) - (#x931C . #x8FE4DA) - (#x931D . #x8FE4DB) - (#x931E . #x8FE4DC) - (#x931F . #x8FE4DD) - (#x9320 . #xBEFB) - (#x9321 . #x8FE4DE) - (#x9322 . #xEFA2) - (#x9323 . #xEFA4) - (#x9324 . #x8FE4DF) - (#x9325 . #x8FE4E0) - (#x9326 . #xB6D3) - (#x9327 . #x8FE4E1) - (#x9328 . #xC9C5) - (#x9329 . #x8FE4E2) - (#x932A . #x8FE4E3) - (#x932B . #xBCE2) - (#x932C . #xCFA3) - (#x932E . #xEEFE) - (#x932F . #xBAF8) - (#x9332 . #xCFBF) - (#x9333 . #x8FE4E4) - (#x9334 . #x8FE4E5) - (#x9335 . #xEFA6) - (#x9336 . #x8FE4E6) - (#x9337 . #x8FE4E7) - (#x933A . #xEFA5) - (#x933B . #xEFA7) - (#x9344 . #xEEFD) - (#x9347 . #x8FE4E8) - (#x9348 . #x8FE4E9) - (#x9349 . #x8FE4EA) - (#x934B . #xC6E9) - (#x934D . #xC5D5) - (#x9350 . #x8FE4EB) - (#x9351 . #x8FE4EC) - (#x9352 . #x8FE4ED) - (#x9354 . #xC4D7) - (#x9355 . #x8FE4EE) - (#x9356 . #xEFAC) - (#x9357 . #x8FE4EF) - (#x9358 . #x8FE4F0) - (#x935A . #x8FE4F1) - (#x935B . #xC3C3) - (#x935C . #xEFA8) - (#x935E . #x8FE4F2) - (#x9360 . #xEFA9) - (#x9364 . #x8FE4F3) - (#x9365 . #x8FE4F4) - (#x9367 . #x8FE4F5) - (#x9369 . #x8FE4F6) - (#x936A . #x8FE4F7) - (#x936C . #xB7AD) - (#x936D . #x8FE4F8) - (#x936E . #xEFAB) - (#x936F . #x8FE4F9) - (#x9370 . #x8FE4FA) - (#x9371 . #x8FE4FB) - (#x9373 . #x8FE4FC) - (#x9374 . #x8FE4FD) - (#x9375 . #xB8B0) - (#x9376 . #x8FE4FE) - (#x937A . #x8FE5A1) - (#x937C . #xEFAA) - (#x937D . #x8FE5A2) - (#x937E . #xBEE1) - (#x937F . #x8FE5A3) - (#x9380 . #x8FE5A4) - (#x9381 . #x8FE5A5) - (#x9382 . #x8FE5A6) - (#x9388 . #x8FE5A7) - (#x938A . #x8FE5A8) - (#x938B . #x8FE5A9) - (#x938C . #xB3F9) - (#x938D . #x8FE5AA) - (#x938F . #x8FE5AB) - (#x9392 . #x8FE5AC) - (#x9394 . #xEFB0) - (#x9395 . #x8FE5AD) - (#x9396 . #xBABF) - (#x9397 . #xC1F9) - (#x9398 . #x8FE5AE) - (#x939A . #xC4CA) - (#x939B . #x8FE5AF) - (#x939E . #x8FE5B0) - (#x93A1 . #x8FE5B1) - (#x93A3 . #x8FE5B2) - (#x93A4 . #x8FE5B3) - (#x93A6 . #x8FE5B4) - (#x93A7 . #xB3BB) - (#x93A8 . #x8FE5B5) - (#x93A9 . #x8FE5BB) - (#x93AB . #x8FE5B6) - (#x93AC . #xEFAE) - (#x93AD . #xEFAF) - (#x93AE . #xC4C3) - (#x93B0 . #xEFAD) - (#x93B4 . #x8FE5B7) - (#x93B5 . #x8FE5B8) - (#x93B6 . #x8FE5B9) - (#x93B9 . #xEFB1) - (#x93BA . #x8FE5BA) - (#x93C1 . #x8FE5BC) - (#x93C3 . #xEFB7) - (#x93C4 . #x8FE5BD) - (#x93C5 . #x8FE5BE) - (#x93C6 . #x8FE5BF) - (#x93C7 . #x8FE5C0) - (#x93C8 . #xEFBA) - (#x93C9 . #x8FE5C1) - (#x93CA . #x8FE5C2) - (#x93CB . #x8FE5C3) - (#x93CC . #x8FE5C4) - (#x93CD . #x8FE5C5) - (#x93D0 . #xEFB9) - (#x93D1 . #xC5AD) - (#x93D3 . #x8FE5C6) - (#x93D6 . #xEFB2) - (#x93D7 . #xEFB3) - (#x93D8 . #xEFB6) - (#x93D9 . #x8FE5C7) - (#x93DC . #x8FE5C8) - (#x93DD . #xEFB8) - (#x93DE . #x8FE5C9) - (#x93DF . #x8FE5CA) - (#x93E1 . #xB6C0) - (#x93E2 . #x8FE5CB) - (#x93E4 . #xEFBB) - (#x93E5 . #xEFB5) - (#x93E6 . #x8FE5CC) - (#x93E7 . #x8FE5CD) - (#x93E8 . #xEFB4) - (#x93F7 . #x8FE5CF) - (#x93F8 . #x8FE5D0) - (#x93F9 . #x8FE5CE) - (#x93FA . #x8FE5D1) - (#x93FB . #x8FE5D2) - (#x93FD . #x8FE5D3) - (#x9401 . #x8FE5D4) - (#x9402 . #x8FE5D5) - (#x9403 . #xEFBF) - (#x9404 . #x8FE5D6) - (#x9407 . #xEFC0) - (#x9408 . #x8FE5D7) - (#x9409 . #x8FE5D8) - (#x940D . #x8FE5D9) - (#x940E . #x8FE5DA) - (#x940F . #x8FE5DB) - (#x9410 . #xEFC1) - (#x9413 . #xEFBE) - (#x9414 . #xEFBD) - (#x9415 . #x8FE5DC) - (#x9416 . #x8FE5DD) - (#x9417 . #x8FE5DE) - (#x9418 . #xBEE2) - (#x9419 . #xC6AA) - (#x941A . #xEFBC) - (#x941F . #x8FE5DF) - (#x9421 . #xEFC5) - (#x942B . #xEFC3) - (#x942E . #x8FE5E0) - (#x942F . #x8FE5E1) - (#x9431 . #x8FE5E2) - (#x9432 . #x8FE5E3) - (#x9433 . #x8FE5E4) - (#x9434 . #x8FE5E5) - (#x9435 . #xEFC4) - (#x9436 . #xEFC2) - (#x9438 . #xC2F8) - (#x943A . #xEFC6) - (#x943B . #x8FE5E6) - (#x943D . #x8FE5E8) - (#x943F . #x8FE5E7) - (#x9441 . #xEFC7) - (#x9443 . #x8FE5E9) - (#x9444 . #xEFC9) - (#x9445 . #x8FE5EA) - (#x9448 . #x8FE5EB) - (#x944A . #x8FE5EC) - (#x944C . #x8FE5ED) - (#x9451 . #xB4D5) - (#x9452 . #xEFC8) - (#x9453 . #xCCFA) - (#x9455 . #x8FE5EE) - (#x9459 . #x8FE5EF) - (#x945A . #xEFD4) - (#x945B . #xEFCA) - (#x945C . #x8FE5F0) - (#x945E . #xEFCD) - (#x945F . #x8FE5F1) - (#x9460 . #xEFCB) - (#x9461 . #x8FE5F2) - (#x9462 . #xEFCC) - (#x9463 . #x8FE5F3) - (#x9468 . #x8FE5F4) - (#x946A . #xEFCE) - (#x946B . #x8FE5F5) - (#x946D . #x8FE5F6) - (#x946E . #x8FE5F7) - (#x946F . #x8FE5F8) - (#x9470 . #xEFD0) - (#x9471 . #x8FE5F9) - (#x9472 . #x8FE5FA) - (#x9475 . #xEFD1) - (#x9477 . #xEFD2) - (#x947C . #xEFD5) - (#x947D . #xEFD3) - (#x947E . #xEFD6) - (#x947F . #xEFD8) - (#x9481 . #xEFD7) - (#x9483 . #x8FE5FC) - (#x9484 . #x8FE5FB) - (#x9577 . #xC4B9) - (#x9578 . #x8FE5FD) - (#x9579 . #x8FE5FE) - (#x957E . #x8FE6A1) - (#x9580 . #xCCE7) - (#x9582 . #xEFD9) - (#x9583 . #xC1AE) - (#x9584 . #x8FE6A2) - (#x9587 . #xEFDA) - (#x9588 . #x8FE6A3) - (#x9589 . #xCAC4) - (#x958A . #xEFDB) - (#x958B . #xB3AB) - (#x958C . #x8FE6A4) - (#x958D . #x8FE6A5) - (#x958E . #x8FE6A6) - (#x958F . #xB1BC) - (#x9591 . #xB4D7) - (#x9593 . #xB4D6) - (#x9594 . #xEFDC) - (#x9596 . #xEFDD) - (#x9598 . #xEFDE) - (#x9599 . #xEFDF) - (#x959D . #x8FE6A7) - (#x959E . #x8FE6A8) - (#x959F . #x8FE6A9) - (#x95A0 . #xEFE0) - (#x95A1 . #x8FE6AA) - (#x95A2 . #xB4D8) - (#x95A3 . #xB3D5) - (#x95A4 . #xB9DE) - (#x95A5 . #xC8B6) - (#x95A6 . #x8FE6AB) - (#x95A7 . #xEFE2) - (#x95A8 . #xEFE1) - (#x95A9 . #x8FE6AC) - (#x95AB . #x8FE6AD) - (#x95AC . #x8FE6AE) - (#x95AD . #xEFE3) - (#x95B2 . #xB1DC) - (#x95B4 . #x8FE6AF) - (#x95B6 . #x8FE6B0) - (#x95B9 . #xEFE6) - (#x95BA . #x8FE6B1) - (#x95BB . #xEFE5) - (#x95BC . #xEFE4) - (#x95BD . #x8FE6B2) - (#x95BE . #xEFE7) - (#x95BF . #x8FE6B3) - (#x95C3 . #xEFEA) - (#x95C6 . #x8FE6B4) - (#x95C7 . #xB0C7) - (#x95C8 . #x8FE6B5) - (#x95C9 . #x8FE6B6) - (#x95CA . #xEFE8) - (#x95CB . #x8FE6B7) - (#x95CC . #xEFEC) - (#x95CD . #xEFEB) - (#x95D0 . #x8FE6B8) - (#x95D1 . #x8FE6B9) - (#x95D2 . #x8FE6BA) - (#x95D3 . #x8FE6BB) - (#x95D4 . #xEFEE) - (#x95D5 . #xEFED) - (#x95D6 . #xEFEF) - (#x95D8 . #xC6AE) - (#x95D9 . #x8FE6BC) - (#x95DA . #x8FE6BD) - (#x95DC . #xEFF0) - (#x95DD . #x8FE6BE) - (#x95DE . #x8FE6BF) - (#x95DF . #x8FE6C0) - (#x95E0 . #x8FE6C1) - (#x95E1 . #xEFF1) - (#x95E2 . #xEFF3) - (#x95E4 . #x8FE6C2) - (#x95E5 . #xEFF2) - (#x95E6 . #x8FE6C3) - (#x961C . #xC9EC) - (#x961D . #x8FE6C4) - (#x961E . #x8FE6C5) - (#x9621 . #xEFF4) - (#x9622 . #x8FE6C6) - (#x9624 . #x8FE6C7) - (#x9625 . #x8FE6C8) - (#x9626 . #x8FE6C9) - (#x9628 . #xEFF5) - (#x962A . #xBAE5) - (#x962C . #x8FE6CA) - (#x962E . #xEFF6) - (#x962F . #xEFF7) - (#x9631 . #x8FE6CB) - (#x9632 . #xCBC9) - (#x9633 . #x8FE6CC) - (#x9637 . #x8FE6CD) - (#x9638 . #x8FE6CE) - (#x9639 . #x8FE6CF) - (#x963A . #x8FE6D0) - (#x963B . #xC1CB) - (#x963C . #x8FE6D1) - (#x963D . #x8FE6D2) - (#x963F . #xB0A4) - (#x9640 . #xC2CB) - (#x9641 . #x8FE6D3) - (#x9642 . #xEFF8) - (#x9644 . #xC9ED) - (#x964B . #xEFFB) - (#x964C . #xEFF9) - (#x964D . #xB9DF) - (#x964F . #xEFFA) - (#x9650 . #xB8C2) - (#x9652 . #x8FE6D4) - (#x9654 . #x8FE6D5) - (#x9656 . #x8FE6D6) - (#x9657 . #x8FE6D7) - (#x9658 . #x8FE6D8) - (#x965B . #xCAC5) - (#x965C . #xEFFD) - (#x965D . #xF0A1) - (#x965E . #xEFFE) - (#x965F . #xF0A2) - (#x9661 . #x8FE6D9) - (#x9662 . #xB1A1) - (#x9663 . #xBFD8) - (#x9664 . #xBDFC) - (#x9665 . #xB4D9) - (#x9666 . #xF0A3) - (#x966A . #xC7E6) - (#x966C . #xF0A5) - (#x966E . #x8FE6DA) - (#x9670 . #xB1A2) - (#x9672 . #xF0A4) - (#x9673 . #xC4C4) - (#x9674 . #x8FE6DB) - (#x9675 . #xCECD) - (#x9676 . #xC6AB) - (#x9677 . #xEFFC) - (#x9678 . #xCEA6) - (#x967A . #xB8B1) - (#x967B . #x8FE6DC) - (#x967C . #x8FE6DD) - (#x967D . #xCDDB) - (#x967E . #x8FE6DE) - (#x967F . #x8FE6DF) - (#x9681 . #x8FE6E0) - (#x9682 . #x8FE6E1) - (#x9683 . #x8FE6E2) - (#x9684 . #x8FE6E3) - (#x9685 . #xB6F9) - (#x9686 . #xCEB4) - (#x9688 . #xB7A8) - (#x9689 . #x8FE6E4) - (#x968A . #xC2E2) - (#x968B . #xE7A1) - (#x968D . #xF0A6) - (#x968E . #xB3AC) - (#x968F . #xBFEF) - (#x9691 . #x8FE6E5) - (#x9694 . #xB3D6) - (#x9695 . #xF0A8) - (#x9696 . #x8FE6E6) - (#x9697 . #xF0A9) - (#x9698 . #xF0A7) - (#x9699 . #xB7E4) - (#x969A . #x8FE6E7) - (#x969B . #xBADD) - (#x969C . #xBEE3) - (#x969D . #x8FE6E8) - (#x969F . #x8FE6E9) - (#x96A0 . #xB1A3) - (#x96A3 . #xCED9) - (#x96A4 . #x8FE6EA) - (#x96A5 . #x8FE6EB) - (#x96A6 . #x8FE6EC) - (#x96A7 . #xF0AB) - (#x96A8 . #xEEAE) - (#x96A9 . #x8FE6ED) - (#x96AA . #xF0AA) - (#x96AE . #x8FE6EE) - (#x96AF . #x8FE6EF) - (#x96B0 . #xF0AE) - (#x96B1 . #xF0AC) - (#x96B2 . #xF0AD) - (#x96B3 . #x8FE6F0) - (#x96B4 . #xF0AF) - (#x96B6 . #xF0B0) - (#x96B7 . #xCEEC) - (#x96B8 . #xF0B1) - (#x96B9 . #xF0B2) - (#x96BA . #x8FE6F1) - (#x96BB . #xC0C9) - (#x96BC . #xC8BB) - (#x96C0 . #xBFFD) - (#x96C1 . #xB4E7) - (#x96C4 . #xCDBA) - (#x96C5 . #xB2ED) - (#x96C6 . #xBDB8) - (#x96C7 . #xB8DB) - (#x96C9 . #xF0B5) - (#x96CA . #x8FE6F2) - (#x96CB . #xF0B4) - (#x96CC . #xBBF3) - (#x96CD . #xF0B6) - (#x96CE . #xF0B3) - (#x96D1 . #xBBA8) - (#x96D2 . #x8FE6F3) - (#x96D5 . #xF0BA) - (#x96D6 . #xEAAD) - (#x96D8 . #x8FE6F5) - (#x96D9 . #xD2D6) - (#x96DA . #x8FE6F6) - (#x96DB . #xBFF7) - (#x96DC . #xF0B8) - (#x96DD . #x8FE6F7) - (#x96DE . #x8FE6F8) - (#x96DF . #x8FE6F9) - (#x96E2 . #xCEA5) - (#x96E3 . #xC6F1) - (#x96E8 . #xB1AB) - (#x96E9 . #x8FE6FA) - (#x96EA . #xC0E3) - (#x96EB . #xBCB6) - (#x96EF . #x8FE6FB) - (#x96F0 . #xCAB7) - (#x96F1 . #x8FE6FC) - (#x96F2 . #xB1C0) - (#x96F6 . #xCEED) - (#x96F7 . #xCDEB) - (#x96F9 . #xF0BB) - (#x96FA . #x8FE6FD) - (#x96FB . #xC5C5) - (#x9700 . #xBCFB) - (#x9702 . #x8FE6FE) - (#x9703 . #x8FE7A1) - (#x9704 . #xF0BC) - (#x9705 . #x8FE7A2) - (#x9706 . #xF0BD) - (#x9707 . #xBFCC) - (#x9708 . #xF0BE) - (#x9709 . #x8FE7A3) - (#x970A . #xCEEE) - (#x970D . #xF0B9) - (#x970E . #xF0C0) - (#x970F . #xF0C2) - (#x9711 . #xF0C1) - (#x9713 . #xF0BF) - (#x9716 . #xF0C3) - (#x9719 . #xF0C4) - (#x971A . #x8FE7A4) - (#x971B . #x8FE7A5) - (#x971C . #xC1FA) - (#x971D . #x8FE7A6) - (#x971E . #xB2E2) - (#x9721 . #x8FE7A7) - (#x9722 . #x8FE7A8) - (#x9723 . #x8FE7A9) - (#x9724 . #xF0C5) - (#x9727 . #xCCB8) - (#x9728 . #x8FE7AA) - (#x972A . #xF0C6) - (#x9730 . #xF0C7) - (#x9731 . #x8FE7AB) - (#x9732 . #xCFAA) - (#x9733 . #x8FE7AC) - (#x9738 . #xDBB1) - (#x9739 . #xF0C8) - (#x973D . #xF0C9) - (#x973E . #xF0CA) - (#x9741 . #x8FE7AD) - (#x9742 . #xF0CE) - (#x9743 . #x8FE7AE) - (#x9744 . #xF0CB) - (#x9746 . #xF0CC) - (#x9748 . #xF0CD) - (#x9749 . #xF0CF) - (#x974A . #x8FE7AF) - (#x974E . #x8FE7B0) - (#x974F . #x8FE7B1) - (#x9752 . #xC0C4) - (#x9755 . #x8FE7B2) - (#x9756 . #xCCF7) - (#x9757 . #x8FE7B3) - (#x9758 . #x8FE7B4) - (#x9759 . #xC0C5) - (#x975A . #x8FE7B5) - (#x975B . #x8FE7B6) - (#x975C . #xF0D0) - (#x975E . #xC8F3) - (#x9760 . #xF0D1) - (#x9761 . #xF3D3) - (#x9762 . #xCCCC) - (#x9763 . #x8FE7B7) - (#x9764 . #xF0D2) - (#x9766 . #xF0D3) - (#x9767 . #x8FE7B8) - (#x9768 . #xF0D4) - (#x9769 . #xB3D7) - (#x976A . #x8FE7B9) - (#x976B . #xF0D6) - (#x976D . #xBFD9) - (#x976E . #x8FE7BA) - (#x9771 . #xF0D7) - (#x9773 . #x8FE7BB) - (#x9774 . #xB7A4) - (#x9776 . #x8FE7BC) - (#x9777 . #x8FE7BD) - (#x9778 . #x8FE7BE) - (#x9779 . #xF0D8) - (#x977A . #xF0DC) - (#x977B . #x8FE7BF) - (#x977C . #xF0DA) - (#x977D . #x8FE7C0) - (#x977F . #x8FE7C1) - (#x9780 . #x8FE7C2) - (#x9781 . #xF0DB) - (#x9784 . #xB3F3) - (#x9785 . #xF0D9) - (#x9786 . #xF0DD) - (#x9789 . #x8FE7C3) - (#x978B . #xF0DE) - (#x978D . #xB0C8) - (#x978F . #xF0DF) - (#x9790 . #xF0E0) - (#x9795 . #x8FE7C4) - (#x9796 . #x8FE7C5) - (#x9797 . #x8FE7C6) - (#x9798 . #xBEE4) - (#x9799 . #x8FE7C7) - (#x979A . #x8FE7C8) - (#x979C . #xF0E1) - (#x979E . #x8FE7C9) - (#x979F . #x8FE7CA) - (#x97A0 . #xB5C7) - (#x97A2 . #x8FE7CB) - (#x97A3 . #xF0E4) - (#x97A6 . #xF0E3) - (#x97A8 . #xF0E2) - (#x97AB . #xEBF1) - (#x97AC . #x8FE7CC) - (#x97AD . #xCADC) - (#x97AE . #x8FE7CD) - (#x97B1 . #x8FE7CE) - (#x97B2 . #x8FE7CF) - (#x97B3 . #xF0E5) - (#x97B4 . #xF0E6) - (#x97B5 . #x8FE7D0) - (#x97B6 . #x8FE7D1) - (#x97B8 . #x8FE7D2) - (#x97B9 . #x8FE7D3) - (#x97BA . #x8FE7D4) - (#x97BC . #x8FE7D5) - (#x97BE . #x8FE7D6) - (#x97BF . #x8FE7D7) - (#x97C1 . #x8FE7D8) - (#x97C3 . #xF0E7) - (#x97C4 . #x8FE7D9) - (#x97C5 . #x8FE7DA) - (#x97C6 . #xF0E8) - (#x97C7 . #x8FE7DB) - (#x97C8 . #xF0E9) - (#x97C9 . #x8FE7DC) - (#x97CA . #x8FE7DD) - (#x97CB . #xF0EA) - (#x97CC . #x8FE7DE) - (#x97CD . #x8FE7DF) - (#x97CE . #x8FE7E0) - (#x97D0 . #x8FE7E1) - (#x97D1 . #x8FE7E2) - (#x97D3 . #xB4DA) - (#x97D4 . #x8FE7E3) - (#x97D7 . #x8FE7E4) - (#x97D8 . #x8FE7E5) - (#x97D9 . #x8FE7E6) - (#x97DB . #x8FE7EA) - (#x97DC . #xF0EB) - (#x97DD . #x8FE7E7) - (#x97DE . #x8FE7E8) - (#x97E0 . #x8FE7E9) - (#x97E1 . #x8FE7EB) - (#x97E4 . #x8FE7EC) - (#x97ED . #xF0EC) - (#x97EE . #xC7A3) - (#x97EF . #x8FE7ED) - (#x97F1 . #x8FE7EE) - (#x97F2 . #xF0EE) - (#x97F3 . #xB2BB) - (#x97F4 . #x8FE7EF) - (#x97F5 . #xF0F1) - (#x97F6 . #xF0F0) - (#x97F7 . #x8FE7F0) - (#x97F8 . #x8FE7F1) - (#x97FA . #x8FE7F2) - (#x97FB . #xB1A4) - (#x97FF . #xB6C1) - (#x9801 . #xCAC7) - (#x9802 . #xC4BA) - (#x9803 . #xBAA2) - (#x9805 . #xB9E0) - (#x9806 . #xBDE7) - (#x9807 . #x8FE7F3) - (#x9808 . #xBFDC) - (#x980A . #x8FE7F4) - (#x980C . #xF0F3) - (#x980D . #x8FE7F6) - (#x980E . #x8FE7F7) - (#x980F . #xF0F2) - (#x9810 . #xCDC2) - (#x9811 . #xB4E8) - (#x9812 . #xC8D2) - (#x9813 . #xC6DC) - (#x9814 . #x8FE7F8) - (#x9816 . #x8FE7F9) - (#x9817 . #xBFFC) - (#x9818 . #xCECE) - (#x9819 . #x8FE7F5) - (#x981A . #xB7DB) - (#x981C . #x8FE7FA) - (#x981E . #x8FE7FB) - (#x9820 . #x8FE7FC) - (#x9821 . #xF0F6) - (#x9823 . #x8FE7FD) - (#x9824 . #xF0F5) - (#x9825 . #x8FE8A8) - (#x9826 . #x8FE7FE) - (#x982B . #x8FE8A1) - (#x982C . #xCBCB) - (#x982D . #xC6AC) - (#x982E . #x8FE8A2) - (#x982F . #x8FE8A3) - (#x9830 . #x8FE8A4) - (#x9832 . #x8FE8A5) - (#x9833 . #x8FE8A6) - (#x9834 . #xB1D0) - (#x9835 . #x8FE8A7) - (#x9837 . #xF0F7) - (#x9838 . #xF0F4) - (#x983B . #xC9D1) - (#x983C . #xCDEA) - (#x983D . #xF0F8) - (#x983E . #x8FE8A9) - (#x9844 . #x8FE8AA) - (#x9846 . #xF0F9) - (#x9847 . #x8FE8AB) - (#x984A . #x8FE8AC) - (#x984B . #xF0FB) - (#x984C . #xC2EA) - (#x984D . #xB3DB) - (#x984E . #xB3DC) - (#x984F . #xF0FA) - (#x9851 . #x8FE8AD) - (#x9852 . #x8FE8AE) - (#x9853 . #x8FE8AF) - (#x9854 . #xB4E9) - (#x9855 . #xB8B2) - (#x9856 . #x8FE8B0) - (#x9857 . #x8FE8B1) - (#x9858 . #xB4EA) - (#x9859 . #x8FE8B2) - (#x985A . #x8FE8B3) - (#x985B . #xC5BF) - (#x985E . #xCEE0) - (#x9862 . #x8FE8B4) - (#x9863 . #x8FE8B5) - (#x9865 . #x8FE8B6) - (#x9866 . #x8FE8B7) - (#x9867 . #xB8DC) - (#x986A . #x8FE8B8) - (#x986B . #xF0FC) - (#x986C . #x8FE8B9) - (#x986F . #xF0FD) - (#x9870 . #xF0FE) - (#x9871 . #xF1A1) - (#x9873 . #xF1A3) - (#x9874 . #xF1A2) - (#x98A8 . #xC9F7) - (#x98AA . #xF1A4) - (#x98AB . #x8FE8BA) - (#x98AD . #x8FE8BB) - (#x98AE . #x8FE8BC) - (#x98AF . #xF1A5) - (#x98B0 . #x8FE8BD) - (#x98B1 . #xF1A6) - (#x98B4 . #x8FE8BE) - (#x98B6 . #xF1A7) - (#x98B7 . #x8FE8BF) - (#x98B8 . #x8FE8C0) - (#x98BA . #x8FE8C1) - (#x98BB . #x8FE8C2) - (#x98BF . #x8FE8C3) - (#x98C2 . #x8FE8C4) - (#x98C3 . #xF1A9) - (#x98C4 . #xF1A8) - (#x98C5 . #x8FE8C5) - (#x98C6 . #xF1AA) - (#x98C8 . #x8FE8C6) - (#x98CC . #x8FE8C7) - (#x98DB . #xC8F4) - (#x98DC . #xE6CC) - (#x98DF . #xBFA9) - (#x98E1 . #x8FE8C8) - (#x98E2 . #xB5B2) - (#x98E3 . #x8FE8C9) - (#x98E5 . #x8FE8CA) - (#x98E6 . #x8FE8CB) - (#x98E7 . #x8FE8CC) - (#x98E9 . #xF1AB) - (#x98EA . #x8FE8CD) - (#x98EB . #xF1AC) - (#x98ED . #xD2AC) - (#x98EE . #xDDBB) - (#x98EF . #xC8D3) - (#x98F2 . #xB0FB) - (#x98F3 . #x8FE8CE) - (#x98F4 . #xB0BB) - (#x98F6 . #x8FE8CF) - (#x98FC . #xBBF4) - (#x98FD . #xCBB0) - (#x98FE . #xBEFE) - (#x9902 . #x8FE8D0) - (#x9903 . #xF1AD) - (#x9905 . #xCCDF) - (#x9907 . #x8FE8D1) - (#x9908 . #x8FE8D2) - (#x9909 . #xF1AE) - (#x990A . #xCDDC) - (#x990C . #xB1C2) - (#x9910 . #xBBC1) - (#x9911 . #x8FE8D3) - (#x9912 . #xF1AF) - (#x9913 . #xB2EE) - (#x9914 . #xF1B0) - (#x9915 . #x8FE8D4) - (#x9916 . #x8FE8D5) - (#x9917 . #x8FE8D6) - (#x9918 . #xF1B1) - (#x991A . #x8FE8D7) - (#x991B . #x8FE8D8) - (#x991C . #x8FE8D9) - (#x991D . #xF1B3) - (#x991E . #xF1B4) - (#x991F . #x8FE8DA) - (#x9920 . #xF1B6) - (#x9921 . #xF1B2) - (#x9922 . #x8FE8DB) - (#x9924 . #xF1B5) - (#x9926 . #x8FE8DC) - (#x9927 . #x8FE8DD) - (#x9928 . #xB4DB) - (#x992B . #x8FE8DE) - (#x992C . #xF1B7) - (#x992E . #xF1B8) - (#x9931 . #x8FE8DF) - (#x9932 . #x8FE8E0) - (#x9933 . #x8FE8E1) - (#x9934 . #x8FE8E2) - (#x9935 . #x8FE8E3) - (#x9939 . #x8FE8E4) - (#x993A . #x8FE8E5) - (#x993B . #x8FE8E6) - (#x993C . #x8FE8E7) - (#x993D . #xF1B9) - (#x993E . #xF1BA) - (#x9940 . #x8FE8E8) - (#x9941 . #x8FE8E9) - (#x9942 . #xF1BB) - (#x9945 . #xF1BD) - (#x9946 . #x8FE8EA) - (#x9947 . #x8FE8EB) - (#x9948 . #x8FE8EC) - (#x9949 . #xF1BC) - (#x994B . #xF1BF) - (#x994C . #xF1C2) - (#x994D . #x8FE8ED) - (#x994E . #x8FE8EE) - (#x9950 . #xF1BE) - (#x9951 . #xF1C0) - (#x9952 . #xF1C1) - (#x9954 . #x8FE8EF) - (#x9955 . #xF1C3) - (#x9957 . #xB6C2) - (#x9958 . #x8FE8F0) - (#x9959 . #x8FE8F1) - (#x995B . #x8FE8F2) - (#x995C . #x8FE8F3) - (#x995E . #x8FE8F4) - (#x995F . #x8FE8F5) - (#x9960 . #x8FE8F6) - (#x9996 . #xBCF3) - (#x9997 . #xF1C4) - (#x9998 . #xF1C5) - (#x9999 . #xB9E1) - (#x999B . #x8FE8F7) - (#x999D . #x8FE8F8) - (#x999F . #x8FE8F9) - (#x99A5 . #xF1C6) - (#x99A6 . #x8FE8FA) - (#x99A8 . #xB3BE) - (#x99AC . #xC7CF) - (#x99AD . #xF1C7) - (#x99AE . #xF1C8) - (#x99B0 . #x8FE8FB) - (#x99B1 . #x8FE8FC) - (#x99B2 . #x8FE8FD) - (#x99B3 . #xC3DA) - (#x99B4 . #xC6EB) - (#x99B5 . #x8FE8FE) - (#x99B9 . #x8FE9A1) - (#x99BA . #x8FE9A2) - (#x99BC . #xF1C9) - (#x99BD . #x8FE9A3) - (#x99BF . #x8FE9A4) - (#x99C1 . #xC7FD) - (#x99C3 . #x8FE9A5) - (#x99C4 . #xC2CC) - (#x99C5 . #xB1D8) - (#x99C6 . #xB6EE) - (#x99C8 . #xB6EF) - (#x99C9 . #x8FE9A6) - (#x99D0 . #xC3F3) - (#x99D1 . #xF1CE) - (#x99D2 . #xB6F0) - (#x99D3 . #x8FE9A7) - (#x99D4 . #x8FE9A8) - (#x99D5 . #xB2EF) - (#x99D8 . #xF1CD) - (#x99D9 . #x8FE9A9) - (#x99DA . #x8FE9AA) - (#x99DB . #xF1CB) - (#x99DC . #x8FE9AB) - (#x99DD . #xF1CC) - (#x99DE . #x8FE9AC) - (#x99DF . #xF1CA) - (#x99E2 . #xF1D8) - (#x99E7 . #x8FE9AD) - (#x99EA . #x8FE9AE) - (#x99EB . #x8FE9AF) - (#x99EC . #x8FE9B0) - (#x99ED . #xF1CF) - (#x99EE . #xF1D0) - (#x99F0 . #x8FE9B1) - (#x99F1 . #xF1D1) - (#x99F2 . #xF1D2) - (#x99F4 . #x8FE9B2) - (#x99F5 . #x8FE9B3) - (#x99F8 . #xF1D4) - (#x99F9 . #x8FE9B4) - (#x99FB . #xF1D3) - (#x99FD . #x8FE9B5) - (#x99FE . #x8FE9B6) - (#x99FF . #xBDD9) - (#x9A01 . #xF1D5) - (#x9A02 . #x8FE9B7) - (#x9A03 . #x8FE9B8) - (#x9A04 . #x8FE9B9) - (#x9A05 . #xF1D7) - (#x9A0B . #x8FE9BA) - (#x9A0C . #x8FE9BB) - (#x9A0E . #xB5B3) - (#x9A0F . #xF1D6) - (#x9A10 . #x8FE9BC) - (#x9A11 . #x8FE9BD) - (#x9A12 . #xC1FB) - (#x9A13 . #xB8B3) - (#x9A16 . #x8FE9BE) - (#x9A19 . #xF1D9) - (#x9A1E . #x8FE9BF) - (#x9A20 . #x8FE9C0) - (#x9A22 . #x8FE9C1) - (#x9A23 . #x8FE9C2) - (#x9A24 . #x8FE9C3) - (#x9A27 . #x8FE9C4) - (#x9A28 . #xC2CD) - (#x9A2B . #xF1DA) - (#x9A2D . #x8FE9C5) - (#x9A2E . #x8FE9C6) - (#x9A30 . #xC6AD) - (#x9A33 . #x8FE9C7) - (#x9A35 . #x8FE9C8) - (#x9A36 . #x8FE9C9) - (#x9A37 . #xF1DB) - (#x9A38 . #x8FE9CA) - (#x9A3E . #xF1E0) - (#x9A40 . #xF1DE) - (#x9A41 . #x8FE9CC) - (#x9A42 . #xF1DD) - (#x9A43 . #xF1DF) - (#x9A44 . #x8FE9CD) - (#x9A45 . #xF1DC) - (#x9A47 . #x8FE9CB) - (#x9A4A . #x8FE9CE) - (#x9A4B . #x8FE9CF) - (#x9A4C . #x8FE9D0) - (#x9A4D . #xF1E2) - (#x9A4E . #x8FE9D1) - (#x9A51 . #x8FE9D2) - (#x9A54 . #x8FE9D3) - (#x9A55 . #xF1E1) - (#x9A56 . #x8FE9D4) - (#x9A57 . #xF1E4) - (#x9A5A . #xB6C3) - (#x9A5B . #xF1E3) - (#x9A5D . #x8FE9D5) - (#x9A5F . #xF1E5) - (#x9A62 . #xF1E6) - (#x9A64 . #xF1E8) - (#x9A65 . #xF1E7) - (#x9A69 . #xF1E9) - (#x9A6A . #xF1EB) - (#x9A6B . #xF1EA) - (#x9AA8 . #xB9FC) - (#x9AAA . #x8FE9D6) - (#x9AAC . #x8FE9D7) - (#x9AAD . #xF1EC) - (#x9AAE . #x8FE9D8) - (#x9AAF . #x8FE9D9) - (#x9AB0 . #xF1ED) - (#x9AB2 . #x8FE9DA) - (#x9AB4 . #x8FE9DB) - (#x9AB5 . #x8FE9DC) - (#x9AB6 . #x8FE9DD) - (#x9AB8 . #xB3BC) - (#x9AB9 . #x8FE9DE) - (#x9ABB . #x8FE9DF) - (#x9ABC . #xF1EE) - (#x9ABE . #x8FE9E0) - (#x9ABF . #x8FE9E1) - (#x9AC0 . #xF1EF) - (#x9AC1 . #x8FE9E2) - (#x9AC3 . #x8FE9E3) - (#x9AC4 . #xBFF1) - (#x9AC6 . #x8FE9E4) - (#x9AC8 . #x8FE9E5) - (#x9ACE . #x8FE9E6) - (#x9ACF . #xF1F0) - (#x9AD0 . #x8FE9E7) - (#x9AD1 . #xF1F1) - (#x9AD2 . #x8FE9E8) - (#x9AD3 . #xF1F2) - (#x9AD4 . #xF1F3) - (#x9AD5 . #x8FE9E9) - (#x9AD6 . #x8FE9EA) - (#x9AD7 . #x8FE9EB) - (#x9AD8 . #xB9E2) - (#x9ADB . #x8FE9EC) - (#x9ADC . #x8FE9ED) - (#x9ADE . #xF1F4) - (#x9ADF . #xF1F5) - (#x9AE0 . #x8FE9EE) - (#x9AE2 . #xF1F6) - (#x9AE3 . #xF1F7) - (#x9AE4 . #x8FE9EF) - (#x9AE5 . #x8FE9F0) - (#x9AE6 . #xF1F8) - (#x9AE7 . #x8FE9F1) - (#x9AE9 . #x8FE9F2) - (#x9AEA . #xC8B1) - (#x9AEB . #xF1FA) - (#x9AEC . #x8FE9F3) - (#x9AED . #xC9A6) - (#x9AEE . #xF1FB) - (#x9AEF . #xF1F9) - (#x9AF1 . #xF1FD) - (#x9AF2 . #x8FE9F4) - (#x9AF3 . #x8FE9F5) - (#x9AF4 . #xF1FC) - (#x9AF5 . #x8FE9F6) - (#x9AF7 . #xF1FE) - (#x9AF9 . #x8FE9F7) - (#x9AFA . #x8FE9F8) - (#x9AFB . #xF2A1) - (#x9AFD . #x8FE9F9) - (#x9AFF . #x8FE9FA) - (#x9B00 . #x8FE9FB) - (#x9B01 . #x8FE9FC) - (#x9B02 . #x8FE9FD) - (#x9B03 . #x8FE9FE) - (#x9B04 . #x8FEAA1) - (#x9B05 . #x8FEAA2) - (#x9B06 . #xF2A2) - (#x9B08 . #x8FEAA3) - (#x9B09 . #x8FEAA4) - (#x9B0B . #x8FEAA5) - (#x9B0C . #x8FEAA6) - (#x9B0D . #x8FEAA7) - (#x9B0E . #x8FEAA8) - (#x9B10 . #x8FEAA9) - (#x9B12 . #x8FEAAA) - (#x9B16 . #x8FEAAB) - (#x9B18 . #xF2A3) - (#x9B19 . #x8FEAAC) - (#x9B1A . #xF2A4) - (#x9B1B . #x8FEAAD) - (#x9B1C . #x8FEAAE) - (#x9B1F . #xF2A5) - (#x9B20 . #x8FEAAF) - (#x9B22 . #xF2A6) - (#x9B23 . #xF2A7) - (#x9B25 . #xF2A8) - (#x9B26 . #x8FEAB0) - (#x9B27 . #xF2A9) - (#x9B28 . #xF2AA) - (#x9B29 . #xF2AB) - (#x9B2A . #xF2AC) - (#x9B2B . #x8FEAB1) - (#x9B2D . #x8FEAB2) - (#x9B2E . #xF2AD) - (#x9B2F . #xF2AE) - (#x9B31 . #xDDB5) - (#x9B32 . #xF2AF) - (#x9B33 . #x8FEAB3) - (#x9B34 . #x8FEAB4) - (#x9B35 . #x8FEAB5) - (#x9B37 . #x8FEAB6) - (#x9B39 . #x8FEAB7) - (#x9B3A . #x8FEAB8) - (#x9B3B . #xE4F8) - (#x9B3C . #xB5B4) - (#x9B3D . #x8FEAB9) - (#x9B41 . #xB3A1) - (#x9B42 . #xBAB2) - (#x9B43 . #xF2B1) - (#x9B44 . #xF2B0) - (#x9B45 . #xCCA5) - (#x9B48 . #x8FEABA) - (#x9B4B . #x8FEABB) - (#x9B4C . #x8FEABC) - (#x9B4D . #xF2B3) - (#x9B4E . #xF2B4) - (#x9B4F . #xF2B2) - (#x9B51 . #xF2B5) - (#x9B54 . #xCBE2) - (#x9B55 . #x8FEABD) - (#x9B56 . #x8FEABE) - (#x9B57 . #x8FEABF) - (#x9B58 . #xF2B6) - (#x9B5A . #xB5FB) - (#x9B5B . #x8FEAC0) - (#x9B5E . #x8FEAC1) - (#x9B61 . #x8FEAC2) - (#x9B63 . #x8FEAC3) - (#x9B65 . #x8FEAC4) - (#x9B66 . #x8FEAC5) - (#x9B68 . #x8FEAC6) - (#x9B6A . #x8FEAC7) - (#x9B6B . #x8FEAC8) - (#x9B6C . #x8FEAC9) - (#x9B6D . #x8FEACA) - (#x9B6E . #x8FEACB) - (#x9B6F . #xCFA5) - (#x9B73 . #x8FEACC) - (#x9B74 . #xF2B7) - (#x9B75 . #x8FEACD) - (#x9B77 . #x8FEACE) - (#x9B78 . #x8FEACF) - (#x9B79 . #x8FEAD0) - (#x9B7F . #x8FEAD1) - (#x9B80 . #x8FEAD2) - (#x9B83 . #xF2B9) - (#x9B84 . #x8FEAD3) - (#x9B85 . #x8FEAD4) - (#x9B86 . #x8FEAD5) - (#x9B87 . #x8FEAD6) - (#x9B89 . #x8FEAD7) - (#x9B8A . #x8FEAD8) - (#x9B8B . #x8FEAD9) - (#x9B8D . #x8FEADA) - (#x9B8E . #xB0BE) - (#x9B8F . #x8FEADB) - (#x9B90 . #x8FEADC) - (#x9B91 . #xF2BA) - (#x9B92 . #xCAAB) - (#x9B93 . #xF2B8) - (#x9B94 . #x8FEADD) - (#x9B96 . #xF2BB) - (#x9B97 . #xF2BC) - (#x9B9A . #x8FEADE) - (#x9B9D . #x8FEADF) - (#x9B9E . #x8FEAE0) - (#x9B9F . #xF2BD) - (#x9BA0 . #xF2BE) - (#x9BA6 . #x8FEAE1) - (#x9BA7 . #x8FEAE2) - (#x9BA8 . #xF2BF) - (#x9BA9 . #x8FEAE3) - (#x9BAA . #xCBEE) - (#x9BAB . #xBBAD) - (#x9BAC . #x8FEAE4) - (#x9BAD . #xBAFA) - (#x9BAE . #xC1AF) - (#x9BB0 . #x8FEAE5) - (#x9BB1 . #x8FEAE6) - (#x9BB2 . #x8FEAE7) - (#x9BB4 . #xF2C0) - (#x9BB7 . #x8FEAE8) - (#x9BB8 . #x8FEAE9) - (#x9BB9 . #xF2C3) - (#x9BBB . #x8FEAEA) - (#x9BBC . #x8FEAEB) - (#x9BBE . #x8FEAEC) - (#x9BBF . #x8FEAED) - (#x9BC0 . #xF2C1) - (#x9BC1 . #x8FEAEE) - (#x9BC6 . #xF2C4) - (#x9BC7 . #x8FEAEF) - (#x9BC8 . #x8FEAF0) - (#x9BC9 . #xB8F1) - (#x9BCA . #xF2C2) - (#x9BCE . #x8FEAF1) - (#x9BCF . #xF2C5) - (#x9BD0 . #x8FEAF2) - (#x9BD1 . #xF2C6) - (#x9BD2 . #xF2C7) - (#x9BD4 . #xF2CB) - (#x9BD6 . #xBBAA) - (#x9BD7 . #x8FEAF3) - (#x9BD8 . #x8FEAF4) - (#x9BDB . #xC2E4) - (#x9BDD . #x8FEAF5) - (#x9BDF . #x8FEAF6) - (#x9BE1 . #xF2CC) - (#x9BE2 . #xF2C9) - (#x9BE3 . #xF2C8) - (#x9BE4 . #xF2CA) - (#x9BE5 . #x8FEAF7) - (#x9BE7 . #x8FEAF8) - (#x9BE8 . #xB7DF) - (#x9BEA . #x8FEAF9) - (#x9BEB . #x8FEAFA) - (#x9BEF . #x8FEAFB) - (#x9BF0 . #xF2D0) - (#x9BF1 . #xF2CF) - (#x9BF2 . #xF2CE) - (#x9BF3 . #x8FEAFC) - (#x9BF5 . #xB0B3) - (#x9BF7 . #x8FEAFD) - (#x9BF8 . #x8FEAFE) - (#x9BF9 . #x8FEBA1) - (#x9BFA . #x8FEBA2) - (#x9BFD . #x8FEBA3) - (#x9BFF . #x8FEBA4) - (#x9C00 . #x8FEBA5) - (#x9C02 . #x8FEBA6) - (#x9C04 . #xF2DA) - (#x9C06 . #xF2D6) - (#x9C08 . #xF2D7) - (#x9C09 . #xF2D3) - (#x9C0A . #xF2D9) - (#x9C0B . #x8FEBA7) - (#x9C0C . #xF2D5) - (#x9C0D . #xB3E2) - (#x9C0F . #x8FEBA8) - (#x9C10 . #xCFCC) - (#x9C11 . #x8FEBA9) - (#x9C12 . #xF2D8) - (#x9C13 . #xF2D4) - (#x9C14 . #xF2D2) - (#x9C15 . #xF2D1) - (#x9C16 . #x8FEBAA) - (#x9C18 . #x8FEBAB) - (#x9C19 . #x8FEBAC) - (#x9C1A . #x8FEBAD) - (#x9C1B . #xF2DC) - (#x9C1C . #x8FEBAE) - (#x9C1E . #x8FEBAF) - (#x9C21 . #xF2DF) - (#x9C22 . #x8FEBB0) - (#x9C23 . #x8FEBB1) - (#x9C24 . #xF2DE) - (#x9C25 . #xF2DD) - (#x9C26 . #x8FEBB2) - (#x9C27 . #x8FEBB3) - (#x9C28 . #x8FEBB4) - (#x9C29 . #x8FEBB5) - (#x9C2A . #x8FEBB6) - (#x9C2D . #xC9C9) - (#x9C2E . #xF2DB) - (#x9C2F . #xB0F3) - (#x9C30 . #xF2E0) - (#x9C31 . #x8FEBB7) - (#x9C32 . #xF2E2) - (#x9C35 . #x8FEBB8) - (#x9C36 . #x8FEBB9) - (#x9C37 . #x8FEBBA) - (#x9C39 . #xB3EF) - (#x9C3A . #xF2CD) - (#x9C3B . #xB1B7) - (#x9C3D . #x8FEBBB) - (#x9C3E . #xF2E4) - (#x9C41 . #x8FEBBC) - (#x9C43 . #x8FEBBD) - (#x9C44 . #x8FEBBE) - (#x9C45 . #x8FEBBF) - (#x9C46 . #xF2E3) - (#x9C47 . #xF2E1) - (#x9C48 . #xC3AD) - (#x9C49 . #x8FEBC0) - (#x9C4A . #x8FEBC1) - (#x9C4E . #x8FEBC2) - (#x9C4F . #x8FEBC3) - (#x9C50 . #x8FEBC4) - (#x9C52 . #xCBF0) - (#x9C53 . #x8FEBC5) - (#x9C54 . #x8FEBC6) - (#x9C56 . #x8FEBC7) - (#x9C57 . #xCEDA) - (#x9C58 . #x8FEBC8) - (#x9C5A . #xF2E5) - (#x9C5B . #x8FEBC9) - (#x9C5C . #x8FEBD0) - (#x9C5D . #x8FEBCA) - (#x9C5E . #x8FEBCB) - (#x9C5F . #x8FEBCC) - (#x9C60 . #xF2E6) - (#x9C63 . #x8FEBCD) - (#x9C67 . #xF2E7) - (#x9C68 . #x8FEBD2) - (#x9C69 . #x8FEBCE) - (#x9C6A . #x8FEBCF) - (#x9C6B . #x8FEBD1) - (#x9C6E . #x8FEBD3) - (#x9C70 . #x8FEBD4) - (#x9C72 . #x8FEBD5) - (#x9C75 . #x8FEBD6) - (#x9C76 . #xF2E8) - (#x9C77 . #x8FEBD7) - (#x9C78 . #xF2E9) - (#x9C7B . #x8FEBD8) - (#x9CE5 . #xC4BB) - (#x9CE6 . #x8FEBD9) - (#x9CE7 . #xF2EA) - (#x9CE9 . #xC8B7) - (#x9CEB . #xF2EF) - (#x9CEC . #xF2EB) - (#x9CF0 . #xF2EC) - (#x9CF2 . #x8FEBDA) - (#x9CF3 . #xCBB1) - (#x9CF4 . #xCCC4) - (#x9CF6 . #xC6D0) - (#x9CF7 . #x8FEBDB) - (#x9CF9 . #x8FEBDC) - (#x9D02 . #x8FEBDE) - (#x9D03 . #xF2F0) - (#x9D06 . #xF2F1) - (#x9D07 . #xC6BE) - (#x9D08 . #xF2EE) - (#x9D09 . #xF2ED) - (#x9D0B . #x8FEBDD) - (#x9D0E . #xB2AA) - (#x9D11 . #x8FEBDF) - (#x9D12 . #xF2F9) - (#x9D15 . #xF2F8) - (#x9D17 . #x8FEBE0) - (#x9D18 . #x8FEBE1) - (#x9D1B . #xB1F5) - (#x9D1C . #x8FEBE2) - (#x9D1D . #x8FEBE3) - (#x9D1E . #x8FEBE4) - (#x9D1F . #xF2F6) - (#x9D23 . #xF2F5) - (#x9D26 . #xF2F3) - (#x9D28 . #xB3FB) - (#x9D2A . #xF2F2) - (#x9D2B . #xBCB2) - (#x9D2C . #xB2A9) - (#x9D2F . #x8FEBE5) - (#x9D30 . #x8FEBE6) - (#x9D32 . #x8FEBE7) - (#x9D33 . #x8FEBE8) - (#x9D34 . #x8FEBE9) - (#x9D3A . #x8FEBEA) - (#x9D3B . #xB9E3) - (#x9D3C . #x8FEBEB) - (#x9D3D . #x8FEBED) - (#x9D3E . #xF2FC) - (#x9D3F . #xF2FB) - (#x9D41 . #xF2FA) - (#x9D42 . #x8FEBEE) - (#x9D43 . #x8FEBEF) - (#x9D44 . #xF2F7) - (#x9D45 . #x8FEBEC) - (#x9D46 . #xF2FD) - (#x9D47 . #x8FEBF0) - (#x9D48 . #xF2FE) - (#x9D4A . #x8FEBF1) - (#x9D50 . #xF3A5) - (#x9D51 . #xF3A4) - (#x9D53 . #x8FEBF2) - (#x9D54 . #x8FEBF3) - (#x9D59 . #xF3A6) - (#x9D5C . #xB1AD) - (#x9D5D . #xF3A1) - (#x9D5E . #xF3A2) - (#x9D5F . #x8FEBF4) - (#x9D60 . #xB9F4) - (#x9D61 . #xCCB9) - (#x9D62 . #x8FEBF6) - (#x9D63 . #x8FEBF5) - (#x9D64 . #xF3A3) - (#x9D65 . #x8FEBF7) - (#x9D69 . #x8FEBF8) - (#x9D6A . #x8FEBF9) - (#x9D6B . #x8FEBFA) - (#x9D6C . #xCBB2) - (#x9D6F . #xF3AB) - (#x9D70 . #x8FEBFB) - (#x9D72 . #xF3A7) - (#x9D76 . #x8FEBFC) - (#x9D77 . #x8FEBFD) - (#x9D7A . #xF3AC) - (#x9D7B . #x8FEBFE) - (#x9D7C . #x8FECA1) - (#x9D7E . #x8FECA2) - (#x9D83 . #x8FECA3) - (#x9D84 . #x8FECA4) - (#x9D86 . #x8FECA5) - (#x9D87 . #xF3A9) - (#x9D89 . #xF3A8) - (#x9D8A . #x8FECA6) - (#x9D8D . #x8FECA7) - (#x9D8E . #x8FECA8) - (#x9D8F . #xB7DC) - (#x9D92 . #x8FECA9) - (#x9D93 . #x8FECAA) - (#x9D95 . #x8FECAB) - (#x9D96 . #x8FECAC) - (#x9D97 . #x8FECAD) - (#x9D98 . #x8FECAE) - (#x9D9A . #xF3AD) - (#x9DA1 . #x8FECAF) - (#x9DA4 . #xF3AE) - (#x9DA9 . #xF3AF) - (#x9DAA . #x8FECB0) - (#x9DAB . #xF3AA) - (#x9DAC . #x8FECB1) - (#x9DAE . #x8FECB2) - (#x9DAF . #xF2F4) - (#x9DB1 . #x8FECB3) - (#x9DB2 . #xF3B0) - (#x9DB4 . #xC4E1) - (#x9DB5 . #x8FECB4) - (#x9DB8 . #xF3B4) - (#x9DB9 . #x8FECB5) - (#x9DBA . #xF3B5) - (#x9DBB . #xF3B3) - (#x9DBC . #x8FECB6) - (#x9DBF . #x8FECB7) - (#x9DC1 . #xF3B2) - (#x9DC2 . #xF3B8) - (#x9DC3 . #x8FECB8) - (#x9DC4 . #xF3B1) - (#x9DC6 . #xF3B6) - (#x9DC7 . #x8FECB9) - (#x9DC9 . #x8FECBA) - (#x9DCA . #x8FECBB) - (#x9DCF . #xF3B7) - (#x9DD3 . #xF3BA) - (#x9DD4 . #x8FECBC) - (#x9DD5 . #x8FECBD) - (#x9DD6 . #x8FECBE) - (#x9DD7 . #x8FECBF) - (#x9DD9 . #xF3B9) - (#x9DDA . #x8FECC0) - (#x9DDE . #x8FECC1) - (#x9DDF . #x8FECC2) - (#x9DE0 . #x8FECC3) - (#x9DE5 . #x8FECC4) - (#x9DE6 . #xF3BC) - (#x9DE7 . #x8FECC5) - (#x9DE9 . #x8FECC6) - (#x9DEB . #x8FECC7) - (#x9DED . #xF3BD) - (#x9DEE . #x8FECC8) - (#x9DEF . #xF3BE) - (#x9DF0 . #x8FECC9) - (#x9DF2 . #xCFC9) - (#x9DF3 . #x8FECCA) - (#x9DF4 . #x8FECCB) - (#x9DF8 . #xF3BB) - (#x9DF9 . #xC2EB) - (#x9DFA . #xBAED) - (#x9DFD . #xF3BF) - (#x9DFE . #x8FECCC) - (#x9E02 . #x8FECCE) - (#x9E07 . #x8FECCF) - (#x9E0A . #x8FECCD) - (#x9E0E . #x8FECD0) - (#x9E10 . #x8FECD1) - (#x9E11 . #x8FECD2) - (#x9E12 . #x8FECD3) - (#x9E15 . #x8FECD4) - (#x9E16 . #x8FECD5) - (#x9E19 . #x8FECD6) - (#x9E1A . #xF3C0) - (#x9E1B . #xF3C1) - (#x9E1C . #x8FECD7) - (#x9E1D . #x8FECD8) - (#x9E1E . #xF3C2) - (#x9E75 . #xF3C3) - (#x9E78 . #xB8B4) - (#x9E79 . #xF3C4) - (#x9E7A . #x8FECD9) - (#x9E7B . #x8FECDA) - (#x9E7C . #x8FECDB) - (#x9E7D . #xF3C5) - (#x9E7F . #xBCAF) - (#x9E80 . #x8FECDC) - (#x9E81 . #xF3C6) - (#x9E82 . #x8FECDD) - (#x9E83 . #x8FECDE) - (#x9E84 . #x8FECDF) - (#x9E85 . #x8FECE0) - (#x9E87 . #x8FECE1) - (#x9E88 . #xF3C7) - (#x9E8B . #xF3C8) - (#x9E8C . #xF3C9) - (#x9E8E . #x8FECE2) - (#x9E8F . #x8FECE3) - (#x9E91 . #xF3CC) - (#x9E92 . #xF3CA) - (#x9E93 . #xCFBC) - (#x9E95 . #xF3CB) - (#x9E96 . #x8FECE4) - (#x9E97 . #xCEEF) - (#x9E98 . #x8FECE5) - (#x9E9B . #x8FECE6) - (#x9E9D . #xF3CD) - (#x9E9E . #x8FECE7) - (#x9E9F . #xCEDB) - (#x9EA4 . #x8FECE8) - (#x9EA5 . #xF3CE) - (#x9EA6 . #xC7FE) - (#x9EA8 . #x8FECE9) - (#x9EA9 . #xF3CF) - (#x9EAA . #xF3D1) - (#x9EAC . #x8FECEA) - (#x9EAD . #xF3D2) - (#x9EAE . #x8FECEB) - (#x9EAF . #x8FECEC) - (#x9EB0 . #x8FECED) - (#x9EB3 . #x8FECEE) - (#x9EB4 . #x8FECEF) - (#x9EB5 . #x8FECF0) - (#x9EB8 . #xF3D0) - (#x9EB9 . #xB9ED) - (#x9EBA . #xCCCD) - (#x9EBB . #xCBE3) - (#x9EBC . #xD6F7) - (#x9EBE . #xDDE0) - (#x9EBF . #xCBFB) - (#x9EC4 . #xB2AB) - (#x9EC6 . #x8FECF1) - (#x9EC8 . #x8FECF2) - (#x9ECB . #x8FECF3) - (#x9ECC . #xF3D4) - (#x9ECD . #xB5D0) - (#x9ECE . #xF3D5) - (#x9ECF . #xF3D6) - (#x9ED0 . #xF3D7) - (#x9ED2 . #xB9F5) - (#x9ED4 . #xF3D8) - (#x9ED5 . #x8FECF4) - (#x9ED8 . #xE0D4) - (#x9ED9 . #xCCDB) - (#x9EDB . #xC2E3) - (#x9EDC . #xF3D9) - (#x9EDD . #xF3DB) - (#x9EDE . #xF3DA) - (#x9EDF . #x8FECF5) - (#x9EE0 . #xF3DC) - (#x9EE4 . #x8FECF6) - (#x9EE5 . #xF3DD) - (#x9EE7 . #x8FECF7) - (#x9EE8 . #xF3DE) - (#x9EEC . #x8FECF8) - (#x9EED . #x8FECF9) - (#x9EEE . #x8FECFA) - (#x9EEF . #xF3DF) - (#x9EF0 . #x8FECFB) - (#x9EF1 . #x8FECFC) - (#x9EF2 . #x8FECFD) - (#x9EF4 . #xF3E0) - (#x9EF5 . #x8FECFE) - (#x9EF6 . #xF3E1) - (#x9EF7 . #xF3E2) - (#x9EF8 . #x8FEDA1) - (#x9EF9 . #xF3E3) - (#x9EFB . #xF3E4) - (#x9EFC . #xF3E5) - (#x9EFD . #xF3E6) - (#x9EFF . #x8FEDA2) - (#x9F02 . #x8FEDA3) - (#x9F03 . #x8FEDA4) - (#x9F07 . #xF3E7) - (#x9F08 . #xF3E8) - (#x9F09 . #x8FEDA5) - (#x9F0E . #xC5A4) - (#x9F0F . #x8FEDA6) - (#x9F10 . #x8FEDA7) - (#x9F11 . #x8FEDA8) - (#x9F12 . #x8FEDA9) - (#x9F13 . #xB8DD) - (#x9F14 . #x8FEDAA) - (#x9F15 . #xF3EA) - (#x9F16 . #x8FEDAB) - (#x9F17 . #x8FEDAC) - (#x9F19 . #x8FEDAD) - (#x9F1A . #x8FEDAE) - (#x9F1B . #x8FEDAF) - (#x9F1F . #x8FEDB0) - (#x9F20 . #xC1CD) - (#x9F21 . #xF3EB) - (#x9F22 . #x8FEDB1) - (#x9F26 . #x8FEDB2) - (#x9F2A . #x8FEDB3) - (#x9F2B . #x8FEDB4) - (#x9F2C . #xF3EC) - (#x9F2F . #x8FEDB5) - (#x9F31 . #x8FEDB6) - (#x9F32 . #x8FEDB7) - (#x9F34 . #x8FEDB8) - (#x9F37 . #x8FEDB9) - (#x9F39 . #x8FEDBA) - (#x9F3A . #x8FEDBB) - (#x9F3B . #xC9A1) - (#x9F3C . #x8FEDBC) - (#x9F3D . #x8FEDBD) - (#x9F3E . #xF3ED) - (#x9F3F . #x8FEDBE) - (#x9F41 . #x8FEDBF) - (#x9F43 . #x8FEDC0) - (#x9F44 . #x8FEDC1) - (#x9F45 . #x8FEDC2) - (#x9F46 . #x8FEDC3) - (#x9F47 . #x8FEDC4) - (#x9F4A . #xF3EE) - (#x9F4B . #xE3B7) - (#x9F4E . #xECDA) - (#x9F4F . #xF0ED) - (#x9F52 . #xF3EF) - (#x9F53 . #x8FEDC5) - (#x9F54 . #xF3F0) - (#x9F55 . #x8FEDC6) - (#x9F56 . #x8FEDC7) - (#x9F57 . #x8FEDC8) - (#x9F58 . #x8FEDC9) - (#x9F5A . #x8FEDCA) - (#x9F5D . #x8FEDCB) - (#x9F5E . #x8FEDCC) - (#x9F5F . #xF3F2) - (#x9F60 . #xF3F3) - (#x9F61 . #xF3F4) - (#x9F62 . #xCEF0) - (#x9F63 . #xF3F1) - (#x9F66 . #xF3F5) - (#x9F67 . #xF3F6) - (#x9F68 . #x8FEDCD) - (#x9F69 . #x8FEDCE) - (#x9F6A . #xF3F8) - (#x9F6C . #xF3F7) - (#x9F6D . #x8FEDCF) - (#x9F6E . #x8FEDD0) - (#x9F6F . #x8FEDD1) - (#x9F70 . #x8FEDD2) - (#x9F71 . #x8FEDD3) - (#x9F72 . #xF3FA) - (#x9F73 . #x8FEDD4) - (#x9F75 . #x8FEDD5) - (#x9F76 . #xF3FB) - (#x9F77 . #xF3F9) - (#x9F7A . #x8FEDD6) - (#x9F7D . #x8FEDD7) - (#x9F8D . #xCEB6) - (#x9F8F . #x8FEDD8) - (#x9F90 . #x8FEDD9) - (#x9F91 . #x8FEDDA) - (#x9F92 . #x8FEDDB) - (#x9F94 . #x8FEDDC) - (#x9F95 . #xF3FC) - (#x9F96 . #x8FEDDD) - (#x9F97 . #x8FEDDE) - (#x9F9C . #xF3FD) - (#x9F9D . #xE3D4) - (#x9F9E . #x8FEDDF) - (#x9FA0 . #xF3FE) - (#x9FA1 . #x8FEDE0) - (#x9FA2 . #x8FEDE1) - (#x9FA3 . #x8FEDE2) - (#x9FA5 . #x8FEDE3) - (#xFF01 . #xA1AA) - (#xFF03 . #xA1F4) - (#xFF04 . #xA1F0) - (#xFF05 . #xA1F3) - (#xFF06 . #xA1F5) - (#xFF08 . #xA1CA) - (#xFF09 . #xA1CB) - (#xFF0A . #xA1F6) - (#xFF0B . #xA1DC) - (#xFF0C . #xA1A4) - (#xFF0E . #xA1A5) - (#xFF0F . #xA1BF) - (#xFF10 . #xA3B0) - (#xFF11 . #xA3B1) - (#xFF12 . #xA3B2) - (#xFF13 . #xA3B3) - (#xFF14 . #xA3B4) - (#xFF15 . #xA3B5) - (#xFF16 . #xA3B6) - (#xFF17 . #xA3B7) - (#xFF18 . #xA3B8) - (#xFF19 . #xA3B9) - (#xFF1A . #xA1A7) - (#xFF1B . #xA1A8) - (#xFF1C . #xA1E3) - (#xFF1D . #xA1E1) - (#xFF1E . #xA1E4) - (#xFF1F . #xA1A9) - (#xFF20 . #xA1F7) - (#xFF21 . #xA3C1) - (#xFF22 . #xA3C2) - (#xFF23 . #xA3C3) - (#xFF24 . #xA3C4) - (#xFF25 . #xA3C5) - (#xFF26 . #xA3C6) - (#xFF27 . #xA3C7) - (#xFF28 . #xA3C8) - (#xFF29 . #xA3C9) - (#xFF2A . #xA3CA) - (#xFF2B . #xA3CB) - (#xFF2C . #xA3CC) - (#xFF2D . #xA3CD) - (#xFF2E . #xA3CE) - (#xFF2F . #xA3CF) - (#xFF30 . #xA3D0) - (#xFF31 . #xA3D1) - (#xFF32 . #xA3D2) - (#xFF33 . #xA3D3) - (#xFF34 . #xA3D4) - (#xFF35 . #xA3D5) - (#xFF36 . #xA3D6) - (#xFF37 . #xA3D7) - (#xFF38 . #xA3D8) - (#xFF39 . #xA3D9) - (#xFF3A . #xA3DA) - (#xFF3B . #xA1CE) - (#xFF3C . #xA1C0) - (#xFF3D . #xA1CF) - (#xFF3E . #xA1B0) - (#xFF3F . #xA1B2) - (#xFF40 . #xA1AE) - (#xFF41 . #xA3E1) - (#xFF42 . #xA3E2) - (#xFF43 . #xA3E3) - (#xFF44 . #xA3E4) - (#xFF45 . #xA3E5) - (#xFF46 . #xA3E6) - (#xFF47 . #xA3E7) - (#xFF48 . #xA3E8) - (#xFF49 . #xA3E9) - (#xFF4A . #xA3EA) - (#xFF4B . #xA3EB) - (#xFF4C . #xA3EC) - (#xFF4D . #xA3ED) - (#xFF4E . #xA3EE) - (#xFF4F . #xA3EF) - (#xFF50 . #xA3F0) - (#xFF51 . #xA3F1) - (#xFF52 . #xA3F2) - (#xFF53 . #xA3F3) - (#xFF54 . #xA3F4) - (#xFF55 . #xA3F5) - (#xFF56 . #xA3F6) - (#xFF57 . #xA3F7) - (#xFF58 . #xA3F8) - (#xFF59 . #xA3F9) - (#xFF5A . #xA3FA) - (#xFF5B . #xA1D0) - (#xFF5C . #xA1C3) - (#xFF5D . #xA1D1) - (#xFF5E . #x8FA2B7) - (#xFF61 . #x8EA1) - (#xFF62 . #x8EA2) - (#xFF63 . #x8EA3) - (#xFF64 . #x8EA4) - (#xFF65 . #x8EA5) - (#xFF66 . #x8EA6) - (#xFF67 . #x8EA7) - (#xFF68 . #x8EA8) - (#xFF69 . #x8EA9) - (#xFF6A . #x8EAA) - (#xFF6B . #x8EAB) - (#xFF6C . #x8EAC) - (#xFF6D . #x8EAD) - (#xFF6E . #x8EAE) - (#xFF6F . #x8EAF) - (#xFF70 . #x8EB0) - (#xFF71 . #x8EB1) - (#xFF72 . #x8EB2) - (#xFF73 . #x8EB3) - (#xFF74 . #x8EB4) - (#xFF75 . #x8EB5) - (#xFF76 . #x8EB6) - (#xFF77 . #x8EB7) - (#xFF78 . #x8EB8) - (#xFF79 . #x8EB9) - (#xFF7A . #x8EBA) - (#xFF7B . #x8EBB) - (#xFF7C . #x8EBC) - (#xFF7D . #x8EBD) - (#xFF7E . #x8EBE) - (#xFF7F . #x8EBF) - (#xFF80 . #x8EC0) - (#xFF81 . #x8EC1) - (#xFF82 . #x8EC2) - (#xFF83 . #x8EC3) - (#xFF84 . #x8EC4) - (#xFF85 . #x8EC5) - (#xFF86 . #x8EC6) - (#xFF87 . #x8EC7) - (#xFF88 . #x8EC8) - (#xFF89 . #x8EC9) - (#xFF8A . #x8ECA) - (#xFF8B . #x8ECB) - (#xFF8C . #x8ECC) - (#xFF8D . #x8ECD) - (#xFF8E . #x8ECE) - (#xFF8F . #x8ECF) - (#xFF90 . #x8ED0) - (#xFF91 . #x8ED1) - (#xFF92 . #x8ED2) - (#xFF93 . #x8ED3) - (#xFF94 . #x8ED4) - (#xFF95 . #x8ED5) - (#xFF96 . #x8ED6) - (#xFF97 . #x8ED7) - (#xFF98 . #x8ED8) - (#xFF99 . #x8ED9) - (#xFF9A . #x8EDA) - (#xFF9B . #x8EDB) - (#xFF9C . #x8EDC) - (#xFF9D . #x8EDD) - (#xFF9E . #x8EDE) - (#xFF9F . #x8EDF))) - (ucs->eucjp ; mono-directional table UCS -> EUC-JP - ;; some implementations convert EUC-JP into other UCS code point. - ;; - '((#x2015 . #xA1BD) - (#x2225 . #xA1C2) - (#xFF0D . #xA1DD) - (#xFFE0 . #xA1F1) - (#xFFE1 . #xA1F2) - (#xFFE2 . #xA2CC) - (#xFFE3 . #xA1B1) - (#xFFE4 . #x8FA2C3) - (#xFFE5 . #xA1EF)))) + (let ((ucs<->eucjp ; bi-directional table UCS <-> EUC-JP + ;; based on eucJP-ascii in + ;; + '((#x00A1 . #x8FA2C2) + (#x00A2 . #xA1F1) + (#x00A3 . #xA1F2) + (#x00A4 . #x8FA2F0) + (#x00A5 . #xA1EF) + (#x00A6 . #x8FA2C3) + (#x00A7 . #xA1F8) + (#x00A8 . #xA1AF) + (#x00A9 . #x8FA2ED) + (#x00AA . #x8FA2EC) + (#x00AC . #xA2CC) + (#x00AE . #x8FA2EE) + (#x00AF . #x8FA2B4) + (#x00B0 . #xA1EB) + (#x00B1 . #xA1DE) + (#x00B4 . #xA1AD) + (#x00B6 . #xA2F9) + (#x00B8 . #x8FA2B1) + (#x00BA . #x8FA2EB) + (#x00BF . #x8FA2C4) + (#x00C0 . #x8FAAA2) + (#x00C1 . #x8FAAA1) + (#x00C2 . #x8FAAA4) + (#x00C3 . #x8FAAAA) + (#x00C4 . #x8FAAA3) + (#x00C5 . #x8FAAA9) + (#x00C6 . #x8FA9A1) + (#x00C7 . #x8FAAAE) + (#x00C8 . #x8FAAB2) + (#x00C9 . #x8FAAB1) + (#x00CA . #x8FAAB4) + (#x00CB . #x8FAAB3) + (#x00CC . #x8FAAC0) + (#x00CD . #x8FAABF) + (#x00CE . #x8FAAC2) + (#x00CF . #x8FAAC1) + (#x00D1 . #x8FAAD0) + (#x00D2 . #x8FAAD2) + (#x00D3 . #x8FAAD1) + (#x00D4 . #x8FAAD4) + (#x00D5 . #x8FAAD8) + (#x00D6 . #x8FAAD3) + (#x00D7 . #xA1DF) + (#x00D8 . #x8FA9AC) + (#x00D9 . #x8FAAE3) + (#x00DA . #x8FAAE2) + (#x00DB . #x8FAAE5) + (#x00DC . #x8FAAE4) + (#x00DD . #x8FAAF2) + (#x00DE . #x8FA9B0) + (#x00DF . #x8FA9CE) + (#x00E0 . #x8FABA2) + (#x00E1 . #x8FABA1) + (#x00E2 . #x8FABA4) + (#x00E3 . #x8FABAA) + (#x00E4 . #x8FABA3) + (#x00E5 . #x8FABA9) + (#x00E6 . #x8FA9C1) + (#x00E7 . #x8FABAE) + (#x00E8 . #x8FABB2) + (#x00E9 . #x8FABB1) + (#x00EA . #x8FABB4) + (#x00EB . #x8FABB3) + (#x00EC . #x8FABC0) + (#x00ED . #x8FABBF) + (#x00EE . #x8FABC2) + (#x00EF . #x8FABC1) + (#x00F0 . #x8FA9C3) + (#x00F1 . #x8FABD0) + (#x00F2 . #x8FABD2) + (#x00F3 . #x8FABD1) + (#x00F4 . #x8FABD4) + (#x00F5 . #x8FABD8) + (#x00F6 . #x8FABD3) + (#x00F7 . #xA1E0) + (#x00F8 . #x8FA9CC) + (#x00F9 . #x8FABE3) + (#x00FA . #x8FABE2) + (#x00FB . #x8FABE5) + (#x00FC . #x8FABE4) + (#x00FD . #x8FABF2) + (#x00FE . #x8FA9D0) + (#x00FF . #x8FABF3) + (#x0100 . #x8FAAA7) + (#x0101 . #x8FABA7) + (#x0102 . #x8FAAA5) + (#x0103 . #x8FABA5) + (#x0104 . #x8FAAA8) + (#x0105 . #x8FABA8) + (#x0106 . #x8FAAAB) + (#x0107 . #x8FABAB) + (#x0108 . #x8FAAAC) + (#x0109 . #x8FABAC) + (#x010A . #x8FAAAF) + (#x010B . #x8FABAF) + (#x010C . #x8FAAAD) + (#x010D . #x8FABAD) + (#x010E . #x8FAAB0) + (#x010F . #x8FABB0) + (#x0110 . #x8FA9A2) + (#x0111 . #x8FA9C2) + (#x0112 . #x8FAAB7) + (#x0113 . #x8FABB7) + (#x0116 . #x8FAAB6) + (#x0117 . #x8FABB6) + (#x0118 . #x8FAAB8) + (#x0119 . #x8FABB8) + (#x011A . #x8FAAB5) + (#x011B . #x8FABB5) + (#x011C . #x8FAABA) + (#x011D . #x8FABBA) + (#x011E . #x8FAABB) + (#x011F . #x8FABBB) + (#x0120 . #x8FAABD) + (#x0121 . #x8FABBD) + (#x0122 . #x8FAABC) + (#x0124 . #x8FAABE) + (#x0125 . #x8FABBE) + (#x0126 . #x8FA9A4) + (#x0127 . #x8FA9C4) + (#x0128 . #x8FAAC7) + (#x0129 . #x8FABC7) + (#x012A . #x8FAAC5) + (#x012B . #x8FABC5) + (#x012E . #x8FAAC6) + (#x012F . #x8FABC6) + (#x0130 . #x8FAAC4) + (#x0131 . #x8FA9C5) + (#x0132 . #x8FA9A6) + (#x0133 . #x8FA9C6) + (#x0134 . #x8FAAC8) + (#x0135 . #x8FABC8) + (#x0136 . #x8FAAC9) + (#x0137 . #x8FABC9) + (#x0138 . #x8FA9C7) + (#x0139 . #x8FAACA) + (#x013A . #x8FABCA) + (#x013B . #x8FAACC) + (#x013C . #x8FABCC) + (#x013D . #x8FAACB) + (#x013E . #x8FABCB) + (#x013F . #x8FA9A9) + (#x0140 . #x8FA9C9) + (#x0141 . #x8FA9A8) + (#x0142 . #x8FA9C8) + (#x0143 . #x8FAACD) + (#x0144 . #x8FABCD) + (#x0145 . #x8FAACF) + (#x0146 . #x8FABCF) + (#x0147 . #x8FAACE) + (#x0148 . #x8FABCE) + (#x0149 . #x8FA9CA) + (#x014A . #x8FA9AB) + (#x014B . #x8FA9CB) + (#x014C . #x8FAAD7) + (#x014D . #x8FABD7) + (#x0150 . #x8FAAD6) + (#x0151 . #x8FABD6) + (#x0152 . #x8FA9AD) + (#x0153 . #x8FA9CD) + (#x0154 . #x8FAAD9) + (#x0155 . #x8FABD9) + (#x0156 . #x8FAADB) + (#x0157 . #x8FABDB) + (#x0158 . #x8FAADA) + (#x0159 . #x8FABDA) + (#x015A . #x8FAADC) + (#x015B . #x8FABDC) + (#x015C . #x8FAADD) + (#x015D . #x8FABDD) + (#x015E . #x8FAADF) + (#x015F . #x8FABDF) + (#x0160 . #x8FAADE) + (#x0161 . #x8FABDE) + (#x0162 . #x8FAAE1) + (#x0163 . #x8FABE1) + (#x0164 . #x8FAAE0) + (#x0165 . #x8FABE0) + (#x0166 . #x8FA9AF) + (#x0167 . #x8FA9CF) + (#x0168 . #x8FAAEC) + (#x0169 . #x8FABEC) + (#x016A . #x8FAAE9) + (#x016B . #x8FABE9) + (#x016C . #x8FAAE6) + (#x016D . #x8FABE6) + (#x016E . #x8FAAEB) + (#x016F . #x8FABEB) + (#x0170 . #x8FAAE8) + (#x0171 . #x8FABE8) + (#x0172 . #x8FAAEA) + (#x0173 . #x8FABEA) + (#x0174 . #x8FAAF1) + (#x0175 . #x8FABF1) + (#x0176 . #x8FAAF4) + (#x0177 . #x8FABF4) + (#x0178 . #x8FAAF3) + (#x0179 . #x8FAAF5) + (#x017A . #x8FABF5) + (#x017B . #x8FAAF7) + (#x017C . #x8FABF7) + (#x017D . #x8FAAF6) + (#x017E . #x8FABF6) + (#x01CD . #x8FAAA6) + (#x01CE . #x8FABA6) + (#x01CF . #x8FAAC3) + (#x01D0 . #x8FABC3) + (#x01D1 . #x8FAAD5) + (#x01D2 . #x8FABD5) + (#x01D3 . #x8FAAE7) + (#x01D4 . #x8FABE7) + (#x01D5 . #x8FAAF0) + (#x01D6 . #x8FABF0) + (#x01D7 . #x8FAAED) + (#x01D8 . #x8FABED) + (#x01D9 . #x8FAAEF) + (#x01DA . #x8FABEF) + (#x01DB . #x8FAAEE) + (#x01DC . #x8FABEE) + (#x01F5 . #x8FABB9) + (#x02C7 . #x8FA2B0) + (#x02D8 . #x8FA2AF) + (#x02D9 . #x8FA2B2) + (#x02DA . #x8FA2B6) + (#x02DB . #x8FA2B5) + (#x02DD . #x8FA2B3) + (#x0384 . #x8FA2B8) + (#x0385 . #x8FA2B9) + (#x0386 . #x8FA6E1) + (#x0388 . #x8FA6E2) + (#x0389 . #x8FA6E3) + (#x038A . #x8FA6E4) + (#x038C . #x8FA6E7) + (#x038E . #x8FA6E9) + (#x038F . #x8FA6EC) + (#x0390 . #x8FA6F6) + (#x0391 . #xA6A1) + (#x0392 . #xA6A2) + (#x0393 . #xA6A3) + (#x0394 . #xA6A4) + (#x0395 . #xA6A5) + (#x0396 . #xA6A6) + (#x0397 . #xA6A7) + (#x0398 . #xA6A8) + (#x0399 . #xA6A9) + (#x039A . #xA6AA) + (#x039B . #xA6AB) + (#x039C . #xA6AC) + (#x039D . #xA6AD) + (#x039E . #xA6AE) + (#x039F . #xA6AF) + (#x03A0 . #xA6B0) + (#x03A1 . #xA6B1) + (#x03A3 . #xA6B2) + (#x03A4 . #xA6B3) + (#x03A5 . #xA6B4) + (#x03A6 . #xA6B5) + (#x03A7 . #xA6B6) + (#x03A8 . #xA6B7) + (#x03A9 . #xA6B8) + (#x03AA . #x8FA6E5) + (#x03AB . #x8FA6EA) + (#x03AC . #x8FA6F1) + (#x03AD . #x8FA6F2) + (#x03AE . #x8FA6F3) + (#x03AF . #x8FA6F4) + (#x03B0 . #x8FA6FB) + (#x03B1 . #xA6C1) + (#x03B2 . #xA6C2) + (#x03B3 . #xA6C3) + (#x03B4 . #xA6C4) + (#x03B5 . #xA6C5) + (#x03B6 . #xA6C6) + (#x03B7 . #xA6C7) + (#x03B8 . #xA6C8) + (#x03B9 . #xA6C9) + (#x03BA . #xA6CA) + (#x03BB . #xA6CB) + (#x03BC . #xA6CC) + (#x03BD . #xA6CD) + (#x03BE . #xA6CE) + (#x03BF . #xA6CF) + (#x03C0 . #xA6D0) + (#x03C1 . #xA6D1) + (#x03C2 . #x8FA6F8) + (#x03C3 . #xA6D2) + (#x03C4 . #xA6D3) + (#x03C5 . #xA6D4) + (#x03C6 . #xA6D5) + (#x03C7 . #xA6D6) + (#x03C8 . #xA6D7) + (#x03C9 . #xA6D8) + (#x03CA . #x8FA6F5) + (#x03CB . #x8FA6FA) + (#x03CC . #x8FA6F7) + (#x03CD . #x8FA6F9) + (#x03CE . #x8FA6FC) + (#x0401 . #xA7A7) + (#x0402 . #x8FA7C2) + (#x0403 . #x8FA7C3) + (#x0404 . #x8FA7C4) + (#x0405 . #x8FA7C5) + (#x0406 . #x8FA7C6) + (#x0407 . #x8FA7C7) + (#x0408 . #x8FA7C8) + (#x0409 . #x8FA7C9) + (#x040A . #x8FA7CA) + (#x040B . #x8FA7CB) + (#x040C . #x8FA7CC) + (#x040E . #x8FA7CD) + (#x040F . #x8FA7CE) + (#x0410 . #xA7A1) + (#x0411 . #xA7A2) + (#x0412 . #xA7A3) + (#x0413 . #xA7A4) + (#x0414 . #xA7A5) + (#x0415 . #xA7A6) + (#x0416 . #xA7A8) + (#x0417 . #xA7A9) + (#x0418 . #xA7AA) + (#x0419 . #xA7AB) + (#x041A . #xA7AC) + (#x041B . #xA7AD) + (#x041C . #xA7AE) + (#x041D . #xA7AF) + (#x041E . #xA7B0) + (#x041F . #xA7B1) + (#x0420 . #xA7B2) + (#x0421 . #xA7B3) + (#x0422 . #xA7B4) + (#x0423 . #xA7B5) + (#x0424 . #xA7B6) + (#x0425 . #xA7B7) + (#x0426 . #xA7B8) + (#x0427 . #xA7B9) + (#x0428 . #xA7BA) + (#x0429 . #xA7BB) + (#x042A . #xA7BC) + (#x042B . #xA7BD) + (#x042C . #xA7BE) + (#x042D . #xA7BF) + (#x042E . #xA7C0) + (#x042F . #xA7C1) + (#x0430 . #xA7D1) + (#x0431 . #xA7D2) + (#x0432 . #xA7D3) + (#x0433 . #xA7D4) + (#x0434 . #xA7D5) + (#x0435 . #xA7D6) + (#x0436 . #xA7D8) + (#x0437 . #xA7D9) + (#x0438 . #xA7DA) + (#x0439 . #xA7DB) + (#x043A . #xA7DC) + (#x043B . #xA7DD) + (#x043C . #xA7DE) + (#x043D . #xA7DF) + (#x043E . #xA7E0) + (#x043F . #xA7E1) + (#x0440 . #xA7E2) + (#x0441 . #xA7E3) + (#x0442 . #xA7E4) + (#x0443 . #xA7E5) + (#x0444 . #xA7E6) + (#x0445 . #xA7E7) + (#x0446 . #xA7E8) + (#x0447 . #xA7E9) + (#x0448 . #xA7EA) + (#x0449 . #xA7EB) + (#x044A . #xA7EC) + (#x044B . #xA7ED) + (#x044C . #xA7EE) + (#x044D . #xA7EF) + (#x044E . #xA7F0) + (#x044F . #xA7F1) + (#x0451 . #xA7D7) + (#x0452 . #x8FA7F2) + (#x0453 . #x8FA7F3) + (#x0454 . #x8FA7F4) + (#x0455 . #x8FA7F5) + (#x0456 . #x8FA7F6) + (#x0457 . #x8FA7F7) + (#x0458 . #x8FA7F8) + (#x0459 . #x8FA7F9) + (#x045A . #x8FA7FA) + (#x045B . #x8FA7FB) + (#x045C . #x8FA7FC) + (#x045E . #x8FA7FD) + (#x045F . #x8FA7FE) + (#x2010 . #xA1BE) + (#x2014 . #xA1BD) + (#x2016 . #xA1C2) + (#x2018 . #xA1C6) + (#x2019 . #xA1C7) + (#x201C . #xA1C8) + (#x201D . #xA1C9) + (#x2020 . #xA2F7) + (#x2021 . #xA2F8) + (#x2025 . #xA1C5) + (#x2026 . #xA1C4) + (#x2030 . #xA2F3) + (#x2032 . #xA1EC) + (#x2033 . #xA1ED) + (#x203B . #xA2A8) + (#x203E . #xA1B1) + (#x2103 . #xA1EE) + (#x2116 . #x8FA2F1) + (#x2122 . #x8FA2EF) + (#x212B . #xA2F2) + (#x2190 . #xA2AB) + (#x2191 . #xA2AC) + (#x2192 . #xA2AA) + (#x2193 . #xA2AD) + (#x21D2 . #xA2CD) + (#x21D4 . #xA2CE) + (#x2200 . #xA2CF) + (#x2202 . #xA2DF) + (#x2203 . #xA2D0) + (#x2207 . #xA2E0) + (#x2208 . #xA2BA) + (#x220B . #xA2BB) + (#x2212 . #xA1DD) + (#x221A . #xA2E5) + (#x221D . #xA2E7) + (#x221E . #xA1E7) + (#x2220 . #xA2DC) + (#x2227 . #xA2CA) + (#x2228 . #xA2CB) + (#x2229 . #xA2C1) + (#x222A . #xA2C0) + (#x222B . #xA2E9) + (#x222C . #xA2EA) + (#x2234 . #xA1E8) + (#x2235 . #xA2E8) + (#x223D . #xA2E6) + (#x2252 . #xA2E2) + (#x2260 . #xA1E2) + (#x2261 . #xA2E1) + (#x2266 . #xA1E5) + (#x2267 . #xA1E6) + (#x226A . #xA2E3) + (#x226B . #xA2E4) + (#x2282 . #xA2BE) + (#x2283 . #xA2BF) + (#x2286 . #xA2BC) + (#x2287 . #xA2BD) + (#x22A5 . #xA2DD) + (#x2312 . #xA2DE) + (#x2500 . #xA8A1) + (#x2501 . #xA8AC) + (#x2502 . #xA8A2) + (#x2503 . #xA8AD) + (#x250C . #xA8A3) + (#x250F . #xA8AE) + (#x2510 . #xA8A4) + (#x2513 . #xA8AF) + (#x2514 . #xA8A6) + (#x2517 . #xA8B1) + (#x2518 . #xA8A5) + (#x251B . #xA8B0) + (#x251C . #xA8A7) + (#x251D . #xA8BC) + (#x2520 . #xA8B7) + (#x2523 . #xA8B2) + (#x2524 . #xA8A9) + (#x2525 . #xA8BE) + (#x2528 . #xA8B9) + (#x252B . #xA8B4) + (#x252C . #xA8A8) + (#x252F . #xA8B8) + (#x2530 . #xA8BD) + (#x2533 . #xA8B3) + (#x2534 . #xA8AA) + (#x2537 . #xA8BA) + (#x2538 . #xA8BF) + (#x253B . #xA8B5) + (#x253C . #xA8AB) + (#x253F . #xA8BB) + (#x2542 . #xA8C0) + (#x254B . #xA8B6) + (#x25A0 . #xA2A3) + (#x25A1 . #xA2A2) + (#x25B2 . #xA2A5) + (#x25B3 . #xA2A4) + (#x25BC . #xA2A7) + (#x25BD . #xA2A6) + (#x25C6 . #xA2A1) + (#x25C7 . #xA1FE) + (#x25CB . #xA1FB) + (#x25CE . #xA1FD) + (#x25CF . #xA1FC) + (#x25EF . #xA2FE) + (#x2605 . #xA1FA) + (#x2606 . #xA1F9) + (#x2640 . #xA1EA) + (#x2642 . #xA1E9) + (#x266A . #xA2F6) + (#x266D . #xA2F5) + (#x266F . #xA2F4) + (#x3000 . #xA1A1) + (#x3001 . #xA1A2) + (#x3002 . #xA1A3) + (#x3003 . #xA1B7) + (#x3005 . #xA1B9) + (#x3006 . #xA1BA) + (#x3007 . #xA1BB) + (#x3008 . #xA1D2) + (#x3009 . #xA1D3) + (#x300A . #xA1D4) + (#x300B . #xA1D5) + (#x300C . #xA1D6) + (#x300D . #xA1D7) + (#x300E . #xA1D8) + (#x300F . #xA1D9) + (#x3010 . #xA1DA) + (#x3011 . #xA1DB) + (#x3012 . #xA2A9) + (#x3013 . #xA2AE) + (#x3014 . #xA1CC) + (#x3015 . #xA1CD) + (#x301C . #xA1C1) + (#x3041 . #xA4A1) + (#x3042 . #xA4A2) + (#x3043 . #xA4A3) + (#x3044 . #xA4A4) + (#x3045 . #xA4A5) + (#x3046 . #xA4A6) + (#x3047 . #xA4A7) + (#x3048 . #xA4A8) + (#x3049 . #xA4A9) + (#x304A . #xA4AA) + (#x304B . #xA4AB) + (#x304C . #xA4AC) + (#x304D . #xA4AD) + (#x304E . #xA4AE) + (#x304F . #xA4AF) + (#x3050 . #xA4B0) + (#x3051 . #xA4B1) + (#x3052 . #xA4B2) + (#x3053 . #xA4B3) + (#x3054 . #xA4B4) + (#x3055 . #xA4B5) + (#x3056 . #xA4B6) + (#x3057 . #xA4B7) + (#x3058 . #xA4B8) + (#x3059 . #xA4B9) + (#x305A . #xA4BA) + (#x305B . #xA4BB) + (#x305C . #xA4BC) + (#x305D . #xA4BD) + (#x305E . #xA4BE) + (#x305F . #xA4BF) + (#x3060 . #xA4C0) + (#x3061 . #xA4C1) + (#x3062 . #xA4C2) + (#x3063 . #xA4C3) + (#x3064 . #xA4C4) + (#x3065 . #xA4C5) + (#x3066 . #xA4C6) + (#x3067 . #xA4C7) + (#x3068 . #xA4C8) + (#x3069 . #xA4C9) + (#x306A . #xA4CA) + (#x306B . #xA4CB) + (#x306C . #xA4CC) + (#x306D . #xA4CD) + (#x306E . #xA4CE) + (#x306F . #xA4CF) + (#x3070 . #xA4D0) + (#x3071 . #xA4D1) + (#x3072 . #xA4D2) + (#x3073 . #xA4D3) + (#x3074 . #xA4D4) + (#x3075 . #xA4D5) + (#x3076 . #xA4D6) + (#x3077 . #xA4D7) + (#x3078 . #xA4D8) + (#x3079 . #xA4D9) + (#x307A . #xA4DA) + (#x307B . #xA4DB) + (#x307C . #xA4DC) + (#x307D . #xA4DD) + (#x307E . #xA4DE) + (#x307F . #xA4DF) + (#x3080 . #xA4E0) + (#x3081 . #xA4E1) + (#x3082 . #xA4E2) + (#x3083 . #xA4E3) + (#x3084 . #xA4E4) + (#x3085 . #xA4E5) + (#x3086 . #xA4E6) + (#x3087 . #xA4E7) + (#x3088 . #xA4E8) + (#x3089 . #xA4E9) + (#x308A . #xA4EA) + (#x308B . #xA4EB) + (#x308C . #xA4EC) + (#x308D . #xA4ED) + (#x308E . #xA4EE) + (#x308F . #xA4EF) + (#x3090 . #xA4F0) + (#x3091 . #xA4F1) + (#x3092 . #xA4F2) + (#x3093 . #xA4F3) + (#x309B . #xA1AB) + (#x309C . #xA1AC) + (#x309D . #xA1B5) + (#x309E . #xA1B6) + (#x30A1 . #xA5A1) + (#x30A2 . #xA5A2) + (#x30A3 . #xA5A3) + (#x30A4 . #xA5A4) + (#x30A5 . #xA5A5) + (#x30A6 . #xA5A6) + (#x30A7 . #xA5A7) + (#x30A8 . #xA5A8) + (#x30A9 . #xA5A9) + (#x30AA . #xA5AA) + (#x30AB . #xA5AB) + (#x30AC . #xA5AC) + (#x30AD . #xA5AD) + (#x30AE . #xA5AE) + (#x30AF . #xA5AF) + (#x30B0 . #xA5B0) + (#x30B1 . #xA5B1) + (#x30B2 . #xA5B2) + (#x30B3 . #xA5B3) + (#x30B4 . #xA5B4) + (#x30B5 . #xA5B5) + (#x30B6 . #xA5B6) + (#x30B7 . #xA5B7) + (#x30B8 . #xA5B8) + (#x30B9 . #xA5B9) + (#x30BA . #xA5BA) + (#x30BB . #xA5BB) + (#x30BC . #xA5BC) + (#x30BD . #xA5BD) + (#x30BE . #xA5BE) + (#x30BF . #xA5BF) + (#x30C0 . #xA5C0) + (#x30C1 . #xA5C1) + (#x30C2 . #xA5C2) + (#x30C3 . #xA5C3) + (#x30C4 . #xA5C4) + (#x30C5 . #xA5C5) + (#x30C6 . #xA5C6) + (#x30C7 . #xA5C7) + (#x30C8 . #xA5C8) + (#x30C9 . #xA5C9) + (#x30CA . #xA5CA) + (#x30CB . #xA5CB) + (#x30CC . #xA5CC) + (#x30CD . #xA5CD) + (#x30CE . #xA5CE) + (#x30CF . #xA5CF) + (#x30D0 . #xA5D0) + (#x30D1 . #xA5D1) + (#x30D2 . #xA5D2) + (#x30D3 . #xA5D3) + (#x30D4 . #xA5D4) + (#x30D5 . #xA5D5) + (#x30D6 . #xA5D6) + (#x30D7 . #xA5D7) + (#x30D8 . #xA5D8) + (#x30D9 . #xA5D9) + (#x30DA . #xA5DA) + (#x30DB . #xA5DB) + (#x30DC . #xA5DC) + (#x30DD . #xA5DD) + (#x30DE . #xA5DE) + (#x30DF . #xA5DF) + (#x30E0 . #xA5E0) + (#x30E1 . #xA5E1) + (#x30E2 . #xA5E2) + (#x30E3 . #xA5E3) + (#x30E4 . #xA5E4) + (#x30E5 . #xA5E5) + (#x30E6 . #xA5E6) + (#x30E7 . #xA5E7) + (#x30E8 . #xA5E8) + (#x30E9 . #xA5E9) + (#x30EA . #xA5EA) + (#x30EB . #xA5EB) + (#x30EC . #xA5EC) + (#x30ED . #xA5ED) + (#x30EE . #xA5EE) + (#x30EF . #xA5EF) + (#x30F0 . #xA5F0) + (#x30F1 . #xA5F1) + (#x30F2 . #xA5F2) + (#x30F3 . #xA5F3) + (#x30F4 . #xA5F4) + (#x30F5 . #xA5F5) + (#x30F6 . #xA5F6) + (#x30FB . #xA1A6) + (#x30FC . #xA1BC) + (#x30FD . #xA1B3) + (#x30FE . #xA1B4) + (#x4E00 . #xB0EC) + (#x4E01 . #xC3FA) + (#x4E02 . #x8FB0A1) + (#x4E03 . #xBCB7) + (#x4E04 . #x8FB0A2) + (#x4E05 . #x8FB0A3) + (#x4E07 . #xCBFC) + (#x4E08 . #xBEE6) + (#x4E09 . #xBBB0) + (#x4E0A . #xBEE5) + (#x4E0B . #xB2BC) + (#x4E0C . #x8FB0A4) + (#x4E0D . #xC9D4) + (#x4E0E . #xCDBF) + (#x4E10 . #xD0A2) + (#x4E11 . #xB1AF) + (#x4E12 . #x8FB0A5) + (#x4E14 . #xB3EE) + (#x4E15 . #xD0A3) + (#x4E16 . #xC0A4) + (#x4E17 . #xD2C2) + (#x4E18 . #xB5D6) + (#x4E19 . #xCABA) + (#x4E1E . #xBEE7) + (#x4E1F . #x8FB0A6) + (#x4E21 . #xCEBE) + (#x4E23 . #x8FB0A7) + (#x4E24 . #x8FB0A8) + (#x4E26 . #xCAC2) + (#x4E28 . #x8FB0A9) + (#x4E2A . #xD0A4) + (#x4E2B . #x8FB0AA) + (#x4E2D . #xC3E6) + (#x4E2E . #x8FB0AB) + (#x4E2F . #x8FB0AC) + (#x4E30 . #x8FB0AD) + (#x4E31 . #xD0A5) + (#x4E32 . #xB6FA) + (#x4E35 . #x8FB0AE) + (#x4E36 . #xD0A6) + (#x4E38 . #xB4DD) + (#x4E39 . #xC3B0) + (#x4E3B . #xBCE7) + (#x4E3C . #xD0A7) + (#x4E3F . #xD0A8) + (#x4E40 . #x8FB0AF) + (#x4E41 . #x8FB0B0) + (#x4E42 . #xD0A9) + (#x4E43 . #xC7B5) + (#x4E44 . #x8FB0B1) + (#x4E45 . #xB5D7) + (#x4E47 . #x8FB0B2) + (#x4E4B . #xC7B7) + (#x4E4D . #xC6E3) + (#x4E4E . #xB8C3) + (#x4E4F . #xCBB3) + (#x4E51 . #x8FB0B3) + (#x4E55 . #xE9C9) + (#x4E56 . #xD0AA) + (#x4E57 . #xBEE8) + (#x4E58 . #xD0AB) + (#x4E59 . #xB2B5) + (#x4E5A . #x8FB0B4) + (#x4E5C . #x8FB0B5) + (#x4E5D . #xB6E5) + (#x4E5E . #xB8F0) + (#x4E5F . #xCCE9) + (#x4E62 . #xD6A6) + (#x4E63 . #x8FB0B6) + (#x4E68 . #x8FB0B7) + (#x4E69 . #x8FB0B8) + (#x4E71 . #xCDF0) + (#x4E73 . #xC6FD) + (#x4E74 . #x8FB0B9) + (#x4E75 . #x8FB0BA) + (#x4E79 . #x8FB0BB) + (#x4E7E . #xB4A5) + (#x4E7F . #x8FB0BC) + (#x4E80 . #xB5B5) + (#x4E82 . #xD0AC) + (#x4E85 . #xD0AD) + (#x4E86 . #xCEBB) + (#x4E88 . #xCDBD) + (#x4E89 . #xC1E8) + (#x4E8A . #xD0AF) + (#x4E8B . #xBBF6) + (#x4E8C . #xC6F3) + (#x4E8D . #x8FB0BD) + (#x4E8E . #xD0B2) + (#x4E91 . #xB1BE) + (#x4E92 . #xB8DF) + (#x4E94 . #xB8DE) + (#x4E95 . #xB0E6) + (#x4E96 . #x8FB0BE) + (#x4E97 . #x8FB0BF) + (#x4E98 . #xCFCB) + (#x4E99 . #xCFCA) + (#x4E9B . #xBAB3) + (#x4E9C . #xB0A1) + (#x4E9D . #x8FB0C0) + (#x4E9E . #xD0B3) + (#x4E9F . #xD0B4) + (#x4EA0 . #xD0B5) + (#x4EA1 . #xCBB4) + (#x4EA2 . #xD0B6) + (#x4EA4 . #xB8F2) + (#x4EA5 . #xB0E7) + (#x4EA6 . #xCBF2) + (#x4EA8 . #xB5FC) + (#x4EAB . #xB5FD) + (#x4EAC . #xB5FE) + (#x4EAD . #xC4E2) + (#x4EAE . #xCEBC) + (#x4EAF . #x8FB0C1) + (#x4EB0 . #xD0B7) + (#x4EB3 . #xD0B8) + (#x4EB6 . #xD0B9) + (#x4EB9 . #x8FB0C2) + (#x4EBA . #xBFCD) + (#x4EC0 . #xBDBA) + (#x4EC1 . #xBFCE) + (#x4EC2 . #xD0BE) + (#x4EC3 . #x8FB0C3) + (#x4EC4 . #xD0BC) + (#x4EC6 . #xD0BD) + (#x4EC7 . #xB5D8) + (#x4ECA . #xBAA3) + (#x4ECB . #xB2F0) + (#x4ECD . #xD0BB) + (#x4ECE . #xD0BA) + (#x4ECF . #xCAA9) + (#x4ED0 . #x8FB0C4) + (#x4ED4 . #xBBC6) + (#x4ED5 . #xBBC5) + (#x4ED6 . #xC2BE) + (#x4ED7 . #xD0BF) + (#x4ED8 . #xC9D5) + (#x4ED9 . #xC0E7) + (#x4EDA . #x8FB0C5) + (#x4EDB . #x8FB0C6) + (#x4EDD . #xA1B8) + (#x4EDE . #xD0C0) + (#x4EDF . #xD0C2) + (#x4EE0 . #x8FB0C7) + (#x4EE1 . #x8FB0C8) + (#x4EE2 . #x8FB0C9) + (#x4EE3 . #xC2E5) + (#x4EE4 . #xCEE1) + (#x4EE5 . #xB0CA) + (#x4EE8 . #x8FB0CA) + (#x4EED . #xD0C1) + (#x4EEE . #xB2BE) + (#x4EEF . #x8FB0CB) + (#x4EF0 . #xB6C4) + (#x4EF1 . #x8FB0CC) + (#x4EF2 . #xC3E7) + (#x4EF3 . #x8FB0CD) + (#x4EF5 . #x8FB0CE) + (#x4EF6 . #xB7EF) + (#x4EF7 . #xD0C3) + (#x4EFB . #xC7A4) + (#x4EFD . #x8FB0CF) + (#x4EFE . #x8FB0D0) + (#x4EFF . #x8FB0D1) + (#x4F00 . #x8FB0D2) + (#x4F01 . #xB4EB) + (#x4F02 . #x8FB0D3) + (#x4F03 . #x8FB0D4) + (#x4F08 . #x8FB0D5) + (#x4F09 . #xD0C4) + (#x4F0A . #xB0CB) + (#x4F0B . #x8FB0D6) + (#x4F0C . #x8FB0D7) + (#x4F0D . #xB8E0) + (#x4F0E . #xB4EC) + (#x4F0F . #xC9FA) + (#x4F10 . #xC8B2) + (#x4F11 . #xB5D9) + (#x4F12 . #x8FB0D8) + (#x4F15 . #x8FB0D9) + (#x4F16 . #x8FB0DA) + (#x4F17 . #x8FB0DB) + (#x4F19 . #x8FB0DC) + (#x4F1A . #xB2F1) + (#x4F1C . #xD0E7) + (#x4F1D . #xC5C1) + (#x4F2E . #x8FB0DD) + (#x4F2F . #xC7EC) + (#x4F30 . #xD0C6) + (#x4F31 . #x8FB0DE) + (#x4F33 . #x8FB0E0) + (#x4F34 . #xC8BC) + (#x4F35 . #x8FB0E1) + (#x4F36 . #xCEE2) + (#x4F37 . #x8FB0E2) + (#x4F38 . #xBFAD) + (#x4F39 . #x8FB0E3) + (#x4F3A . #xBBC7) + (#x4F3B . #x8FB0E4) + (#x4F3C . #xBBF7) + (#x4F3D . #xB2C0) + (#x4F3E . #x8FB0E5) + (#x4F40 . #x8FB0E6) + (#x4F42 . #x8FB0E7) + (#x4F43 . #xC4D1) + (#x4F46 . #xC3A2) + (#x4F47 . #xD0CA) + (#x4F48 . #x8FB0E8) + (#x4F49 . #x8FB0E9) + (#x4F4B . #x8FB0EA) + (#x4F4C . #x8FB0EB) + (#x4F4D . #xB0CC) + (#x4F4E . #xC4E3) + (#x4F4F . #xBDBB) + (#x4F50 . #xBAB4) + (#x4F51 . #xCDA4) + (#x4F52 . #x8FB0EC) + (#x4F53 . #xC2CE) + (#x4F54 . #x8FB0ED) + (#x4F55 . #xB2BF) + (#x4F56 . #x8FB0EE) + (#x4F57 . #xD0C9) + (#x4F58 . #x8FB0EF) + (#x4F59 . #xCDBE) + (#x4F5A . #xD0C5) + (#x4F5B . #xD0C7) + (#x4F5C . #xBAEE) + (#x4F5D . #xD0C8) + (#x4F5E . #xD5A4) + (#x4F5F . #x8FB0F0) + (#x4F60 . #x8FB0DF) + (#x4F63 . #x8FB0F1) + (#x4F69 . #xD0D0) + (#x4F6A . #x8FB0F2) + (#x4F6C . #x8FB0F3) + (#x4F6E . #x8FB0F4) + (#x4F6F . #xD0D3) + (#x4F70 . #xD0D1) + (#x4F71 . #x8FB0F5) + (#x4F73 . #xB2C2) + (#x4F75 . #xCABB) + (#x4F76 . #xD0CB) + (#x4F77 . #x8FB0F6) + (#x4F78 . #x8FB0F7) + (#x4F79 . #x8FB0F8) + (#x4F7A . #x8FB0F9) + (#x4F7B . #xD0CF) + (#x4F7C . #xB8F3) + (#x4F7D . #x8FB0FA) + (#x4F7E . #x8FB0FB) + (#x4F7F . #xBBC8) + (#x4F81 . #x8FB0FC) + (#x4F82 . #x8FB0FD) + (#x4F83 . #xB4A6) + (#x4F84 . #x8FB0FE) + (#x4F85 . #x8FB1A1) + (#x4F86 . #xD0D4) + (#x4F88 . #xD0CC) + (#x4F89 . #x8FB1A2) + (#x4F8A . #x8FB1A3) + (#x4F8B . #xCEE3) + (#x4F8C . #x8FB1A4) + (#x4F8D . #xBBF8) + (#x4F8E . #x8FB1A5) + (#x4F8F . #xD0CD) + (#x4F90 . #x8FB1A6) + (#x4F91 . #xD0D2) + (#x4F92 . #x8FB1A7) + (#x4F93 . #x8FB1A8) + (#x4F94 . #x8FB1A9) + (#x4F96 . #xD0D5) + (#x4F97 . #x8FB1AA) + (#x4F98 . #xD0CE) + (#x4F99 . #x8FB1AB) + (#x4F9A . #x8FB1AC) + (#x4F9B . #xB6A1) + (#x4F9D . #xB0CD) + (#x4F9E . #x8FB1AD) + (#x4F9F . #x8FB1AE) + (#x4FA0 . #xB6A2) + (#x4FA1 . #xB2C1) + (#x4FAB . #xD5A5) + (#x4FAD . #xCBF9) + (#x4FAE . #xC9EE) + (#x4FAF . #xB8F4) + (#x4FB2 . #x8FB1AF) + (#x4FB5 . #xBFAF) + (#x4FB6 . #xCEB7) + (#x4FB7 . #x8FB1B0) + (#x4FB9 . #x8FB1B1) + (#x4FBB . #x8FB1B2) + (#x4FBC . #x8FB1B3) + (#x4FBD . #x8FB1B4) + (#x4FBE . #x8FB1B5) + (#x4FBF . #xCAD8) + (#x4FC0 . #x8FB1B6) + (#x4FC1 . #x8FB1B7) + (#x4FC2 . #xB7B8) + (#x4FC3 . #xC2A5) + (#x4FC4 . #xB2E4) + (#x4FC5 . #x8FB1B8) + (#x4FC6 . #x8FB1B9) + (#x4FC8 . #x8FB1BA) + (#x4FC9 . #x8FB1BB) + (#x4FCA . #xBDD3) + (#x4FCB . #x8FB1BC) + (#x4FCC . #x8FB1BD) + (#x4FCD . #x8FB1BE) + (#x4FCE . #xD0D9) + (#x4FCF . #x8FB1BF) + (#x4FD0 . #xD0DE) + (#x4FD1 . #xD0DC) + (#x4FD2 . #x8FB1C0) + (#x4FD4 . #xD0D7) + (#x4FD7 . #xC2AF) + (#x4FD8 . #xD0DA) + (#x4FDA . #xD0DD) + (#x4FDB . #xD0DB) + (#x4FDC . #x8FB1C1) + (#x4FDD . #xCADD) + (#x4FDF . #xD0D8) + (#x4FE0 . #x8FB1C2) + (#x4FE1 . #xBFAE) + (#x4FE2 . #x8FB1C3) + (#x4FE3 . #xCBF3) + (#x4FE4 . #xD0DF) + (#x4FE5 . #xD0E0) + (#x4FEE . #xBDA4) + (#x4FEF . #xD0ED) + (#x4FF0 . #x8FB1C4) + (#x4FF2 . #x8FB1C5) + (#x4FF3 . #xC7D0) + (#x4FF5 . #xC9B6) + (#x4FF6 . #xD0E8) + (#x4FF8 . #xCAF0) + (#x4FFA . #xB2B6) + (#x4FFC . #x8FB1C6) + (#x4FFD . #x8FB1C7) + (#x4FFE . #xD0EC) + (#x4FFF . #x8FB1C8) + (#x5000 . #x8FB1C9) + (#x5001 . #x8FB1CA) + (#x5004 . #x8FB1CB) + (#x5005 . #xD0E6) + (#x5006 . #xD0EF) + (#x5007 . #x8FB1CC) + (#x5009 . #xC1D2) + (#x500A . #x8FB1CD) + (#x500B . #xB8C4) + (#x500C . #x8FB1CE) + (#x500D . #xC7DC) + (#x500E . #x8FB1CF) + (#x500F . #xE0C7) + (#x5010 . #x8FB1D0) + (#x5011 . #xD0EE) + (#x5012 . #xC5DD) + (#x5013 . #x8FB1D1) + (#x5014 . #xD0E3) + (#x5016 . #xB8F6) + (#x5017 . #x8FB1D2) + (#x5018 . #x8FB1D3) + (#x5019 . #xB8F5) + (#x501A . #xD0E1) + (#x501B . #x8FB1D4) + (#x501C . #x8FB1D5) + (#x501D . #x8FB1D6) + (#x501E . #x8FB1D7) + (#x501F . #xBCDA) + (#x5021 . #xD0E9) + (#x5022 . #x8FB1D8) + (#x5023 . #xCAEF) + (#x5024 . #xC3CD) + (#x5025 . #xD0E5) + (#x5026 . #xB7F1) + (#x5027 . #x8FB1D9) + (#x5028 . #xD0E2) + (#x5029 . #xD0EA) + (#x502A . #xD0E4) + (#x502B . #xCED1) + (#x502C . #xD0EB) + (#x502D . #xCFC1) + (#x502E . #x8FB1DA) + (#x5030 . #x8FB1DB) + (#x5032 . #x8FB1DC) + (#x5033 . #x8FB1DD) + (#x5035 . #x8FB1DE) + (#x5036 . #xB6E6) + (#x5039 . #xB7F0) + (#x503B . #x8FB1F6) + (#x5040 . #x8FB1DF) + (#x5041 . #x8FB1E0) + (#x5042 . #x8FB1E1) + (#x5043 . #xD0F0) + (#x5045 . #x8FB1E2) + (#x5046 . #x8FB1E3) + (#x5047 . #xD0F1) + (#x5048 . #xD0F5) + (#x5049 . #xB0CE) + (#x504A . #x8FB1E4) + (#x504C . #x8FB1E5) + (#x504E . #x8FB1E6) + (#x504F . #xCAD0) + (#x5050 . #xD0F4) + (#x5051 . #x8FB1E7) + (#x5052 . #x8FB1E8) + (#x5053 . #x8FB1E9) + (#x5055 . #xD0F3) + (#x5056 . #xD0F7) + (#x5057 . #x8FB1EA) + (#x5059 . #x8FB1EB) + (#x505A . #xD0F6) + (#x505C . #xC4E4) + (#x505F . #x8FB1EC) + (#x5060 . #x8FB1ED) + (#x5062 . #x8FB1EE) + (#x5063 . #x8FB1EF) + (#x5065 . #xB7F2) + (#x5066 . #x8FB1F0) + (#x5067 . #x8FB1F1) + (#x506A . #x8FB1F2) + (#x506C . #xD0F8) + (#x506D . #x8FB1F3) + (#x5070 . #x8FB1F4) + (#x5071 . #x8FB1F5) + (#x5072 . #xBCC5) + (#x5074 . #xC2A6) + (#x5075 . #xC4E5) + (#x5076 . #xB6F6) + (#x5078 . #xD0F9) + (#x507D . #xB5B6) + (#x5080 . #xD0FA) + (#x5081 . #x8FB1F7) + (#x5083 . #x8FB1F8) + (#x5084 . #x8FB1F9) + (#x5085 . #xD0FC) + (#x5086 . #x8FB1FA) + (#x508A . #x8FB1FB) + (#x508D . #xCBB5) + (#x508E . #x8FB1FC) + (#x508F . #x8FB1FD) + (#x5090 . #x8FB1FE) + (#x5091 . #xB7E6) + (#x5092 . #x8FB2A1) + (#x5093 . #x8FB2A2) + (#x5094 . #x8FB2A3) + (#x5096 . #x8FB2A4) + (#x5098 . #xBBB1) + (#x5099 . #xC8F7) + (#x509A . #xD0FB) + (#x509B . #x8FB2A5) + (#x509C . #x8FB2A6) + (#x509E . #x8FB2A7) + (#x509F . #x8FB2A8) + (#x50A0 . #x8FB2A9) + (#x50A1 . #x8FB2AA) + (#x50A2 . #x8FB2AB) + (#x50AA . #x8FB2AC) + (#x50AC . #xBAC5) + (#x50AD . #xCDC3) + (#x50AF . #x8FB2AD) + (#x50B0 . #x8FB2AE) + (#x50B2 . #xD0FE) + (#x50B3 . #xD1A3) + (#x50B4 . #xD0FD) + (#x50B5 . #xBAC4) + (#x50B7 . #xBDFD) + (#x50B9 . #x8FB2AF) + (#x50BA . #x8FB2B0) + (#x50BD . #x8FB2B1) + (#x50BE . #xB7B9) + (#x50C0 . #x8FB2B2) + (#x50C2 . #xD1A4) + (#x50C3 . #x8FB2B3) + (#x50C4 . #x8FB2B4) + (#x50C5 . #xB6CF) + (#x50C7 . #x8FB2B5) + (#x50C9 . #xD1A1) + (#x50CA . #xD1A2) + (#x50CC . #x8FB2B6) + (#x50CD . #xC6AF) + (#x50CE . #x8FB2B7) + (#x50CF . #xC1FC) + (#x50D0 . #x8FB2B8) + (#x50D1 . #xB6A3) + (#x50D3 . #x8FB2B9) + (#x50D4 . #x8FB2BA) + (#x50D5 . #xCBCD) + (#x50D6 . #xD1A5) + (#x50D8 . #x8FB2BB) + (#x50DA . #xCEBD) + (#x50DC . #x8FB2BC) + (#x50DD . #x8FB2BD) + (#x50DE . #xD1A6) + (#x50DF . #x8FB2BE) + (#x50E2 . #x8FB2BF) + (#x50E3 . #xD1A9) + (#x50E4 . #x8FB2C0) + (#x50E5 . #xD1A7) + (#x50E6 . #x8FB2C1) + (#x50E7 . #xC1CE) + (#x50E8 . #x8FB2C2) + (#x50E9 . #x8FB2C3) + (#x50ED . #xD1A8) + (#x50EE . #xD1AA) + (#x50EF . #x8FB2C4) + (#x50F1 . #x8FB2C5) + (#x50F2 . #x8FB2D1) + (#x50F5 . #xD1AC) + (#x50F6 . #x8FB2C6) + (#x50F9 . #xD1AB) + (#x50FA . #x8FB2C7) + (#x50FB . #xCAC8) + (#x50FE . #x8FB2C8) + (#x5100 . #xB5B7) + (#x5101 . #xD1AE) + (#x5102 . #xD1AF) + (#x5103 . #x8FB2C9) + (#x5104 . #xB2AF) + (#x5106 . #x8FB2CA) + (#x5107 . #x8FB2CB) + (#x5108 . #x8FB2CC) + (#x5109 . #xD1AD) + (#x510B . #x8FB2CD) + (#x510C . #x8FB2CE) + (#x510D . #x8FB2CF) + (#x510E . #x8FB2D0) + (#x5110 . #x8FB2D2) + (#x5112 . #xBCF4) + (#x5114 . #xD1B2) + (#x5115 . #xD1B1) + (#x5116 . #xD1B0) + (#x5117 . #x8FB2D3) + (#x5118 . #xD0D6) + (#x5119 . #x8FB2D4) + (#x511A . #xD1B3) + (#x511B . #x8FB2D5) + (#x511C . #x8FB2D6) + (#x511D . #x8FB2D7) + (#x511E . #x8FB2D8) + (#x511F . #xBDFE) + (#x5121 . #xD1B4) + (#x5123 . #x8FB2D9) + (#x5127 . #x8FB2DA) + (#x5128 . #x8FB2DB) + (#x512A . #xCDA5) + (#x512C . #x8FB2DC) + (#x512D . #x8FB2DD) + (#x512F . #x8FB2DE) + (#x5131 . #x8FB2DF) + (#x5132 . #xCCD9) + (#x5133 . #x8FB2E0) + (#x5134 . #x8FB2E1) + (#x5135 . #x8FB2E2) + (#x5137 . #xD1B6) + (#x5138 . #x8FB2E3) + (#x5139 . #x8FB2E4) + (#x513A . #xD1B5) + (#x513B . #xD1B8) + (#x513C . #xD1B7) + (#x513F . #xD1B9) + (#x5140 . #xD1BA) + (#x5141 . #xB0F4) + (#x5142 . #x8FB2E5) + (#x5143 . #xB8B5) + (#x5144 . #xB7BB) + (#x5145 . #xBDBC) + (#x5146 . #xC3FB) + (#x5147 . #xB6A4) + (#x5148 . #xC0E8) + (#x5149 . #xB8F7) + (#x514A . #x8FB2E6) + (#x514B . #xB9EE) + (#x514C . #xD1BC) + (#x514D . #xCCC8) + (#x514E . #xC5C6) + (#x514F . #x8FB2E7) + (#x5150 . #xBBF9) + (#x5152 . #xD1BB) + (#x5153 . #x8FB2E8) + (#x5154 . #xD1BD) + (#x5155 . #x8FB2E9) + (#x5157 . #x8FB2EA) + (#x5158 . #x8FB2EB) + (#x515A . #xC5DE) + (#x515C . #xB3F5) + (#x515F . #x8FB2EC) + (#x5162 . #xD1BE) + (#x5164 . #x8FB2ED) + (#x5165 . #xC6FE) + (#x5166 . #x8FB2EE) + (#x5168 . #xC1B4) + (#x5169 . #xD1C0) + (#x516A . #xD1C1) + (#x516B . #xC8AC) + (#x516C . #xB8F8) + (#x516D . #xCFBB) + (#x516E . #xD1C2) + (#x5171 . #xB6A6) + (#x5175 . #xCABC) + (#x5176 . #xC2B6) + (#x5177 . #xB6F1) + (#x5178 . #xC5B5) + (#x517C . #xB7F3) + (#x517E . #x8FB2EF) + (#x5180 . #xD1C3) + (#x5182 . #xD1C4) + (#x5183 . #x8FB2F0) + (#x5184 . #x8FB2F1) + (#x5185 . #xC6E2) + (#x5186 . #xB1DF) + (#x5189 . #xD1C7) + (#x518A . #xBAFD) + (#x518B . #x8FB2F2) + (#x518C . #xD1C6) + (#x518D . #xBAC6) + (#x518E . #x8FB2F3) + (#x518F . #xD1C8) + (#x5190 . #xE6EE) + (#x5191 . #xD1C9) + (#x5192 . #xCBC1) + (#x5193 . #xD1CA) + (#x5195 . #xD1CB) + (#x5196 . #xD1CC) + (#x5197 . #xBEE9) + (#x5198 . #x8FB2F4) + (#x5199 . #xBCCC) + (#x519D . #x8FB2F5) + (#x51A0 . #xB4A7) + (#x51A1 . #x8FB2F6) + (#x51A2 . #xD1CF) + (#x51A3 . #x8FB2F7) + (#x51A4 . #xD1CD) + (#x51A5 . #xCCBD) + (#x51A6 . #xD1CE) + (#x51A8 . #xC9DA) + (#x51A9 . #xD1D0) + (#x51AA . #xD1D1) + (#x51AB . #xD1D2) + (#x51AC . #xC5DF) + (#x51AD . #x8FB2F8) + (#x51B0 . #xD1D6) + (#x51B1 . #xD1D4) + (#x51B2 . #xD1D5) + (#x51B3 . #xD1D3) + (#x51B4 . #xBAE3) + (#x51B5 . #xD1D7) + (#x51B6 . #xCCEA) + (#x51B7 . #xCEE4) + (#x51B8 . #x8FB2F9) + (#x51BA . #x8FB2FA) + (#x51BC . #x8FB2FB) + (#x51BD . #xD1D8) + (#x51BE . #x8FB2FC) + (#x51BF . #x8FB2FD) + (#x51C2 . #x8FB2FE) + (#x51C4 . #xC0A8) + (#x51C5 . #xD1D9) + (#x51C6 . #xBDDA) + (#x51C8 . #x8FB3A1) + (#x51C9 . #xD1DA) + (#x51CB . #xC3FC) + (#x51CC . #xCEBF) + (#x51CD . #xC5E0) + (#x51CF . #x8FB3A2) + (#x51D1 . #x8FB3A3) + (#x51D2 . #x8FB3A4) + (#x51D3 . #x8FB3A5) + (#x51D5 . #x8FB3A6) + (#x51D6 . #xD2C5) + (#x51D8 . #x8FB3A7) + (#x51DB . #xD1DB) + (#x51DC . #xF4A5) + (#x51DD . #xB6C5) + (#x51DE . #x8FB3A8) + (#x51E0 . #xD1DC) + (#x51E1 . #xCBDE) + (#x51E2 . #x8FB3A9) + (#x51E5 . #x8FB3AA) + (#x51E6 . #xBDE8) + (#x51E7 . #xC2FC) + (#x51E9 . #xD1DE) + (#x51EA . #xC6E4) + (#x51ED . #xD1DF) + (#x51EE . #x8FB3AB) + (#x51F0 . #xD1E0) + (#x51F1 . #xB3AE) + (#x51F2 . #x8FB3AC) + (#x51F3 . #x8FB3AD) + (#x51F4 . #x8FB3AE) + (#x51F5 . #xD1E1) + (#x51F6 . #xB6A7) + (#x51F7 . #x8FB3AF) + (#x51F8 . #xC6CC) + (#x51F9 . #xB1FA) + (#x51FA . #xBDD0) + (#x51FD . #xC8A1) + (#x51FE . #xD1E2) + (#x5200 . #xC5E1) + (#x5201 . #x8FB3B0) + (#x5202 . #x8FB3B1) + (#x5203 . #xBFCF) + (#x5204 . #xD1E3) + (#x5205 . #x8FB3B2) + (#x5206 . #xCAAC) + (#x5207 . #xC0DA) + (#x5208 . #xB4A2) + (#x520A . #xB4A9) + (#x520B . #xD1E4) + (#x520E . #xD1E6) + (#x5211 . #xB7BA) + (#x5212 . #x8FB3B3) + (#x5213 . #x8FB3B4) + (#x5214 . #xD1E5) + (#x5215 . #x8FB3B5) + (#x5216 . #x8FB3B6) + (#x5217 . #xCEF3) + (#x5218 . #x8FB3B7) + (#x521D . #xBDE9) + (#x5222 . #x8FB3B8) + (#x5224 . #xC8BD) + (#x5225 . #xCACC) + (#x5227 . #xD1E7) + (#x5228 . #x8FB3B9) + (#x5229 . #xCDF8) + (#x522A . #xD1E8) + (#x522E . #xD1E9) + (#x5230 . #xC5FE) + (#x5231 . #x8FB3BA) + (#x5232 . #x8FB3BB) + (#x5233 . #xD1EA) + (#x5235 . #x8FB3BC) + (#x5236 . #xC0A9) + (#x5237 . #xBAFE) + (#x5238 . #xB7F4) + (#x5239 . #xD1EB) + (#x523A . #xBBC9) + (#x523B . #xB9EF) + (#x523C . #x8FB3BD) + (#x5243 . #xC4E6) + (#x5244 . #xD1ED) + (#x5245 . #x8FB3BE) + (#x5247 . #xC2A7) + (#x5249 . #x8FB3BF) + (#x524A . #xBAEF) + (#x524B . #xD1EE) + (#x524C . #xD1EF) + (#x524D . #xC1B0) + (#x524F . #xD1EC) + (#x5254 . #xD1F1) + (#x5255 . #x8FB3C0) + (#x5256 . #xCBB6) + (#x5257 . #x8FB3C1) + (#x5258 . #x8FB3C2) + (#x525A . #x8FB3C3) + (#x525B . #xB9E4) + (#x525C . #x8FB3C4) + (#x525E . #xD1F0) + (#x525F . #x8FB3C5) + (#x5260 . #x8FB3C6) + (#x5261 . #x8FB3C7) + (#x5263 . #xB7F5) + (#x5264 . #xBADE) + (#x5265 . #xC7ED) + (#x5266 . #x8FB3C8) + (#x5269 . #xD1F4) + (#x526A . #xD1F2) + (#x526E . #x8FB3C9) + (#x526F . #xC9FB) + (#x5270 . #xBEEA) + (#x5271 . #xD1FB) + (#x5272 . #xB3E4) + (#x5273 . #xD1F5) + (#x5274 . #xD1F3) + (#x5275 . #xC1CF) + (#x5277 . #x8FB3CA) + (#x5278 . #x8FB3CB) + (#x5279 . #x8FB3CC) + (#x527D . #xD1F7) + (#x527F . #xD1F6) + (#x5280 . #x8FB3CD) + (#x5282 . #x8FB3CE) + (#x5283 . #xB3C4) + (#x5285 . #x8FB3CF) + (#x5287 . #xB7E0) + (#x5288 . #xD1FC) + (#x5289 . #xCEAD) + (#x528A . #x8FB3D0) + (#x528C . #x8FB3D1) + (#x528D . #xD1F8) + (#x5291 . #xD1FD) + (#x5292 . #xD1FA) + (#x5293 . #x8FB3D2) + (#x5294 . #xD1F9) + (#x5295 . #x8FB3D3) + (#x5296 . #x8FB3D4) + (#x5297 . #x8FB3D5) + (#x5298 . #x8FB3D6) + (#x529A . #x8FB3D7) + (#x529B . #xCECF) + (#x529C . #x8FB3D8) + (#x529F . #xB8F9) + (#x52A0 . #xB2C3) + (#x52A3 . #xCEF4) + (#x52A4 . #x8FB3D9) + (#x52A5 . #x8FB3DA) + (#x52A6 . #x8FB3DB) + (#x52A7 . #x8FB3DC) + (#x52A9 . #xBDF5) + (#x52AA . #xC5D8) + (#x52AB . #xB9E5) + (#x52AC . #xD2A2) + (#x52AD . #xD2A3) + (#x52AF . #x8FB3DD) + (#x52B0 . #x8FB3DE) + (#x52B1 . #xCEE5) + (#x52B4 . #xCFAB) + (#x52B5 . #xD2A5) + (#x52B6 . #x8FB3DF) + (#x52B7 . #x8FB3E0) + (#x52B8 . #x8FB3E1) + (#x52B9 . #xB8FA) + (#x52BA . #x8FB3E2) + (#x52BB . #x8FB3E3) + (#x52BC . #xD2A4) + (#x52BD . #x8FB3E4) + (#x52BE . #xB3AF) + (#x52C0 . #x8FB3E5) + (#x52C1 . #xD2A6) + (#x52C3 . #xCBD6) + (#x52C4 . #x8FB3E6) + (#x52C5 . #xC4BC) + (#x52C6 . #x8FB3E7) + (#x52C7 . #xCDA6) + (#x52C8 . #x8FB3E8) + (#x52C9 . #xCAD9) + (#x52CC . #x8FB3E9) + (#x52CD . #xD2A7) + (#x52CF . #x8FB3EA) + (#x52D1 . #x8FB3EB) + (#x52D2 . #xF0D5) + (#x52D4 . #x8FB3EC) + (#x52D5 . #xC6B0) + (#x52D6 . #x8FB3ED) + (#x52D7 . #xD2A8) + (#x52D8 . #xB4AA) + (#x52D9 . #xCCB3) + (#x52DB . #x8FB3EE) + (#x52DC . #x8FB3EF) + (#x52DD . #xBEA1) + (#x52DE . #xD2A9) + (#x52DF . #xCAE7) + (#x52E0 . #xD2AD) + (#x52E1 . #x8FB3F0) + (#x52E2 . #xC0AA) + (#x52E3 . #xD2AA) + (#x52E4 . #xB6D0) + (#x52E5 . #x8FB3F1) + (#x52E6 . #xD2AB) + (#x52E7 . #xB4AB) + (#x52E8 . #x8FB3F2) + (#x52E9 . #x8FB3F3) + (#x52EA . #x8FB3F4) + (#x52EC . #x8FB3F5) + (#x52F0 . #x8FB3F6) + (#x52F1 . #x8FB3F7) + (#x52F2 . #xB7AE) + (#x52F3 . #xD2AE) + (#x52F4 . #x8FB3F8) + (#x52F5 . #xD2AF) + (#x52F6 . #x8FB3F9) + (#x52F7 . #x8FB3FA) + (#x52F8 . #xD2B0) + (#x52F9 . #xD2B1) + (#x52FA . #xBCDB) + (#x52FE . #xB8FB) + (#x52FF . #xCCDE) + (#x5300 . #x8FB3FB) + (#x5301 . #xCCE8) + (#x5302 . #xC6F7) + (#x5303 . #x8FB3FC) + (#x5305 . #xCAF1) + (#x5306 . #xD2B2) + (#x5308 . #xD2B3) + (#x530A . #x8FB3FD) + (#x530B . #x8FB3FE) + (#x530C . #x8FB4A1) + (#x530D . #xD2B5) + (#x530F . #xD2B7) + (#x5310 . #xD2B6) + (#x5311 . #x8FB4A2) + (#x5313 . #x8FB4A3) + (#x5315 . #xD2B8) + (#x5316 . #xB2BD) + (#x5317 . #xCBCC) + (#x5318 . #x8FB4A4) + (#x5319 . #xBAFC) + (#x531A . #xD2B9) + (#x531B . #x8FB4A5) + (#x531C . #x8FB4A6) + (#x531D . #xC1D9) + (#x531E . #x8FB4A7) + (#x531F . #x8FB4A8) + (#x5320 . #xBEA2) + (#x5321 . #xB6A9) + (#x5323 . #xD2BA) + (#x5325 . #x8FB4A9) + (#x5327 . #x8FB4AA) + (#x5328 . #x8FB4AB) + (#x5329 . #x8FB4AC) + (#x532A . #xC8DB) + (#x532B . #x8FB4AD) + (#x532C . #x8FB4AE) + (#x532D . #x8FB4AF) + (#x532F . #xD2BB) + (#x5330 . #x8FB4B0) + (#x5331 . #xD2BC) + (#x5332 . #x8FB4B1) + (#x5333 . #xD2BD) + (#x5335 . #x8FB4B2) + (#x5338 . #xD2BE) + (#x5339 . #xC9A4) + (#x533A . #xB6E8) + (#x533B . #xB0E5) + (#x533C . #x8FB4B3) + (#x533D . #x8FB4B4) + (#x533E . #x8FB4B5) + (#x533F . #xC6BF) + (#x5340 . #xD2BF) + (#x5341 . #xBDBD) + (#x5342 . #x8FB4B6) + (#x5343 . #xC0E9) + (#x5345 . #xD2C1) + (#x5346 . #xD2C0) + (#x5347 . #xBEA3) + (#x5348 . #xB8E1) + (#x5349 . #xD2C3) + (#x534A . #xC8BE) + (#x534B . #x8FB4B8) + (#x534C . #x8FB4B7) + (#x534D . #xD2C4) + (#x5351 . #xC8DC) + (#x5352 . #xC2B4) + (#x5353 . #xC2EE) + (#x5354 . #xB6A8) + (#x5357 . #xC6EE) + (#x5358 . #xC3B1) + (#x5359 . #x8FB4B9) + (#x535A . #xC7EE) + (#x535B . #x8FB4BA) + (#x535C . #xCBCE) + (#x535E . #xD2C6) + (#x5360 . #xC0EA) + (#x5361 . #x8FB4BB) + (#x5363 . #x8FB4BC) + (#x5365 . #x8FB4BD) + (#x5366 . #xB7B5) + (#x5369 . #xD2C7) + (#x536C . #x8FB4BE) + (#x536D . #x8FB4BF) + (#x536E . #xD2C8) + (#x536F . #xB1AC) + (#x5370 . #xB0F5) + (#x5371 . #xB4ED) + (#x5372 . #x8FB4C0) + (#x5373 . #xC2A8) + (#x5374 . #xB5D1) + (#x5375 . #xCDF1) + (#x5377 . #xD2CB) + (#x5378 . #xB2B7) + (#x5379 . #x8FB4C1) + (#x537B . #xD2CA) + (#x537E . #x8FB4C2) + (#x537F . #xB6AA) + (#x5382 . #xD2CC) + (#x5383 . #x8FB4C3) + (#x5384 . #xCCF1) + (#x5387 . #x8FB4C4) + (#x5388 . #x8FB4C5) + (#x538E . #x8FB4C6) + (#x5393 . #x8FB4C7) + (#x5394 . #x8FB4C8) + (#x5396 . #xD2CD) + (#x5398 . #xCED2) + (#x5399 . #x8FB4C9) + (#x539A . #xB8FC) + (#x539D . #x8FB4CA) + (#x539F . #xB8B6) + (#x53A0 . #xD2CE) + (#x53A1 . #x8FB4CB) + (#x53A4 . #x8FB4CC) + (#x53A5 . #xD2D0) + (#x53A6 . #xD2CF) + (#x53A8 . #xBFDF) + (#x53A9 . #xB1B9) + (#x53AA . #x8FB4CD) + (#x53AB . #x8FB4CE) + (#x53AD . #xB1DE) + (#x53AE . #xD2D1) + (#x53AF . #x8FB4CF) + (#x53B0 . #xD2D2) + (#x53B2 . #x8FB4D0) + (#x53B3 . #xB8B7) + (#x53B4 . #x8FB4D1) + (#x53B5 . #x8FB4D2) + (#x53B6 . #xD2D3) + (#x53B7 . #x8FB4D3) + (#x53B8 . #x8FB4D4) + (#x53BA . #x8FB4D5) + (#x53BB . #xB5EE) + (#x53BD . #x8FB4D6) + (#x53C0 . #x8FB4D7) + (#x53C2 . #xBBB2) + (#x53C3 . #xD2D4) + (#x53C5 . #x8FB4D8) + (#x53C8 . #xCBF4) + (#x53C9 . #xBAB5) + (#x53CA . #xB5DA) + (#x53CB . #xCDA7) + (#x53CC . #xC1D0) + (#x53CD . #xC8BF) + (#x53CE . #xBCFD) + (#x53CF . #x8FB4D9) + (#x53D2 . #x8FB4DA) + (#x53D3 . #x8FB4DB) + (#x53D4 . #xBDC7) + (#x53D5 . #x8FB4DC) + (#x53D6 . #xBCE8) + (#x53D7 . #xBCF5) + (#x53D9 . #xBDF6) + (#x53DA . #x8FB4DD) + (#x53DB . #xC8C0) + (#x53DD . #x8FB4DE) + (#x53DE . #x8FB4DF) + (#x53DF . #xD2D7) + (#x53E0 . #x8FB4E0) + (#x53E1 . #xB1C3) + (#x53E2 . #xC1D1) + (#x53E3 . #xB8FD) + (#x53E4 . #xB8C5) + (#x53E5 . #xB6E7) + (#x53E6 . #x8FB4E1) + (#x53E7 . #x8FB4E2) + (#x53E8 . #xD2DB) + (#x53E9 . #xC3A1) + (#x53EA . #xC2FE) + (#x53EB . #xB6AB) + (#x53EC . #xBEA4) + (#x53ED . #xD2DC) + (#x53EE . #xD2DA) + (#x53EF . #xB2C4) + (#x53F0 . #xC2E6) + (#x53F1 . #xBCB8) + (#x53F2 . #xBBCB) + (#x53F3 . #xB1A6) + (#x53F5 . #x8FB4E3) + (#x53F6 . #xB3F0) + (#x53F7 . #xB9E6) + (#x53F8 . #xBBCA) + (#x53FA . #xD2DD) + (#x5401 . #xD2DE) + (#x5402 . #x8FB4E4) + (#x5403 . #xB5C9) + (#x5404 . #xB3C6) + (#x5408 . #xB9E7) + (#x5409 . #xB5C8) + (#x540A . #xC4DF) + (#x540B . #xB1A5) + (#x540C . #xC6B1) + (#x540D . #xCCBE) + (#x540E . #xB9A1) + (#x540F . #xCDF9) + (#x5410 . #xC5C7) + (#x5411 . #xB8FE) + (#x5413 . #x8FB4E5) + (#x541A . #x8FB4E6) + (#x541B . #xB7AF) + (#x541D . #xD2E7) + (#x541F . #xB6E3) + (#x5420 . #xCBCA) + (#x5421 . #x8FB4E7) + (#x5426 . #xC8DD) + (#x5427 . #x8FB4E8) + (#x5428 . #x8FB4E9) + (#x5429 . #xD2E6) + (#x542A . #x8FB4EA) + (#x542B . #xB4DE) + (#x542C . #xD2E1) + (#x542D . #xD2E2) + (#x542E . #xD2E4) + (#x542F . #x8FB4EB) + (#x5431 . #x8FB4EC) + (#x5434 . #x8FB4ED) + (#x5435 . #x8FB4EE) + (#x5436 . #xD2E5) + (#x5438 . #xB5DB) + (#x5439 . #xBFE1) + (#x543B . #xCAAD) + (#x543C . #xD2E3) + (#x543D . #xD2DF) + (#x543E . #xB8E3) + (#x5440 . #xD2E0) + (#x5442 . #xCFA4) + (#x5443 . #x8FB4EF) + (#x5444 . #x8FB4F0) + (#x5446 . #xCAF2) + (#x5447 . #x8FB4F1) + (#x5448 . #xC4E8) + (#x5449 . #xB8E2) + (#x544A . #xB9F0) + (#x544D . #x8FB4F2) + (#x544E . #xD2E8) + (#x544F . #x8FB4F3) + (#x5451 . #xC6DD) + (#x545E . #x8FB4F4) + (#x545F . #xD2EC) + (#x5462 . #x8FB4F5) + (#x5464 . #x8FB4F6) + (#x5466 . #x8FB4F7) + (#x5467 . #x8FB4F8) + (#x5468 . #xBCFE) + (#x5469 . #x8FB4F9) + (#x546A . #xBCF6) + (#x546B . #x8FB4FA) + (#x546D . #x8FB4FB) + (#x546E . #x8FB4FC) + (#x5470 . #xD2EF) + (#x5471 . #xD2ED) + (#x5473 . #xCCA3) + (#x5474 . #x8FB4FD) + (#x5475 . #xD2EA) + (#x5476 . #xD2F3) + (#x5477 . #xD2EE) + (#x547B . #xD2F1) + (#x547C . #xB8C6) + (#x547D . #xCCBF) + (#x547F . #x8FB4FE) + (#x5480 . #xD2F2) + (#x5481 . #x8FB5A1) + (#x5483 . #x8FB5A2) + (#x5484 . #xD2F4) + (#x5485 . #x8FB5A3) + (#x5486 . #xD2F6) + (#x5488 . #x8FB5A4) + (#x5489 . #x8FB5A5) + (#x548B . #xBAF0) + (#x548C . #xCFC2) + (#x548D . #x8FB5A6) + (#x548E . #xD2EB) + (#x548F . #xD2E9) + (#x5490 . #xD2F5) + (#x5491 . #x8FB5A7) + (#x5492 . #xD2F0) + (#x5495 . #x8FB5A8) + (#x5496 . #x8FB5A9) + (#x549C . #x8FB5AA) + (#x549F . #x8FB5AB) + (#x54A1 . #x8FB5AC) + (#x54A2 . #xD2F8) + (#x54A4 . #xD3A3) + (#x54A5 . #xD2FA) + (#x54A6 . #x8FB5AD) + (#x54A7 . #x8FB5AE) + (#x54A8 . #xD2FE) + (#x54A9 . #x8FB5AF) + (#x54AA . #x8FB5B0) + (#x54AB . #xD3A1) + (#x54AC . #xD2FB) + (#x54AD . #x8FB5B1) + (#x54AE . #x8FB5B2) + (#x54AF . #xD3BE) + (#x54B1 . #x8FB5B3) + (#x54B2 . #xBAE9) + (#x54B3 . #xB3B1) + (#x54B7 . #x8FB5B4) + (#x54B8 . #xD2F9) + (#x54B9 . #x8FB5B5) + (#x54BA . #x8FB5B6) + (#x54BB . #x8FB5B7) + (#x54BC . #xD3A5) + (#x54BD . #xB0F6) + (#x54BE . #xD3A4) + (#x54BF . #x8FB5B8) + (#x54C0 . #xB0A5) + (#x54C1 . #xC9CA) + (#x54C2 . #xD3A2) + (#x54C4 . #xD2FC) + (#x54C6 . #x8FB5B9) + (#x54C7 . #xD2F7) + (#x54C8 . #xD2FD) + (#x54C9 . #xBAC8) + (#x54CA . #x8FB5BA) + (#x54CD . #x8FB5BB) + (#x54CE . #x8FB5BC) + (#x54D8 . #xD3A6) + (#x54E0 . #x8FB5BD) + (#x54E1 . #xB0F7) + (#x54E2 . #xD3AF) + (#x54E5 . #xD3A7) + (#x54E6 . #xD3A8) + (#x54E8 . #xBEA5) + (#x54E9 . #xCBE9) + (#x54EA . #x8FB5BE) + (#x54EC . #x8FB5BF) + (#x54ED . #xD3AD) + (#x54EE . #xD3AC) + (#x54EF . #x8FB5C0) + (#x54F2 . #xC5AF) + (#x54F6 . #x8FB5C1) + (#x54FA . #xD3AE) + (#x54FC . #x8FB5C2) + (#x54FD . #xD3AB) + (#x54FE . #x8FB5C3) + (#x54FF . #x8FB5C4) + (#x5500 . #x8FB5C5) + (#x5501 . #x8FB5C6) + (#x5504 . #xB1B4) + (#x5505 . #x8FB5C7) + (#x5506 . #xBAB6) + (#x5507 . #xBFB0) + (#x5508 . #x8FB5C8) + (#x5509 . #x8FB5C9) + (#x550C . #x8FB5CA) + (#x550D . #x8FB5CB) + (#x550E . #x8FB5CC) + (#x550F . #xD3A9) + (#x5510 . #xC5E2) + (#x5514 . #xD3AA) + (#x5515 . #x8FB5CD) + (#x5516 . #xB0A2) + (#x552A . #x8FB5CE) + (#x552B . #x8FB5CF) + (#x552E . #xD3B4) + (#x552F . #xCDA3) + (#x5531 . #xBEA7) + (#x5532 . #x8FB5D0) + (#x5533 . #xD3BA) + (#x5535 . #x8FB5D1) + (#x5536 . #x8FB5D2) + (#x5538 . #xD3B9) + (#x5539 . #xD3B0) + (#x553B . #x8FB5D3) + (#x553C . #x8FB5D4) + (#x553D . #x8FB5D5) + (#x553E . #xC2C3) + (#x5540 . #xD3B1) + (#x5541 . #x8FB5D6) + (#x5544 . #xC2EF) + (#x5545 . #xD3B6) + (#x5546 . #xBEA6) + (#x5547 . #x8FB5D7) + (#x5549 . #x8FB5D8) + (#x554A . #x8FB5D9) + (#x554C . #xD3B3) + (#x554D . #x8FB5DA) + (#x554F . #xCCE4) + (#x5550 . #x8FB5DB) + (#x5551 . #x8FB5DC) + (#x5553 . #xB7BC) + (#x5556 . #xD3B7) + (#x5557 . #xD3B8) + (#x5558 . #x8FB5DD) + (#x555A . #x8FB5DE) + (#x555B . #x8FB5DF) + (#x555C . #xD3B5) + (#x555D . #xD3BB) + (#x555E . #x8FB5E0) + (#x5560 . #x8FB5E1) + (#x5561 . #x8FB5E2) + (#x5563 . #xD3B2) + (#x5564 . #x8FB5E3) + (#x5566 . #x8FB5E4) + (#x557B . #xD3C1) + (#x557C . #xD3C6) + (#x557E . #xD3C2) + (#x557F . #x8FB5E5) + (#x5580 . #xD3BD) + (#x5581 . #x8FB5E6) + (#x5582 . #x8FB5E7) + (#x5583 . #xD3C7) + (#x5584 . #xC1B1) + (#x5586 . #x8FB5E8) + (#x5587 . #xD3C9) + (#x5588 . #x8FB5E9) + (#x5589 . #xB9A2) + (#x558A . #xD3BF) + (#x558B . #xC3FD) + (#x558E . #x8FB5EA) + (#x558F . #x8FB5EB) + (#x5591 . #x8FB5EC) + (#x5592 . #x8FB5ED) + (#x5593 . #x8FB5EE) + (#x5594 . #x8FB5EF) + (#x5597 . #x8FB5F0) + (#x5598 . #xD3C3) + (#x5599 . #xD3BC) + (#x559A . #xB4AD) + (#x559C . #xB4EE) + (#x559D . #xB3E5) + (#x559E . #xD3C4) + (#x559F . #xD3C0) + (#x55A3 . #x8FB5F1) + (#x55A4 . #x8FB5F2) + (#x55A7 . #xB7F6) + (#x55A8 . #xD3CA) + (#x55A9 . #xD3C8) + (#x55AA . #xC1D3) + (#x55AB . #xB5CA) + (#x55AC . #xB6AC) + (#x55AD . #x8FB5F3) + (#x55AE . #xD3C5) + (#x55B0 . #xB6F4) + (#x55B2 . #x8FB5F4) + (#x55B6 . #xB1C4) + (#x55BF . #x8FB5F5) + (#x55C1 . #x8FB5F6) + (#x55C3 . #x8FB5F7) + (#x55C4 . #xD3CE) + (#x55C5 . #xD3CC) + (#x55C6 . #x8FB5F8) + (#x55C7 . #xD4A7) + (#x55C9 . #x8FB5F9) + (#x55CB . #x8FB5FA) + (#x55CC . #x8FB5FB) + (#x55CE . #x8FB5FC) + (#x55D1 . #x8FB5FD) + (#x55D2 . #x8FB5FE) + (#x55D3 . #x8FB6A1) + (#x55D4 . #xD3D1) + (#x55D7 . #x8FB6A2) + (#x55D8 . #x8FB6A3) + (#x55DA . #xD3CB) + (#x55DB . #x8FB6A4) + (#x55DC . #xD3CF) + (#x55DE . #x8FB6A5) + (#x55DF . #xD3CD) + (#x55E2 . #x8FB6A6) + (#x55E3 . #xBBCC) + (#x55E4 . #xD3D0) + (#x55E9 . #x8FB6A7) + (#x55F6 . #x8FB6A8) + (#x55F7 . #xD3D3) + (#x55F9 . #xD3D8) + (#x55FD . #xD3D6) + (#x55FE . #xD3D5) + (#x55FF . #x8FB6A9) + (#x5605 . #x8FB6AA) + (#x5606 . #xC3B2) + (#x5608 . #x8FB6AB) + (#x5609 . #xB2C5) + (#x560A . #x8FB6AC) + (#x560D . #x8FB6AD) + (#x560E . #x8FB6AE) + (#x560F . #x8FB6AF) + (#x5610 . #x8FB6B0) + (#x5611 . #x8FB6B1) + (#x5612 . #x8FB6B2) + (#x5614 . #xD3D2) + (#x5616 . #xD3D4) + (#x5617 . #xBEA8) + (#x5618 . #xB1B3) + (#x5619 . #x8FB6B3) + (#x561B . #xD3D7) + (#x5629 . #xB2DE) + (#x562C . #x8FB6B4) + (#x562F . #xD3E2) + (#x5630 . #x8FB6B5) + (#x5631 . #xBEFC) + (#x5632 . #xD3DE) + (#x5633 . #x8FB6B6) + (#x5634 . #xD3DC) + (#x5635 . #x8FB6B7) + (#x5636 . #xD3DD) + (#x5637 . #x8FB6B8) + (#x5638 . #xD3DF) + (#x5639 . #x8FB6B9) + (#x563B . #x8FB6BA) + (#x563C . #x8FB6BB) + (#x563D . #x8FB6BC) + (#x563F . #x8FB6BD) + (#x5640 . #x8FB6BE) + (#x5641 . #x8FB6BF) + (#x5642 . #xB1BD) + (#x5643 . #x8FB6C0) + (#x5644 . #x8FB6C1) + (#x5646 . #x8FB6C2) + (#x5649 . #x8FB6C3) + (#x564B . #x8FB6C4) + (#x564C . #xC1B9) + (#x564D . #x8FB6C5) + (#x564E . #xD3D9) + (#x564F . #x8FB6C6) + (#x5650 . #xD3DA) + (#x5654 . #x8FB6C7) + (#x565B . #xB3FA) + (#x565E . #x8FB6C8) + (#x5660 . #x8FB6C9) + (#x5661 . #x8FB6CA) + (#x5662 . #x8FB6CB) + (#x5663 . #x8FB6CC) + (#x5664 . #xD3E1) + (#x5666 . #x8FB6CD) + (#x5668 . #xB4EF) + (#x5669 . #x8FB6CE) + (#x566A . #xD3E4) + (#x566B . #xD3E0) + (#x566C . #xD3E3) + (#x566D . #x8FB6CF) + (#x566F . #x8FB6D0) + (#x5671 . #x8FB6D1) + (#x5672 . #x8FB6D2) + (#x5674 . #xCAAE) + (#x5675 . #x8FB6D3) + (#x5678 . #xC6D5) + (#x567A . #xC8B8) + (#x5680 . #xD3E6) + (#x5684 . #x8FB6D4) + (#x5685 . #x8FB6D5) + (#x5686 . #xD3E5) + (#x5687 . #xB3C5) + (#x5688 . #x8FB6D6) + (#x568A . #xD3E7) + (#x568B . #x8FB6D7) + (#x568C . #x8FB6D8) + (#x568F . #xD3EA) + (#x5694 . #xD3E9) + (#x5695 . #x8FB6D9) + (#x5699 . #x8FB6DA) + (#x569A . #x8FB6DB) + (#x569D . #x8FB6DC) + (#x569E . #x8FB6DD) + (#x569F . #x8FB6DE) + (#x56A0 . #xD3E8) + (#x56A2 . #xC7B9) + (#x56A5 . #xD3EB) + (#x56A6 . #x8FB6DF) + (#x56A7 . #x8FB6E0) + (#x56A8 . #x8FB6E1) + (#x56A9 . #x8FB6E2) + (#x56AB . #x8FB6E3) + (#x56AC . #x8FB6E4) + (#x56AD . #x8FB6E5) + (#x56AE . #xD3EC) + (#x56B1 . #x8FB6E6) + (#x56B3 . #x8FB6E7) + (#x56B4 . #xD3EE) + (#x56B6 . #xD3ED) + (#x56B7 . #x8FB6E8) + (#x56BC . #xD3F0) + (#x56BE . #x8FB6E9) + (#x56C0 . #xD3F3) + (#x56C1 . #xD3F1) + (#x56C2 . #xD3EF) + (#x56C3 . #xD3F2) + (#x56C5 . #x8FB6EA) + (#x56C8 . #xD3F4) + (#x56C9 . #x8FB6EB) + (#x56CA . #x8FB6EC) + (#x56CB . #x8FB6ED) + (#x56CC . #x8FB6F0) + (#x56CD . #x8FB6F1) + (#x56CE . #xD3F5) + (#x56CF . #x8FB6EE) + (#x56D0 . #x8FB6EF) + (#x56D1 . #xD3F6) + (#x56D3 . #xD3F7) + (#x56D7 . #xD3F8) + (#x56D8 . #xD1C5) + (#x56D9 . #x8FB6F2) + (#x56DA . #xBCFC) + (#x56DB . #xBBCD) + (#x56DC . #x8FB6F3) + (#x56DD . #x8FB6F4) + (#x56DE . #xB2F3) + (#x56DF . #x8FB6F5) + (#x56E0 . #xB0F8) + (#x56E1 . #x8FB6F6) + (#x56E3 . #xC3C4) + (#x56E4 . #x8FB6F7) + (#x56E5 . #x8FB6F8) + (#x56E6 . #x8FB6F9) + (#x56E7 . #x8FB6FA) + (#x56E8 . #x8FB6FB) + (#x56EB . #x8FB6FD) + (#x56ED . #x8FB6FE) + (#x56EE . #xD3F9) + (#x56F0 . #xBAA4) + (#x56F1 . #x8FB6FC) + (#x56F2 . #xB0CF) + (#x56F3 . #xBFDE) + (#x56F6 . #x8FB7A1) + (#x56F7 . #x8FB7A2) + (#x56F9 . #xD3FA) + (#x56FA . #xB8C7) + (#x56FD . #xB9F1) + (#x56FF . #xD3FC) + (#x5700 . #xD3FB) + (#x5701 . #x8FB7A3) + (#x5702 . #x8FB7A4) + (#x5703 . #xCAE0) + (#x5704 . #xD3FD) + (#x5707 . #x8FB7A5) + (#x5708 . #xD4A1) + (#x5709 . #xD3FE) + (#x570A . #x8FB7A6) + (#x570B . #xD4A2) + (#x570C . #x8FB7A7) + (#x570D . #xD4A3) + (#x570F . #xB7F7) + (#x5711 . #x8FB7A8) + (#x5712 . #xB1E0) + (#x5713 . #xD4A4) + (#x5715 . #x8FB7A9) + (#x5716 . #xD4A6) + (#x5718 . #xD4A5) + (#x571A . #x8FB7AA) + (#x571B . #x8FB7AB) + (#x571C . #xD4A8) + (#x571D . #x8FB7AC) + (#x571F . #xC5DA) + (#x5720 . #x8FB7AD) + (#x5722 . #x8FB7AE) + (#x5723 . #x8FB7AF) + (#x5724 . #x8FB7B0) + (#x5725 . #x8FB7B1) + (#x5726 . #xD4A9) + (#x5727 . #xB0B5) + (#x5728 . #xBADF) + (#x5729 . #x8FB7B2) + (#x572A . #x8FB7B3) + (#x572C . #x8FB7B4) + (#x572D . #xB7BD) + (#x572E . #x8FB7B5) + (#x572F . #x8FB7B6) + (#x5730 . #xC3CF) + (#x5733 . #x8FB7B7) + (#x5734 . #x8FB7B8) + (#x5737 . #xD4AA) + (#x5738 . #xD4AB) + (#x573B . #xD4AD) + (#x573D . #x8FB7B9) + (#x573E . #x8FB7BA) + (#x573F . #x8FB7BB) + (#x5740 . #xD4AE) + (#x5742 . #xBAE4) + (#x5745 . #x8FB7BC) + (#x5746 . #x8FB7BD) + (#x5747 . #xB6D1) + (#x574A . #xCBB7) + (#x574C . #x8FB7BE) + (#x574D . #x8FB7BF) + (#x574E . #xD4AC) + (#x574F . #xD4AF) + (#x5750 . #xBAC1) + (#x5751 . #xB9A3) + (#x5752 . #x8FB7C0) + (#x5761 . #xD4B3) + (#x5762 . #x8FB7C1) + (#x5764 . #xBAA5) + (#x5765 . #x8FB7C2) + (#x5766 . #xC3B3) + (#x5767 . #x8FB7C3) + (#x5768 . #x8FB7C4) + (#x5769 . #xD4B0) + (#x576A . #xC4DA) + (#x576B . #x8FB7C5) + (#x576D . #x8FB7C6) + (#x576E . #x8FB7C7) + (#x576F . #x8FB7C8) + (#x5770 . #x8FB7C9) + (#x5771 . #x8FB7CA) + (#x5773 . #x8FB7CB) + (#x5774 . #x8FB7CC) + (#x5775 . #x8FB7CD) + (#x5777 . #x8FB7CE) + (#x5779 . #x8FB7CF) + (#x577A . #x8FB7D0) + (#x577B . #x8FB7D1) + (#x577C . #x8FB7D2) + (#x577E . #x8FB7D3) + (#x577F . #xD4B4) + (#x5781 . #x8FB7D4) + (#x5782 . #xBFE2) + (#x5783 . #x8FB7D5) + (#x5788 . #xD4B2) + (#x5789 . #xD4B5) + (#x578B . #xB7BF) + (#x578C . #x8FB7D6) + (#x5793 . #xD4B6) + (#x5794 . #x8FB7D7) + (#x5795 . #x8FB7E0) + (#x5797 . #x8FB7D8) + (#x5799 . #x8FB7D9) + (#x579A . #x8FB7DA) + (#x579C . #x8FB7DB) + (#x579D . #x8FB7DC) + (#x579E . #x8FB7DD) + (#x579F . #x8FB7DE) + (#x57A0 . #xD4B7) + (#x57A1 . #x8FB7DF) + (#x57A2 . #xB9A4) + (#x57A3 . #xB3C0) + (#x57A4 . #xD4B9) + (#x57A7 . #x8FB7E1) + (#x57A8 . #x8FB7E2) + (#x57A9 . #x8FB7E3) + (#x57AA . #xD4BA) + (#x57AC . #x8FB7E4) + (#x57B0 . #xD4BB) + (#x57B3 . #xD4B8) + (#x57B8 . #x8FB7E5) + (#x57BD . #x8FB7E6) + (#x57C0 . #xD4B1) + (#x57C3 . #xD4BC) + (#x57C6 . #xD4BD) + (#x57C7 . #x8FB7E7) + (#x57C8 . #x8FB7E8) + (#x57CB . #xCBE4) + (#x57CC . #x8FB7E9) + (#x57CE . #xBEEB) + (#x57CF . #x8FB7EA) + (#x57D2 . #xD4BF) + (#x57D3 . #xD4C0) + (#x57D4 . #xD4BE) + (#x57D5 . #x8FB7EB) + (#x57D6 . #xD4C2) + (#x57DC . #xC7B8) + (#x57DD . #x8FB7EC) + (#x57DE . #x8FB7ED) + (#x57DF . #xB0E8) + (#x57E0 . #xC9D6) + (#x57E1 . #x8FB7FE) + (#x57E3 . #xD4C3) + (#x57E4 . #x8FB7EE) + (#x57E6 . #x8FB7EF) + (#x57E7 . #x8FB7F0) + (#x57E9 . #x8FB7F1) + (#x57ED . #x8FB7F2) + (#x57F0 . #x8FB7F3) + (#x57F4 . #xBEFD) + (#x57F5 . #x8FB7F4) + (#x57F6 . #x8FB7F5) + (#x57F7 . #xBCB9) + (#x57F8 . #x8FB7F6) + (#x57F9 . #xC7DD) + (#x57FA . #xB4F0) + (#x57FC . #xBAEB) + (#x57FD . #x8FB7F7) + (#x57FE . #x8FB7F8) + (#x57FF . #x8FB7F9) + (#x5800 . #xCBD9) + (#x5802 . #xC6B2) + (#x5803 . #x8FB7FA) + (#x5804 . #x8FB7FB) + (#x5805 . #xB7F8) + (#x5806 . #xC2CF) + (#x5808 . #x8FB7FC) + (#x5809 . #x8FB7FD) + (#x580A . #xD4C1) + (#x580B . #xD4C4) + (#x580C . #x8FB8A1) + (#x580D . #x8FB8A2) + (#x5815 . #xC2C4) + (#x5819 . #xD4C5) + (#x581B . #x8FB8A3) + (#x581D . #xD4C6) + (#x581E . #x8FB8A4) + (#x581F . #x8FB8A5) + (#x5820 . #x8FB8A6) + (#x5821 . #xD4C8) + (#x5824 . #xC4E9) + (#x5826 . #x8FB8A7) + (#x5827 . #x8FB8A8) + (#x582A . #xB4AE) + (#x582D . #x8FB8A9) + (#x582F . #xF4A1) + (#x5830 . #xB1E1) + (#x5831 . #xCAF3) + (#x5832 . #x8FB8AA) + (#x5834 . #xBEEC) + (#x5835 . #xC5C8) + (#x5839 . #x8FB8AB) + (#x583A . #xBAE6) + (#x583D . #xD4CE) + (#x583F . #x8FB8AC) + (#x5840 . #xCABD) + (#x5841 . #xCEDD) + (#x5849 . #x8FB8AD) + (#x584A . #xB2F4) + (#x584B . #xD4CA) + (#x584C . #x8FB8AE) + (#x584D . #x8FB8AF) + (#x584F . #x8FB8B0) + (#x5850 . #x8FB8B1) + (#x5851 . #xC1BA) + (#x5852 . #xD4CD) + (#x5854 . #xC5E3) + (#x5855 . #x8FB8B2) + (#x5857 . #xC5C9) + (#x5858 . #xC5E4) + (#x5859 . #xC8B9) + (#x585A . #xC4CD) + (#x585E . #xBAC9) + (#x585F . #x8FB8B3) + (#x5861 . #x8FB8B4) + (#x5862 . #xD4C9) + (#x5864 . #x8FB8B5) + (#x5867 . #x8FB8B6) + (#x5868 . #x8FB8B7) + (#x5869 . #xB1F6) + (#x586B . #xC5B6) + (#x5870 . #xD4CB) + (#x5872 . #xD4C7) + (#x5875 . #xBFD0) + (#x5878 . #x8FB8B8) + (#x5879 . #xD4CF) + (#x587C . #x8FB8B9) + (#x587E . #xBDCE) + (#x587F . #x8FB8BA) + (#x5880 . #x8FB8BB) + (#x5881 . #x8FB8BC) + (#x5883 . #xB6AD) + (#x5885 . #xD4D0) + (#x5887 . #x8FB8BD) + (#x5888 . #x8FB8BE) + (#x5889 . #x8FB8BF) + (#x588A . #x8FB8C0) + (#x588C . #x8FB8C1) + (#x588D . #x8FB8C2) + (#x588F . #x8FB8C3) + (#x5890 . #x8FB8C4) + (#x5893 . #xCAE8) + (#x5894 . #x8FB8C5) + (#x5896 . #x8FB8C6) + (#x5897 . #xC1FD) + (#x589C . #xC4C6) + (#x589D . #x8FB8C7) + (#x589F . #xD4D2) + (#x58A0 . #x8FB8C8) + (#x58A1 . #x8FB8C9) + (#x58A2 . #x8FB8CA) + (#x58A6 . #x8FB8CB) + (#x58A8 . #xCBCF) + (#x58A9 . #x8FB8CC) + (#x58AB . #xD4D3) + (#x58AE . #xD4D8) + (#x58B1 . #x8FB8CD) + (#x58B2 . #x8FB8CE) + (#x58B3 . #xCAAF) + (#x58B8 . #xD4D7) + (#x58B9 . #xD4D1) + (#x58BA . #xD4D4) + (#x58BB . #xD4D6) + (#x58BC . #x8FB8D0) + (#x58BE . #xBAA6) + (#x58C1 . #xCAC9) + (#x58C2 . #x8FB8D1) + (#x58C4 . #x8FB8CF) + (#x58C5 . #xD4D9) + (#x58C7 . #xC3C5) + (#x58C8 . #x8FB8D2) + (#x58CA . #xB2F5) + (#x58CC . #xBEED) + (#x58CD . #x8FB8D3) + (#x58CE . #x8FB8D4) + (#x58D0 . #x8FB8D5) + (#x58D1 . #xD4DB) + (#x58D2 . #x8FB8D6) + (#x58D3 . #xD4DA) + (#x58D4 . #x8FB8D7) + (#x58D5 . #xB9E8) + (#x58D6 . #x8FB8D8) + (#x58D7 . #xD4DC) + (#x58D8 . #xD4DE) + (#x58D9 . #xD4DD) + (#x58DA . #x8FB8D9) + (#x58DC . #xD4E0) + (#x58DD . #x8FB8DA) + (#x58DE . #xD4D5) + (#x58DF . #xD4E2) + (#x58E1 . #x8FB8DB) + (#x58E2 . #x8FB8DC) + (#x58E4 . #xD4E1) + (#x58E5 . #xD4DF) + (#x58E9 . #x8FB8DD) + (#x58EB . #xBBCE) + (#x58EC . #xBFD1) + (#x58EE . #xC1D4) + (#x58EF . #xD4E3) + (#x58F0 . #xC0BC) + (#x58F1 . #xB0ED) + (#x58F2 . #xC7E4) + (#x58F3 . #x8FB8DE) + (#x58F7 . #xC4DB) + (#x58F9 . #xD4E5) + (#x58FA . #xD4E4) + (#x58FB . #xD4E6) + (#x58FC . #xD4E7) + (#x58FD . #xD4E8) + (#x5902 . #xD4E9) + (#x5905 . #x8FB8DF) + (#x5906 . #x8FB8E0) + (#x5909 . #xCAD1) + (#x590A . #xD4EA) + (#x590B . #x8FB8E1) + (#x590C . #x8FB8E2) + (#x590F . #xB2C6) + (#x5910 . #xD4EB) + (#x5912 . #x8FB8E3) + (#x5913 . #x8FB8E4) + (#x5914 . #x8FB8E5) + (#x5915 . #xCDBC) + (#x5916 . #xB3B0) + (#x5918 . #xD2C9) + (#x5919 . #xBDC8) + (#x591A . #xC2BF) + (#x591B . #xD4EC) + (#x591C . #xCCEB) + (#x591D . #x8FB8E7) + (#x5921 . #x8FB8E8) + (#x5922 . #xCCB4) + (#x5923 . #x8FB8E9) + (#x5924 . #x8FB8EA) + (#x5925 . #xD4EE) + (#x5927 . #xC2E7) + (#x5928 . #x8FB8EB) + (#x5929 . #xC5B7) + (#x592A . #xC2C0) + (#x592B . #xC9D7) + (#x592C . #xD4EF) + (#x592D . #xD4F0) + (#x592E . #xB1FB) + (#x592F . #x8FB8EC) + (#x5930 . #x8FB8ED) + (#x5931 . #xBCBA) + (#x5932 . #xD4F1) + (#x5933 . #x8FB8EE) + (#x5935 . #x8FB8EF) + (#x5936 . #x8FB8F0) + (#x5937 . #xB0D0) + (#x5938 . #xD4F2) + (#x593E . #xD4F3) + (#x593F . #x8FB8F1) + (#x5943 . #x8FB8F2) + (#x5944 . #xB1E2) + (#x5946 . #x8FB8F3) + (#x5947 . #xB4F1) + (#x5948 . #xC6E0) + (#x5949 . #xCAF4) + (#x594E . #xD4F7) + (#x594F . #xC1D5) + (#x5950 . #xD4F6) + (#x5951 . #xB7C0) + (#x5952 . #x8FB8F4) + (#x5953 . #x8FB8F5) + (#x5954 . #xCBDB) + (#x5955 . #xD4F5) + (#x5957 . #xC5E5) + (#x5958 . #xD4F9) + (#x5959 . #x8FB8F6) + (#x595A . #xD4F8) + (#x595B . #x8FB8F7) + (#x595D . #x8FB8F8) + (#x595E . #x8FB8F9) + (#x595F . #x8FB8FA) + (#x5960 . #xD4FB) + (#x5961 . #x8FB8FB) + (#x5962 . #xD4FA) + (#x5963 . #x8FB8FC) + (#x5965 . #xB1FC) + (#x5967 . #xD4FC) + (#x5968 . #xBEA9) + (#x5969 . #xD4FE) + (#x596A . #xC3A5) + (#x596B . #x8FB8FD) + (#x596C . #xD4FD) + (#x596D . #x8FB8FE) + (#x596E . #xCAB3) + (#x596F . #x8FB9A1) + (#x5972 . #x8FB9A2) + (#x5973 . #xBDF7) + (#x5974 . #xC5DB) + (#x5975 . #x8FB9A3) + (#x5976 . #x8FB9A4) + (#x5978 . #xD5A1) + (#x5979 . #x8FB9A5) + (#x597B . #x8FB9A6) + (#x597C . #x8FB9A7) + (#x597D . #xB9A5) + (#x5981 . #xD5A2) + (#x5982 . #xC7A1) + (#x5983 . #xC8DE) + (#x5984 . #xCCD1) + (#x598A . #xC7A5) + (#x598B . #x8FB9A8) + (#x598C . #x8FB9A9) + (#x598D . #xD5AB) + (#x598E . #x8FB9AA) + (#x5992 . #x8FB9AB) + (#x5993 . #xB5B8) + (#x5995 . #x8FB9AC) + (#x5996 . #xCDC5) + (#x5997 . #x8FB9AD) + (#x5999 . #xCCAF) + (#x599B . #xD6AC) + (#x599D . #xD5A3) + (#x599F . #x8FB9AE) + (#x59A3 . #xD5A6) + (#x59A4 . #x8FB9AF) + (#x59A5 . #xC2C5) + (#x59A7 . #x8FB9B0) + (#x59A8 . #xCBB8) + (#x59AC . #xC5CA) + (#x59AD . #x8FB9B1) + (#x59AE . #x8FB9B2) + (#x59AF . #x8FB9B3) + (#x59B0 . #x8FB9B4) + (#x59B2 . #xD5A7) + (#x59B3 . #x8FB9B5) + (#x59B7 . #x8FB9B6) + (#x59B9 . #xCBE5) + (#x59BA . #x8FB9B7) + (#x59BB . #xBACA) + (#x59BC . #x8FB9B8) + (#x59BE . #xBEAA) + (#x59C1 . #x8FB9B9) + (#x59C3 . #x8FB9BA) + (#x59C4 . #x8FB9BB) + (#x59C6 . #xD5A8) + (#x59C8 . #x8FB9BC) + (#x59C9 . #xBBD0) + (#x59CA . #x8FB9BD) + (#x59CB . #xBBCF) + (#x59CD . #x8FB9BE) + (#x59D0 . #xB0B9) + (#x59D1 . #xB8C8) + (#x59D2 . #x8FB9BF) + (#x59D3 . #xC0AB) + (#x59D4 . #xB0D1) + (#x59D9 . #xD5AC) + (#x59DA . #xD5AD) + (#x59DC . #xD5AA) + (#x59DD . #x8FB9C0) + (#x59DE . #x8FB9C1) + (#x59DF . #x8FB9C2) + (#x59E3 . #x8FB9C3) + (#x59E4 . #x8FB9C4) + (#x59E5 . #xB1B8) + (#x59E6 . #xB4AF) + (#x59E7 . #x8FB9C5) + (#x59E8 . #xD5A9) + (#x59EA . #xCCC5) + (#x59EB . #xC9B1) + (#x59EE . #x8FB9C6) + (#x59EF . #x8FB9C7) + (#x59F1 . #x8FB9C8) + (#x59F2 . #x8FB9C9) + (#x59F4 . #x8FB9CA) + (#x59F6 . #xB0A8) + (#x59F7 . #x8FB9CB) + (#x59FB . #xB0F9) + (#x59FF . #xBBD1) + (#x5A00 . #x8FB9CC) + (#x5A01 . #xB0D2) + (#x5A03 . #xB0A3) + (#x5A04 . #x8FB9CD) + (#x5A09 . #xD5B2) + (#x5A0C . #x8FB9CE) + (#x5A0D . #x8FB9CF) + (#x5A0E . #x8FB9D0) + (#x5A11 . #xD5B0) + (#x5A12 . #x8FB9D1) + (#x5A13 . #x8FB9D2) + (#x5A18 . #xCCBC) + (#x5A1A . #xD5B3) + (#x5A1C . #xD5B1) + (#x5A1E . #x8FB9D3) + (#x5A1F . #xD5AF) + (#x5A20 . #xBFB1) + (#x5A23 . #x8FB9D4) + (#x5A24 . #x8FB9D5) + (#x5A25 . #xD5AE) + (#x5A27 . #x8FB9D6) + (#x5A28 . #x8FB9D7) + (#x5A29 . #xCADA) + (#x5A2A . #x8FB9D8) + (#x5A2D . #x8FB9D9) + (#x5A2F . #xB8E4) + (#x5A30 . #x8FB9DA) + (#x5A35 . #xD5B7) + (#x5A36 . #xD5B8) + (#x5A3C . #xBEAB) + (#x5A40 . #xD5B4) + (#x5A41 . #xCFAC) + (#x5A44 . #x8FB9DB) + (#x5A45 . #x8FB9DC) + (#x5A46 . #xC7CC) + (#x5A47 . #x8FB9DD) + (#x5A48 . #x8FB9DE) + (#x5A49 . #xD5B6) + (#x5A4C . #x8FB9DF) + (#x5A50 . #x8FB9E0) + (#x5A55 . #x8FB9E1) + (#x5A5A . #xBAA7) + (#x5A5E . #x8FB9E2) + (#x5A62 . #xD5B9) + (#x5A63 . #x8FB9E3) + (#x5A65 . #x8FB9E4) + (#x5A66 . #xC9D8) + (#x5A67 . #x8FB9E5) + (#x5A6A . #xD5BA) + (#x5A6C . #xD5B5) + (#x5A6D . #x8FB9E6) + (#x5A77 . #x8FB9E7) + (#x5A7A . #x8FB9E8) + (#x5A7B . #x8FB9E9) + (#x5A7E . #x8FB9EA) + (#x5A7F . #xCCBB) + (#x5A8B . #x8FB9EB) + (#x5A90 . #x8FB9EC) + (#x5A92 . #xC7DE) + (#x5A93 . #x8FB9ED) + (#x5A96 . #x8FB9EE) + (#x5A99 . #x8FB9EF) + (#x5A9A . #xD5BB) + (#x5A9B . #xC9B2) + (#x5A9C . #x8FB9F0) + (#x5A9E . #x8FB9F1) + (#x5A9F . #x8FB9F2) + (#x5AA0 . #x8FB9F3) + (#x5AA2 . #x8FB9F4) + (#x5AA7 . #x8FB9F5) + (#x5AAC . #x8FB9F6) + (#x5AB1 . #x8FB9F7) + (#x5AB2 . #x8FB9F8) + (#x5AB3 . #x8FB9F9) + (#x5AB5 . #x8FB9FA) + (#x5AB8 . #x8FB9FB) + (#x5ABA . #x8FB9FC) + (#x5ABB . #x8FB9FD) + (#x5ABC . #xD5BC) + (#x5ABD . #xD5C0) + (#x5ABE . #xD5BD) + (#x5ABF . #x8FB9FE) + (#x5AC1 . #xB2C7) + (#x5AC2 . #xD5BF) + (#x5AC4 . #x8FBAA1) + (#x5AC6 . #x8FBAA2) + (#x5AC8 . #x8FBAA3) + (#x5AC9 . #xBCBB) + (#x5ACB . #xD5BE) + (#x5ACC . #xB7F9) + (#x5ACF . #x8FBAA4) + (#x5AD0 . #xD5CC) + (#x5AD6 . #xD5C5) + (#x5AD7 . #xD5C2) + (#x5ADA . #x8FBAA5) + (#x5ADC . #x8FBAA6) + (#x5AE0 . #x8FBAA7) + (#x5AE1 . #xC3E4) + (#x5AE3 . #xD5C1) + (#x5AE5 . #x8FBAA8) + (#x5AE6 . #xD5C3) + (#x5AE9 . #xD5C4) + (#x5AEA . #x8FBAA9) + (#x5AEE . #x8FBAAA) + (#x5AF5 . #x8FBAAB) + (#x5AF6 . #x8FBAAC) + (#x5AFA . #xD5C6) + (#x5AFB . #xD5C7) + (#x5AFD . #x8FBAAD) + (#x5B00 . #x8FBAAE) + (#x5B01 . #x8FBAAF) + (#x5B08 . #x8FBAB0) + (#x5B09 . #xB4F2) + (#x5B0B . #xD5C9) + (#x5B0C . #xD5C8) + (#x5B16 . #xD5CA) + (#x5B17 . #x8FBAB1) + (#x5B19 . #x8FBAB3) + (#x5B1B . #x8FBAB4) + (#x5B1D . #x8FBAB5) + (#x5B21 . #x8FBAB6) + (#x5B22 . #xBEEE) + (#x5B25 . #x8FBAB7) + (#x5B2A . #xD5CD) + (#x5B2C . #xC4DC) + (#x5B2D . #x8FBAB8) + (#x5B30 . #xB1C5) + (#x5B32 . #xD5CB) + (#x5B34 . #x8FBAB2) + (#x5B36 . #xD5CE) + (#x5B38 . #x8FBAB9) + (#x5B3E . #xD5CF) + (#x5B40 . #xD5D2) + (#x5B41 . #x8FBABA) + (#x5B43 . #xD5D0) + (#x5B45 . #xD5D1) + (#x5B4B . #x8FBABB) + (#x5B4C . #x8FBABC) + (#x5B50 . #xBBD2) + (#x5B51 . #xD5D3) + (#x5B52 . #x8FBABD) + (#x5B54 . #xB9A6) + (#x5B55 . #xD5D4) + (#x5B56 . #x8FBABE) + (#x5B57 . #xBBFA) + (#x5B58 . #xC2B8) + (#x5B5A . #xD5D5) + (#x5B5B . #xD5D6) + (#x5B5C . #xBBDA) + (#x5B5D . #xB9A7) + (#x5B5E . #x8FBABF) + (#x5B5F . #xCCD2) + (#x5B63 . #xB5A8) + (#x5B64 . #xB8C9) + (#x5B65 . #xD5D7) + (#x5B66 . #xB3D8) + (#x5B68 . #x8FBAC0) + (#x5B69 . #xD5D8) + (#x5B6B . #xC2B9) + (#x5B6E . #x8FBAC1) + (#x5B6F . #x8FBAC2) + (#x5B70 . #xD5D9) + (#x5B71 . #xD6A3) + (#x5B73 . #xD5DA) + (#x5B75 . #xD5DB) + (#x5B78 . #xD5DC) + (#x5B7A . #xD5DE) + (#x5B7C . #x8FBAC3) + (#x5B7D . #x8FBAC4) + (#x5B7E . #x8FBAC5) + (#x5B7F . #x8FBAC6) + (#x5B80 . #xD5DF) + (#x5B81 . #x8FBAC7) + (#x5B83 . #xD5E0) + (#x5B84 . #x8FBAC8) + (#x5B85 . #xC2F0) + (#x5B86 . #x8FBAC9) + (#x5B87 . #xB1A7) + (#x5B88 . #xBCE9) + (#x5B89 . #xB0C2) + (#x5B8A . #x8FBACA) + (#x5B8B . #xC1D7) + (#x5B8C . #xB4B0) + (#x5B8D . #xBCB5) + (#x5B8E . #x8FBACB) + (#x5B8F . #xB9A8) + (#x5B90 . #x8FBACC) + (#x5B91 . #x8FBACD) + (#x5B93 . #x8FBACE) + (#x5B94 . #x8FBACF) + (#x5B95 . #xC5E6) + (#x5B96 . #x8FBAD0) + (#x5B97 . #xBDA1) + (#x5B98 . #xB4B1) + (#x5B99 . #xC3E8) + (#x5B9A . #xC4EA) + (#x5B9B . #xB0B8) + (#x5B9C . #xB5B9) + (#x5B9D . #xCAF5) + (#x5B9F . #xBCC2) + (#x5BA2 . #xB5D2) + (#x5BA3 . #xC0EB) + (#x5BA4 . #xBCBC) + (#x5BA5 . #xCDA8) + (#x5BA6 . #xD5E1) + (#x5BA8 . #x8FBAD1) + (#x5BA9 . #x8FBAD2) + (#x5BAC . #x8FBAD3) + (#x5BAD . #x8FBAD4) + (#x5BAE . #xB5DC) + (#x5BAF . #x8FBAD5) + (#x5BB0 . #xBACB) + (#x5BB1 . #x8FBAD6) + (#x5BB2 . #x8FBAD7) + (#x5BB3 . #xB3B2) + (#x5BB4 . #xB1E3) + (#x5BB5 . #xBEAC) + (#x5BB6 . #xB2C8) + (#x5BB7 . #x8FBAD8) + (#x5BB8 . #xD5E2) + (#x5BB9 . #xCDC6) + (#x5BBA . #x8FBAD9) + (#x5BBC . #x8FBADA) + (#x5BBF . #xBDC9) + (#x5BC0 . #x8FBADB) + (#x5BC1 . #x8FBADC) + (#x5BC2 . #xBCE4) + (#x5BC3 . #xD5E3) + (#x5BC4 . #xB4F3) + (#x5BC5 . #xC6D2) + (#x5BC6 . #xCCA9) + (#x5BC7 . #xD5E4) + (#x5BC9 . #xD5E5) + (#x5BCC . #xC9D9) + (#x5BCD . #x8FBADD) + (#x5BCF . #x8FBADE) + (#x5BD0 . #xD5E7) + (#x5BD2 . #xB4A8) + (#x5BD3 . #xB6F7) + (#x5BD4 . #xD5E6) + (#x5BD6 . #x8FBADF) + (#x5BD7 . #x8FBAE0) + (#x5BD8 . #x8FBAE1) + (#x5BD9 . #x8FBAE2) + (#x5BDA . #x8FBAE3) + (#x5BDB . #xB4B2) + (#x5BDD . #xBFB2) + (#x5BDE . #xD5EB) + (#x5BDF . #xBBA1) + (#x5BE0 . #x8FBAE4) + (#x5BE1 . #xB2C9) + (#x5BE2 . #xD5EA) + (#x5BE4 . #xD5E8) + (#x5BE5 . #xD5EC) + (#x5BE6 . #xD5E9) + (#x5BE7 . #xC7AB) + (#x5BE8 . #xDCCD) + (#x5BE9 . #xBFB3) + (#x5BEB . #xD5ED) + (#x5BEE . #xCEC0) + (#x5BEF . #x8FBAE5) + (#x5BF0 . #xD5EE) + (#x5BF1 . #x8FBAE6) + (#x5BF3 . #xD5F0) + (#x5BF4 . #x8FBAE7) + (#x5BF5 . #xC3FE) + (#x5BF6 . #xD5EF) + (#x5BF8 . #xC0A3) + (#x5BFA . #xBBFB) + (#x5BFD . #x8FBAE8) + (#x5BFE . #xC2D0) + (#x5BFF . #xBCF7) + (#x5C01 . #xC9F5) + (#x5C02 . #xC0EC) + (#x5C04 . #xBCCD) + (#x5C05 . #xD5F1) + (#x5C06 . #xBEAD) + (#x5C07 . #xD5F2) + (#x5C08 . #xD5F3) + (#x5C09 . #xB0D3) + (#x5C0A . #xC2BA) + (#x5C0B . #xBFD2) + (#x5C0C . #x8FBAE9) + (#x5C0D . #xD5F4) + (#x5C0E . #xC6B3) + (#x5C0F . #xBEAE) + (#x5C11 . #xBEAF) + (#x5C13 . #xD5F5) + (#x5C16 . #xC0ED) + (#x5C17 . #x8FBAEA) + (#x5C1A . #xBEB0) + (#x5C1E . #x8FBAEB) + (#x5C1F . #x8FBAEC) + (#x5C20 . #xD5F6) + (#x5C22 . #xD5F7) + (#x5C23 . #x8FBAED) + (#x5C24 . #xCCE0) + (#x5C26 . #x8FBAEE) + (#x5C28 . #xD5F8) + (#x5C29 . #x8FBAEF) + (#x5C2B . #x8FBAF0) + (#x5C2C . #x8FBAF1) + (#x5C2D . #xB6C6) + (#x5C2E . #x8FBAF2) + (#x5C30 . #x8FBAF3) + (#x5C31 . #xBDA2) + (#x5C32 . #x8FBAF4) + (#x5C35 . #x8FBAF5) + (#x5C36 . #x8FBAF6) + (#x5C38 . #xD5F9) + (#x5C39 . #xD5FA) + (#x5C3A . #xBCDC) + (#x5C3B . #xBFAC) + (#x5C3C . #xC6F4) + (#x5C3D . #xBFD4) + (#x5C3E . #xC8F8) + (#x5C3F . #xC7A2) + (#x5C40 . #xB6C9) + (#x5C41 . #xD5FB) + (#x5C45 . #xB5EF) + (#x5C46 . #xD5FC) + (#x5C48 . #xB6FE) + (#x5C4A . #xC6CF) + (#x5C4B . #xB2B0) + (#x5C4D . #xBBD3) + (#x5C4E . #xD5FD) + (#x5C4F . #xD6A2) + (#x5C50 . #xD6A1) + (#x5C51 . #xB6FD) + (#x5C53 . #xD5FE) + (#x5C55 . #xC5B8) + (#x5C59 . #x8FBAF7) + (#x5C5A . #x8FBAF8) + (#x5C5C . #x8FBAF9) + (#x5C5E . #xC2B0) + (#x5C60 . #xC5CB) + (#x5C61 . #xBCC8) + (#x5C62 . #x8FBAFA) + (#x5C63 . #x8FBAFB) + (#x5C64 . #xC1D8) + (#x5C65 . #xCDFA) + (#x5C67 . #x8FBAFC) + (#x5C68 . #x8FBAFD) + (#x5C69 . #x8FBAFE) + (#x5C6C . #xD6A4) + (#x5C6D . #x8FBBA1) + (#x5C6E . #xD6A5) + (#x5C6F . #xC6D6) + (#x5C70 . #x8FBBA2) + (#x5C71 . #xBBB3) + (#x5C74 . #x8FBBA3) + (#x5C75 . #x8FBBA4) + (#x5C76 . #xD6A7) + (#x5C79 . #xD6A8) + (#x5C7A . #x8FBBA5) + (#x5C7B . #x8FBBA6) + (#x5C7C . #x8FBBA7) + (#x5C7D . #x8FBBA8) + (#x5C87 . #x8FBBA9) + (#x5C88 . #x8FBBAA) + (#x5C8A . #x8FBBAB) + (#x5C8C . #xD6A9) + (#x5C8F . #x8FBBAC) + (#x5C90 . #xB4F4) + (#x5C91 . #xD6AA) + (#x5C92 . #x8FBBAD) + (#x5C94 . #xD6AB) + (#x5C9D . #x8FBBAE) + (#x5C9F . #x8FBBAF) + (#x5CA0 . #x8FBBB0) + (#x5CA1 . #xB2AC) + (#x5CA2 . #x8FBBB1) + (#x5CA3 . #x8FBBB2) + (#x5CA6 . #x8FBBB3) + (#x5CA8 . #xC1BB) + (#x5CA9 . #xB4E4) + (#x5CAA . #x8FBBB4) + (#x5CAB . #xD6AD) + (#x5CAC . #xCCA8) + (#x5CB1 . #xC2D2) + (#x5CB2 . #x8FBBB5) + (#x5CB3 . #xB3D9) + (#x5CB4 . #x8FBBB6) + (#x5CB5 . #x8FBBB7) + (#x5CB6 . #xD6AF) + (#x5CB7 . #xD6B1) + (#x5CB8 . #xB4DF) + (#x5CBA . #x8FBBB8) + (#x5CBB . #xD6AE) + (#x5CBC . #xD6B0) + (#x5CBE . #xD6B3) + (#x5CC5 . #xD6B2) + (#x5CC7 . #xD6B4) + (#x5CC9 . #x8FBBB9) + (#x5CCB . #x8FBBBA) + (#x5CD2 . #x8FBBBB) + (#x5CD7 . #x8FBBBD) + (#x5CD9 . #xD6B5) + (#x5CDD . #x8FBBBC) + (#x5CE0 . #xC6BD) + (#x5CE1 . #xB6AE) + (#x5CE8 . #xB2E5) + (#x5CE9 . #xD6B6) + (#x5CEA . #xD6BB) + (#x5CED . #xD6B9) + (#x5CEE . #x8FBBBE) + (#x5CEF . #xCAF7) + (#x5CF0 . #xCAF6) + (#x5CF1 . #x8FBBBF) + (#x5CF2 . #x8FBBC0) + (#x5CF4 . #x8FBBC1) + (#x5CF6 . #xC5E7) + (#x5CFA . #xD6B8) + (#x5CFB . #xBDD4) + (#x5CFD . #xD6B7) + (#x5D01 . #x8FBBC2) + (#x5D06 . #x8FBBC3) + (#x5D07 . #xBFF2) + (#x5D0B . #xD6BC) + (#x5D0D . #x8FBBC4) + (#x5D0E . #xBAEA) + (#x5D11 . #xD6C2) + (#x5D12 . #x8FBBC5) + (#x5D14 . #xD6C3) + (#x5D15 . #xD6BD) + (#x5D16 . #xB3B3) + (#x5D17 . #xD6BE) + (#x5D18 . #xD6C7) + (#x5D19 . #xD6C6) + (#x5D1A . #xD6C5) + (#x5D1B . #xD6C1) + (#x5D1F . #xD6C0) + (#x5D22 . #xD6C4) + (#x5D23 . #x8FBBC7) + (#x5D24 . #x8FBBC8) + (#x5D26 . #x8FBBC9) + (#x5D27 . #x8FBBCA) + (#x5D29 . #xCAF8) + (#x5D2B . #x8FBBC6) + (#x5D31 . #x8FBBCB) + (#x5D34 . #x8FBBCC) + (#x5D39 . #x8FBBCD) + (#x5D3D . #x8FBBCE) + (#x5D3F . #x8FBBCF) + (#x5D42 . #x8FBBD0) + (#x5D43 . #x8FBBD1) + (#x5D46 . #x8FBBD2) + (#x5D48 . #x8FBBD3) + (#x5D4A . #x8FBBD7) + (#x5D4B . #xD6CB) + (#x5D4C . #xD6C8) + (#x5D4E . #xD6CA) + (#x5D50 . #xCDF2) + (#x5D51 . #x8FBBD5) + (#x5D52 . #xD6C9) + (#x5D55 . #x8FBBD4) + (#x5D59 . #x8FBBD6) + (#x5D5C . #xD6BF) + (#x5D5F . #x8FBBD8) + (#x5D60 . #x8FBBD9) + (#x5D61 . #x8FBBDA) + (#x5D62 . #x8FBBDB) + (#x5D64 . #x8FBBDC) + (#x5D69 . #xBFF3) + (#x5D6A . #x8FBBDD) + (#x5D6C . #xD6CC) + (#x5D6D . #x8FBBDE) + (#x5D6F . #xBAB7) + (#x5D70 . #x8FBBDF) + (#x5D73 . #xD6CD) + (#x5D76 . #xD6CE) + (#x5D79 . #x8FBBE0) + (#x5D7A . #x8FBBE1) + (#x5D7E . #x8FBBE2) + (#x5D7F . #x8FBBE3) + (#x5D81 . #x8FBBE4) + (#x5D82 . #xD6D1) + (#x5D83 . #x8FBBE5) + (#x5D84 . #xD6D0) + (#x5D87 . #xD6CF) + (#x5D88 . #x8FBBE6) + (#x5D8A . #x8FBBE7) + (#x5D8B . #xC5E8) + (#x5D8C . #xD6BA) + (#x5D90 . #xD6D7) + (#x5D92 . #x8FBBE8) + (#x5D93 . #x8FBBE9) + (#x5D94 . #x8FBBEA) + (#x5D95 . #x8FBBEB) + (#x5D99 . #x8FBBEC) + (#x5D9B . #x8FBBED) + (#x5D9D . #xD6D3) + (#x5D9F . #x8FBBEE) + (#x5DA0 . #x8FBBEF) + (#x5DA2 . #xD6D2) + (#x5DA7 . #x8FBBF0) + (#x5DAB . #x8FBBF1) + (#x5DAC . #xD6D4) + (#x5DAE . #xD6D5) + (#x5DB0 . #x8FBBF2) + (#x5DB2 . #x8FE6F4) + (#x5DB4 . #x8FBBF3) + (#x5DB7 . #xD6D8) + (#x5DB8 . #x8FBBF4) + (#x5DB9 . #x8FBBF5) + (#x5DBA . #xCEE6) + (#x5DBC . #xD6D9) + (#x5DBD . #xD6D6) + (#x5DC3 . #x8FBBF6) + (#x5DC7 . #x8FBBF7) + (#x5DC9 . #xD6DA) + (#x5DCB . #x8FBBF8) + (#x5DCC . #xB4E0) + (#x5DCD . #xD6DB) + (#x5DCE . #x8FBBFA) + (#x5DD0 . #x8FBBF9) + (#x5DD2 . #xD6DD) + (#x5DD3 . #xD6DC) + (#x5DD6 . #xD6DE) + (#x5DD8 . #x8FBBFB) + (#x5DD9 . #x8FBBFC) + (#x5DDB . #xD6DF) + (#x5DDD . #xC0EE) + (#x5DDE . #xBDA3) + (#x5DE0 . #x8FBBFD) + (#x5DE1 . #xBDE4) + (#x5DE3 . #xC1E3) + (#x5DE4 . #x8FBBFE) + (#x5DE5 . #xB9A9) + (#x5DE6 . #xBAB8) + (#x5DE7 . #xB9AA) + (#x5DE8 . #xB5F0) + (#x5DE9 . #x8FBCA1) + (#x5DEB . #xD6E0) + (#x5DEE . #xBAB9) + (#x5DF1 . #xB8CA) + (#x5DF2 . #xD6E1) + (#x5DF3 . #xCCA6) + (#x5DF4 . #xC7C3) + (#x5DF5 . #xD6E2) + (#x5DF7 . #xB9AB) + (#x5DF8 . #x8FBCA2) + (#x5DF9 . #x8FBCA3) + (#x5DFB . #xB4AC) + (#x5DFD . #xC3A7) + (#x5DFE . #xB6D2) + (#x5E00 . #x8FBCA4) + (#x5E02 . #xBBD4) + (#x5E03 . #xC9DB) + (#x5E06 . #xC8C1) + (#x5E07 . #x8FBCA5) + (#x5E0B . #xD6E3) + (#x5E0C . #xB4F5) + (#x5E0D . #x8FBCA6) + (#x5E11 . #xD6E6) + (#x5E12 . #x8FBCA7) + (#x5E14 . #x8FBCA8) + (#x5E15 . #x8FBCA9) + (#x5E16 . #xC4A1) + (#x5E18 . #x8FBCAA) + (#x5E19 . #xD6E5) + (#x5E1A . #xD6E4) + (#x5E1B . #xD6E7) + (#x5E1D . #xC4EB) + (#x5E1F . #x8FBCAB) + (#x5E20 . #x8FBCAC) + (#x5E25 . #xBFE3) + (#x5E28 . #x8FBCAE) + (#x5E2B . #xBBD5) + (#x5E2D . #xC0CA) + (#x5E2E . #x8FBCAD) + (#x5E2F . #xC2D3) + (#x5E30 . #xB5A2) + (#x5E32 . #x8FBCAF) + (#x5E33 . #xC4A2) + (#x5E35 . #x8FBCB0) + (#x5E36 . #xD6E8) + (#x5E37 . #xD6E9) + (#x5E38 . #xBEEF) + (#x5E3D . #xCBB9) + (#x5E3E . #x8FBCB1) + (#x5E40 . #xD6EC) + (#x5E43 . #xD6EB) + (#x5E44 . #xD6EA) + (#x5E45 . #xC9FD) + (#x5E47 . #xD6F3) + (#x5E49 . #x8FBCB4) + (#x5E4B . #x8FBCB2) + (#x5E4C . #xCBDA) + (#x5E4E . #xD6ED) + (#x5E50 . #x8FBCB3) + (#x5E51 . #x8FBCB5) + (#x5E54 . #xD6EF) + (#x5E55 . #xCBEB) + (#x5E56 . #x8FBCB6) + (#x5E57 . #xD6EE) + (#x5E58 . #x8FBCB7) + (#x5E5B . #x8FBCB8) + (#x5E5C . #x8FBCB9) + (#x5E5E . #x8FBCBA) + (#x5E5F . #xD6F0) + (#x5E61 . #xC8A8) + (#x5E62 . #xD6F1) + (#x5E63 . #xCABE) + (#x5E64 . #xD6F2) + (#x5E68 . #x8FBCBB) + (#x5E6A . #x8FBCBC) + (#x5E6B . #x8FBCBD) + (#x5E6C . #x8FBCBE) + (#x5E6D . #x8FBCBF) + (#x5E6E . #x8FBCC0) + (#x5E70 . #x8FBCC1) + (#x5E72 . #xB4B3) + (#x5E73 . #xCABF) + (#x5E74 . #xC7AF) + (#x5E75 . #xD6F4) + (#x5E76 . #xD6F5) + (#x5E78 . #xB9AC) + (#x5E79 . #xB4B4) + (#x5E7A . #xD6F6) + (#x5E7B . #xB8B8) + (#x5E7C . #xCDC4) + (#x5E7D . #xCDA9) + (#x5E7E . #xB4F6) + (#x5E7F . #xD6F8) + (#x5E80 . #x8FBCC2) + (#x5E81 . #xC4A3) + (#x5E83 . #xB9AD) + (#x5E84 . #xBEB1) + (#x5E87 . #xC8DF) + (#x5E8A . #xBEB2) + (#x5E8B . #x8FBCC3) + (#x5E8E . #x8FBCC4) + (#x5E8F . #xBDF8) + (#x5E95 . #xC4EC) + (#x5E96 . #xCAF9) + (#x5E97 . #xC5B9) + (#x5E9A . #xB9AE) + (#x5E9C . #xC9DC) + (#x5EA0 . #xD6F9) + (#x5EA2 . #x8FBCC5) + (#x5EA4 . #x8FBCC6) + (#x5EA5 . #x8FBCC7) + (#x5EA6 . #xC5D9) + (#x5EA7 . #xBAC2) + (#x5EA8 . #x8FBCC8) + (#x5EAA . #x8FBCC9) + (#x5EAB . #xB8CB) + (#x5EAC . #x8FBCCA) + (#x5EAD . #xC4ED) + (#x5EB1 . #x8FBCCB) + (#x5EB3 . #x8FBCCC) + (#x5EB5 . #xB0C3) + (#x5EB6 . #xBDEE) + (#x5EB7 . #xB9AF) + (#x5EB8 . #xCDC7) + (#x5EBD . #x8FBCCD) + (#x5EBE . #x8FBCCE) + (#x5EBF . #x8FBCCF) + (#x5EC1 . #xD6FA) + (#x5EC2 . #xD6FB) + (#x5EC3 . #xC7D1) + (#x5EC6 . #x8FBCD0) + (#x5EC8 . #xD6FC) + (#x5EC9 . #xCEF7) + (#x5ECA . #xCFAD) + (#x5ECB . #x8FBCD2) + (#x5ECC . #x8FBCD1) + (#x5ECE . #x8FBCD3) + (#x5ECF . #xD6FE) + (#x5ED0 . #xD6FD) + (#x5ED1 . #x8FBCD4) + (#x5ED2 . #x8FBCD5) + (#x5ED3 . #xB3C7) + (#x5ED4 . #x8FBCD6) + (#x5ED5 . #x8FBCD7) + (#x5ED6 . #xD7A1) + (#x5EDA . #xD7A4) + (#x5EDB . #xD7A5) + (#x5EDC . #x8FBCD8) + (#x5EDD . #xD7A3) + (#x5EDE . #x8FBCD9) + (#x5EDF . #xC9C0) + (#x5EE0 . #xBEB3) + (#x5EE1 . #xD7A7) + (#x5EE2 . #xD7A6) + (#x5EE3 . #xD7A2) + (#x5EE5 . #x8FBCDA) + (#x5EE8 . #xD7A8) + (#x5EE9 . #xD7A9) + (#x5EEB . #x8FBCDB) + (#x5EEC . #xD7AA) + (#x5EF0 . #xD7AD) + (#x5EF1 . #xD7AB) + (#x5EF3 . #xD7AC) + (#x5EF4 . #xD7AE) + (#x5EF6 . #xB1E4) + (#x5EF7 . #xC4EE) + (#x5EF8 . #xD7AF) + (#x5EFA . #xB7FA) + (#x5EFB . #xB2F6) + (#x5EFC . #xC7B6) + (#x5EFE . #xD7B0) + (#x5EFF . #xC6FB) + (#x5F01 . #xCADB) + (#x5F02 . #x8FBCDC) + (#x5F03 . #xD7B1) + (#x5F04 . #xCFAE) + (#x5F06 . #x8FBCDD) + (#x5F07 . #x8FBCDE) + (#x5F08 . #x8FBCDF) + (#x5F09 . #xD7B2) + (#x5F0A . #xCAC0) + (#x5F0B . #xD7B5) + (#x5F0C . #xD0A1) + (#x5F0D . #xD0B1) + (#x5F0E . #x8FBCE0) + (#x5F0F . #xBCB0) + (#x5F10 . #xC6F5) + (#x5F11 . #xD7B6) + (#x5F13 . #xB5DD) + (#x5F14 . #xC4A4) + (#x5F15 . #xB0FA) + (#x5F16 . #xD7B7) + (#x5F17 . #xCAA6) + (#x5F18 . #xB9B0) + (#x5F19 . #x8FBCE1) + (#x5F1B . #xC3D0) + (#x5F1C . #x8FBCE2) + (#x5F1D . #x8FBCE3) + (#x5F1F . #xC4EF) + (#x5F21 . #x8FBCE4) + (#x5F22 . #x8FBCE5) + (#x5F23 . #x8FBCE6) + (#x5F24 . #x8FBCE7) + (#x5F25 . #xCCEF) + (#x5F26 . #xB8B9) + (#x5F27 . #xB8CC) + (#x5F28 . #x8FBCE8) + (#x5F29 . #xD7B8) + (#x5F2B . #x8FBCE9) + (#x5F2C . #x8FBCEA) + (#x5F2D . #xD7B9) + (#x5F2E . #x8FBCEB) + (#x5F2F . #xD7BF) + (#x5F30 . #x8FBCEC) + (#x5F31 . #xBCE5) + (#x5F34 . #x8FBCED) + (#x5F35 . #xC4A5) + (#x5F36 . #x8FBCEE) + (#x5F37 . #xB6AF) + (#x5F38 . #xD7BA) + (#x5F3B . #x8FBCEF) + (#x5F3C . #xC9AB) + (#x5F3D . #x8FBCF0) + (#x5F3E . #xC3C6) + (#x5F3F . #x8FBCF1) + (#x5F40 . #x8FBCF2) + (#x5F41 . #xD7BB) + (#x5F44 . #x8FBCF3) + (#x5F45 . #x8FBCF4) + (#x5F47 . #x8FBCF5) + (#x5F48 . #xD7BC) + (#x5F4A . #xB6B0) + (#x5F4C . #xD7BD) + (#x5F4D . #x8FBCF6) + (#x5F4E . #xD7BE) + (#x5F50 . #x8FBCF7) + (#x5F51 . #xD7C0) + (#x5F53 . #xC5F6) + (#x5F54 . #x8FBCF8) + (#x5F56 . #xD7C1) + (#x5F57 . #xD7C2) + (#x5F58 . #x8FBCF9) + (#x5F59 . #xD7C3) + (#x5F5B . #x8FBCFA) + (#x5F5C . #xD7B4) + (#x5F5D . #xD7B3) + (#x5F60 . #x8FBCFB) + (#x5F61 . #xD7C4) + (#x5F62 . #xB7C1) + (#x5F63 . #x8FBCFC) + (#x5F64 . #x8FBCFD) + (#x5F66 . #xC9A7) + (#x5F67 . #x8FBCFE) + (#x5F69 . #xBACC) + (#x5F6A . #xC9B7) + (#x5F6B . #xC4A6) + (#x5F6C . #xC9CB) + (#x5F6D . #xD7C5) + (#x5F6F . #x8FBDA1) + (#x5F70 . #xBEB4) + (#x5F71 . #xB1C6) + (#x5F72 . #x8FBDA2) + (#x5F73 . #xD7C6) + (#x5F74 . #x8FBDA3) + (#x5F75 . #x8FBDA4) + (#x5F77 . #xD7C7) + (#x5F78 . #x8FBDA5) + (#x5F79 . #xCCF2) + (#x5F7A . #x8FBDA6) + (#x5F7C . #xC8E0) + (#x5F7D . #x8FBDA7) + (#x5F7E . #x8FBDA8) + (#x5F7F . #xD7CA) + (#x5F80 . #xB1FD) + (#x5F81 . #xC0AC) + (#x5F82 . #xD7C9) + (#x5F83 . #xD7C8) + (#x5F84 . #xB7C2) + (#x5F85 . #xC2D4) + (#x5F87 . #xD7CE) + (#x5F88 . #xD7CC) + (#x5F89 . #x8FBDA9) + (#x5F8A . #xD7CB) + (#x5F8B . #xCEA7) + (#x5F8C . #xB8E5) + (#x5F8D . #x8FBDAA) + (#x5F8F . #x8FBDAB) + (#x5F90 . #xBDF9) + (#x5F91 . #xD7CD) + (#x5F92 . #xC5CC) + (#x5F93 . #xBDBE) + (#x5F96 . #x8FBDAC) + (#x5F97 . #xC6C0) + (#x5F98 . #xD7D1) + (#x5F99 . #xD7D0) + (#x5F9C . #x8FBDAD) + (#x5F9D . #x8FBDAE) + (#x5F9E . #xD7CF) + (#x5FA0 . #xD7D2) + (#x5FA1 . #xB8E6) + (#x5FA2 . #x8FBDAF) + (#x5FA4 . #x8FBDB2) + (#x5FA7 . #x8FBDB0) + (#x5FA8 . #xD7D3) + (#x5FA9 . #xC9FC) + (#x5FAA . #xBDDB) + (#x5FAB . #x8FBDB1) + (#x5FAC . #x8FBDB3) + (#x5FAD . #xD7D4) + (#x5FAE . #xC8F9) + (#x5FAF . #x8FBDB4) + (#x5FB0 . #x8FBDB5) + (#x5FB1 . #x8FBDB6) + (#x5FB3 . #xC6C1) + (#x5FB4 . #xC4A7) + (#x5FB8 . #x8FBDB7) + (#x5FB9 . #xC5B0) + (#x5FBC . #xD7D5) + (#x5FBD . #xB5AB) + (#x5FC3 . #xBFB4) + (#x5FC4 . #x8FBDB8) + (#x5FC5 . #xC9AC) + (#x5FC7 . #x8FBDB9) + (#x5FC8 . #x8FBDBA) + (#x5FC9 . #x8FBDBB) + (#x5FCB . #x8FBDBC) + (#x5FCC . #xB4F7) + (#x5FCD . #xC7A6) + (#x5FD0 . #x8FBDBD) + (#x5FD1 . #x8FBDBE) + (#x5FD2 . #x8FBDBF) + (#x5FD3 . #x8FBDC0) + (#x5FD4 . #x8FBDC1) + (#x5FD6 . #xD7D6) + (#x5FD7 . #xBBD6) + (#x5FD8 . #xCBBA) + (#x5FD9 . #xCBBB) + (#x5FDC . #xB1FE) + (#x5FDD . #xD7DB) + (#x5FDE . #x8FBDC2) + (#x5FE0 . #xC3E9) + (#x5FE1 . #x8FBDC3) + (#x5FE2 . #x8FBDC4) + (#x5FE4 . #xD7D8) + (#x5FE8 . #x8FBDC5) + (#x5FE9 . #x8FBDC6) + (#x5FEA . #x8FBDC7) + (#x5FEB . #xB2F7) + (#x5FEC . #x8FBDC8) + (#x5FED . #x8FBDC9) + (#x5FEE . #x8FBDCA) + (#x5FEF . #x8FBDCB) + (#x5FF0 . #xD8AD) + (#x5FF1 . #xD7DA) + (#x5FF2 . #x8FBDCC) + (#x5FF3 . #x8FBDCD) + (#x5FF5 . #xC7B0) + (#x5FF6 . #x8FBDCE) + (#x5FF8 . #xD7D9) + (#x5FFA . #x8FBDCF) + (#x5FFB . #xD7D7) + (#x5FFC . #x8FBDD0) + (#x5FFD . #xB9FA) + (#x5FFF . #xD7DD) + (#x6007 . #x8FBDD1) + (#x600A . #x8FBDD2) + (#x600D . #x8FBDD3) + (#x600E . #xD7E3) + (#x600F . #xD7E9) + (#x6010 . #xD7E1) + (#x6012 . #xC5DC) + (#x6013 . #x8FBDD4) + (#x6014 . #x8FBDD5) + (#x6015 . #xD7E6) + (#x6016 . #xC9DD) + (#x6017 . #x8FBDD6) + (#x6018 . #x8FBDD7) + (#x6019 . #xD7E0) + (#x601A . #x8FBDD8) + (#x601B . #xD7E5) + (#x601C . #xCEE7) + (#x601D . #xBBD7) + (#x601F . #x8FBDD9) + (#x6020 . #xC2D5) + (#x6021 . #xD7DE) + (#x6024 . #x8FBDDA) + (#x6025 . #xB5DE) + (#x6026 . #xD7E8) + (#x6027 . #xC0AD) + (#x6028 . #xB1E5) + (#x6029 . #xD7E2) + (#x602A . #xB2F8) + (#x602B . #xD7E7) + (#x602D . #x8FBDDB) + (#x602F . #xB6B1) + (#x6031 . #xD7E4) + (#x6033 . #x8FBDDC) + (#x6035 . #x8FBDDD) + (#x603A . #xD7EA) + (#x6040 . #x8FBDDE) + (#x6041 . #xD7EC) + (#x6042 . #xD7F6) + (#x6043 . #xD7F4) + (#x6046 . #xD7F1) + (#x6047 . #x8FBDDF) + (#x6048 . #x8FBDE0) + (#x6049 . #x8FBDE1) + (#x604A . #xD7F0) + (#x604B . #xCEF8) + (#x604C . #x8FBDE2) + (#x604D . #xD7F2) + (#x6050 . #xB6B2) + (#x6051 . #x8FBDE3) + (#x6052 . #xB9B1) + (#x6054 . #x8FBDE4) + (#x6055 . #xBDFA) + (#x6056 . #x8FBDE5) + (#x6057 . #x8FBDE6) + (#x6059 . #xD7F9) + (#x605A . #xD7EB) + (#x605D . #x8FBDE7) + (#x605F . #xD7EF) + (#x6060 . #xD7DF) + (#x6061 . #x8FBDE8) + (#x6062 . #xB2FA) + (#x6063 . #xD7F3) + (#x6064 . #xD7F5) + (#x6065 . #xC3D1) + (#x6067 . #x8FBDE9) + (#x6068 . #xBAA8) + (#x6069 . #xB2B8) + (#x606A . #xD7ED) + (#x606B . #xD7F8) + (#x606C . #xD7F7) + (#x606D . #xB6B3) + (#x606F . #xC2A9) + (#x6070 . #xB3E6) + (#x6071 . #x8FBDEA) + (#x6075 . #xB7C3) + (#x6077 . #xD7EE) + (#x607E . #x8FBDEB) + (#x607F . #x8FBDEC) + (#x6081 . #xD7FA) + (#x6082 . #x8FBDED) + (#x6083 . #xD7FD) + (#x6084 . #xD8A1) + (#x6086 . #x8FBDEE) + (#x6088 . #x8FBDEF) + (#x6089 . #xBCBD) + (#x608A . #x8FBDF0) + (#x608B . #xD8A7) + (#x608C . #xC4F0) + (#x608D . #xD7FB) + (#x608E . #x8FBDF1) + (#x6091 . #x8FBDF2) + (#x6092 . #xD8A5) + (#x6093 . #x8FBDF3) + (#x6094 . #xB2F9) + (#x6095 . #x8FBDF4) + (#x6096 . #xD8A3) + (#x6097 . #xD8A4) + (#x6098 . #x8FBDF5) + (#x609A . #xD7FE) + (#x609B . #xD8A2) + (#x609D . #x8FBDF6) + (#x609E . #x8FBDF7) + (#x609F . #xB8E7) + (#x60A0 . #xCDAA) + (#x60A2 . #x8FBDF8) + (#x60A3 . #xB4B5) + (#x60A4 . #x8FBDF9) + (#x60A5 . #x8FBDFA) + (#x60A6 . #xB1D9) + (#x60A7 . #xD8A6) + (#x60A8 . #x8FBDFB) + (#x60A9 . #xC7BA) + (#x60AA . #xB0AD) + (#x60B0 . #x8FBDFC) + (#x60B1 . #x8FBDFD) + (#x60B2 . #xC8E1) + (#x60B3 . #xD7DC) + (#x60B4 . #xD8AC) + (#x60B5 . #xD8B0) + (#x60B6 . #xCCE5) + (#x60B7 . #x8FBDFE) + (#x60B8 . #xD8A9) + (#x60BB . #x8FBEA1) + (#x60BC . #xC5E9) + (#x60BD . #xD8AE) + (#x60BE . #x8FBEA2) + (#x60C2 . #x8FBEA3) + (#x60C4 . #x8FBEA4) + (#x60C5 . #xBEF0) + (#x60C6 . #xD8AF) + (#x60C7 . #xC6D7) + (#x60C8 . #x8FBEA5) + (#x60C9 . #x8FBEA6) + (#x60CA . #x8FBEA7) + (#x60CB . #x8FBEA8) + (#x60CE . #x8FBEA9) + (#x60CF . #x8FBEAA) + (#x60D1 . #xCFC7) + (#x60D3 . #xD8AB) + (#x60D4 . #x8FBEAB) + (#x60D5 . #x8FBEAC) + (#x60D8 . #xD8B1) + (#x60D9 . #x8FBEAD) + (#x60DA . #xB9FB) + (#x60DB . #x8FBEAE) + (#x60DC . #xC0CB) + (#x60DD . #x8FBEAF) + (#x60DE . #x8FBEB0) + (#x60DF . #xB0D4) + (#x60E0 . #xD8AA) + (#x60E1 . #xD8A8) + (#x60E2 . #x8FBEB1) + (#x60E3 . #xC1DA) + (#x60E5 . #x8FBEB2) + (#x60E7 . #xD7FC) + (#x60E8 . #xBBB4) + (#x60F0 . #xC2C6) + (#x60F1 . #xD8BD) + (#x60F2 . #x8FBEB3) + (#x60F3 . #xC1DB) + (#x60F4 . #xD8B8) + (#x60F5 . #x8FBEB4) + (#x60F6 . #xD8B5) + (#x60F7 . #xD8B6) + (#x60F8 . #x8FBEB5) + (#x60F9 . #xBCE6) + (#x60FA . #xD8B9) + (#x60FB . #xD8BC) + (#x60FC . #x8FBEB6) + (#x60FD . #x8FBEB7) + (#x6100 . #xD8B7) + (#x6101 . #xBDA5) + (#x6102 . #x8FBEB8) + (#x6103 . #xD8BA) + (#x6106 . #xD8B4) + (#x6107 . #x8FBEB9) + (#x6108 . #xCCFC) + (#x6109 . #xCCFB) + (#x610A . #x8FBEBA) + (#x610C . #x8FBEBB) + (#x610D . #xD8BE) + (#x610E . #xD8BF) + (#x610F . #xB0D5) + (#x6110 . #x8FBEBC) + (#x6111 . #x8FBEBD) + (#x6112 . #x8FBEBE) + (#x6113 . #x8FBEBF) + (#x6114 . #x8FBEC0) + (#x6115 . #xD8B3) + (#x6116 . #x8FBEC1) + (#x6117 . #x8FBEC2) + (#x6119 . #x8FBEC3) + (#x611A . #xB6F2) + (#x611B . #xB0A6) + (#x611C . #x8FBEC4) + (#x611E . #x8FBEC5) + (#x611F . #xB4B6) + (#x6121 . #xD8BB) + (#x6122 . #x8FBEC6) + (#x6127 . #xD8C3) + (#x6128 . #xD8C2) + (#x612A . #x8FBEC7) + (#x612B . #x8FBEC8) + (#x612C . #xD8C7) + (#x6130 . #x8FBEC9) + (#x6131 . #x8FBECA) + (#x6134 . #xD8C8) + (#x6135 . #x8FBECB) + (#x6136 . #x8FBECC) + (#x6137 . #x8FBECD) + (#x6139 . #x8FBECE) + (#x613C . #xD8C6) + (#x613D . #xD8C9) + (#x613E . #xD8C1) + (#x613F . #xD8C5) + (#x6141 . #x8FBECF) + (#x6142 . #xD8CA) + (#x6144 . #xD8CB) + (#x6145 . #x8FBED0) + (#x6146 . #x8FBED1) + (#x6147 . #xD8C0) + (#x6148 . #xBBFC) + (#x6149 . #x8FBED2) + (#x614A . #xD8C4) + (#x614B . #xC2D6) + (#x614C . #xB9B2) + (#x614D . #xD8B2) + (#x614E . #xBFB5) + (#x6153 . #xD8D8) + (#x6155 . #xCAE9) + (#x6158 . #xD8CE) + (#x6159 . #xD8CF) + (#x615A . #xD8D0) + (#x615D . #xD8D7) + (#x615E . #x8FBED3) + (#x615F . #xD8D6) + (#x6160 . #x8FBED4) + (#x6162 . #xCBFD) + (#x6163 . #xB4B7) + (#x6165 . #xD8D4) + (#x6167 . #xB7C5) + (#x6168 . #xB3B4) + (#x616B . #xD8D1) + (#x616C . #x8FBED5) + (#x616E . #xCEB8) + (#x616F . #xD8D3) + (#x6170 . #xB0D6) + (#x6171 . #xD8D5) + (#x6172 . #x8FBED6) + (#x6173 . #xD8CC) + (#x6174 . #xD8D2) + (#x6175 . #xD8D9) + (#x6176 . #xB7C4) + (#x6177 . #xD8CD) + (#x6178 . #x8FBED7) + (#x617B . #x8FBED8) + (#x617C . #x8FBED9) + (#x617E . #xCDDD) + (#x617F . #x8FBEDA) + (#x6180 . #x8FBEDB) + (#x6181 . #x8FBEDC) + (#x6182 . #xCDAB) + (#x6183 . #x8FBEDD) + (#x6184 . #x8FBEDE) + (#x6187 . #xD8DC) + (#x618A . #xD8E0) + (#x618B . #x8FBEDF) + (#x618D . #x8FBEE0) + (#x618E . #xC1FE) + (#x6190 . #xCEF9) + (#x6191 . #xD8E1) + (#x6192 . #x8FBEE1) + (#x6193 . #x8FBEE2) + (#x6194 . #xD8DE) + (#x6196 . #xD8DB) + (#x6197 . #x8FBEE3) + (#x6198 . #x8FBEE4) + (#x6199 . #xD8DA) + (#x619A . #xD8DF) + (#x619C . #x8FBEE5) + (#x619D . #x8FBEE6) + (#x619F . #x8FBEE7) + (#x61A0 . #x8FBEE8) + (#x61A4 . #xCAB0) + (#x61A5 . #x8FBEE9) + (#x61A7 . #xC6B4) + (#x61A8 . #x8FBEEA) + (#x61A9 . #xB7C6) + (#x61AA . #x8FBEEB) + (#x61AB . #xD8E2) + (#x61AC . #xD8DD) + (#x61AD . #x8FBEEC) + (#x61AE . #xD8E3) + (#x61B2 . #xB7FB) + (#x61B6 . #xB2B1) + (#x61B8 . #x8FBEED) + (#x61B9 . #x8FBEEE) + (#x61BA . #xD8EB) + (#x61BC . #x8FBEEF) + (#x61BE . #xB4B8) + (#x61C0 . #x8FBEF0) + (#x61C1 . #x8FBEF1) + (#x61C2 . #x8FBEF2) + (#x61C3 . #xD8E9) + (#x61C6 . #xD8EA) + (#x61C7 . #xBAA9) + (#x61C8 . #xD8E8) + (#x61C9 . #xD8E6) + (#x61CA . #xD8E5) + (#x61CB . #xD8EC) + (#x61CC . #xD8E4) + (#x61CD . #xD8EE) + (#x61CE . #x8FBEF3) + (#x61CF . #x8FBEF4) + (#x61D0 . #xB2FB) + (#x61D5 . #x8FBEF5) + (#x61DC . #x8FBEF6) + (#x61DD . #x8FBEF7) + (#x61DE . #x8FBEF8) + (#x61DF . #x8FBEF9) + (#x61E1 . #x8FBEFA) + (#x61E2 . #x8FBEFB) + (#x61E3 . #xD8F0) + (#x61E5 . #x8FBEFE) + (#x61E6 . #xD8EF) + (#x61E7 . #x8FBEFC) + (#x61E9 . #x8FBEFD) + (#x61EC . #x8FBFA1) + (#x61ED . #x8FBFA2) + (#x61EF . #x8FBFA3) + (#x61F2 . #xC4A8) + (#x61F4 . #xD8F3) + (#x61F6 . #xD8F1) + (#x61F7 . #xD8E7) + (#x61F8 . #xB7FC) + (#x61FA . #xD8F2) + (#x61FC . #xD8F6) + (#x61FD . #xD8F5) + (#x61FE . #xD8F7) + (#x61FF . #xD8F4) + (#x6200 . #xD8F8) + (#x6201 . #x8FBFA4) + (#x6203 . #x8FBFA5) + (#x6204 . #x8FBFA6) + (#x6207 . #x8FBFA7) + (#x6208 . #xD8F9) + (#x6209 . #xD8FA) + (#x620A . #xCAEA) + (#x620C . #xD8FC) + (#x620D . #xD8FB) + (#x620E . #xBDBF) + (#x6210 . #xC0AE) + (#x6211 . #xB2E6) + (#x6212 . #xB2FC) + (#x6213 . #x8FBFA8) + (#x6214 . #xD8FD) + (#x6215 . #x8FBFA9) + (#x6216 . #xB0BF) + (#x621A . #xC0CC) + (#x621B . #xD8FE) + (#x621C . #x8FBFAA) + (#x621D . #xECC3) + (#x621E . #xD9A1) + (#x621F . #xB7E1) + (#x6220 . #x8FBFAB) + (#x6221 . #xD9A2) + (#x6222 . #x8FBFAC) + (#x6223 . #x8FBFAD) + (#x6226 . #xC0EF) + (#x6227 . #x8FBFAE) + (#x6229 . #x8FBFAF) + (#x622A . #xD9A3) + (#x622B . #x8FBFB0) + (#x622E . #xD9A4) + (#x622F . #xB5BA) + (#x6230 . #xD9A5) + (#x6232 . #xD9A6) + (#x6233 . #xD9A7) + (#x6234 . #xC2D7) + (#x6238 . #xB8CD) + (#x6239 . #x8FBFB1) + (#x623B . #xCCE1) + (#x623D . #x8FBFB2) + (#x623F . #xCBBC) + (#x6240 . #xBDEA) + (#x6241 . #xD9A8) + (#x6242 . #x8FBFB3) + (#x6243 . #x8FBFB4) + (#x6244 . #x8FBFB5) + (#x6246 . #x8FBFB6) + (#x6247 . #xC0F0) + (#x6248 . #xEEBD) + (#x6249 . #xC8E2) + (#x624B . #xBCEA) + (#x624C . #x8FBFB7) + (#x624D . #xBACD) + (#x624E . #xD9A9) + (#x6250 . #x8FBFB8) + (#x6251 . #x8FBFB9) + (#x6252 . #x8FBFBA) + (#x6253 . #xC2C7) + (#x6254 . #x8FBFBB) + (#x6255 . #xCAA7) + (#x6256 . #x8FBFBC) + (#x6258 . #xC2F1) + (#x625A . #x8FBFBD) + (#x625B . #xD9AC) + (#x625C . #x8FBFBE) + (#x625E . #xD9AA) + (#x6260 . #xD9AD) + (#x6263 . #xD9AB) + (#x6264 . #x8FBFBF) + (#x6268 . #xD9AE) + (#x626D . #x8FBFC0) + (#x626E . #xCAB1) + (#x626F . #x8FBFC1) + (#x6271 . #xB0B7) + (#x6273 . #x8FBFC2) + (#x6276 . #xC9DE) + (#x6279 . #xC8E3) + (#x627A . #x8FBFC3) + (#x627C . #xD9AF) + (#x627D . #x8FBFC4) + (#x627E . #xD9B2) + (#x627F . #xBEB5) + (#x6280 . #xB5BB) + (#x6282 . #xD9B0) + (#x6283 . #xD9B7) + (#x6284 . #xBEB6) + (#x6289 . #xD9B1) + (#x628A . #xC7C4) + (#x628D . #x8FBFC5) + (#x628E . #x8FBFC6) + (#x628F . #x8FBFC7) + (#x6290 . #x8FBFC8) + (#x6291 . #xCDDE) + (#x6292 . #xD9B3) + (#x6293 . #xD9B4) + (#x6294 . #xD9B8) + (#x6295 . #xC5EA) + (#x6296 . #xD9B5) + (#x6297 . #xB9B3) + (#x6298 . #xC0DE) + (#x629B . #xD9C6) + (#x629C . #xC8B4) + (#x629E . #xC2F2) + (#x62A6 . #x8FBFC9) + (#x62A8 . #x8FBFCA) + (#x62AB . #xC8E4) + (#x62AC . #xDAAD) + (#x62B1 . #xCAFA) + (#x62B3 . #x8FBFCB) + (#x62B5 . #xC4F1) + (#x62B6 . #x8FBFCC) + (#x62B7 . #x8FBFCD) + (#x62B9 . #xCBF5) + (#x62BA . #x8FBFCE) + (#x62BB . #xD9BB) + (#x62BC . #xB2A1) + (#x62BD . #xC3EA) + (#x62BE . #x8FBFCF) + (#x62BF . #x8FBFD0) + (#x62C2 . #xD9C4) + (#x62C4 . #x8FBFD1) + (#x62C5 . #xC3B4) + (#x62C6 . #xD9BE) + (#x62C7 . #xD9C5) + (#x62C8 . #xD9C0) + (#x62C9 . #xD9C7) + (#x62CA . #xD9C3) + (#x62CC . #xD9C2) + (#x62CD . #xC7EF) + (#x62CE . #x8FBFD2) + (#x62CF . #xD9BC) + (#x62D0 . #xB2FD) + (#x62D1 . #xD9BA) + (#x62D2 . #xB5F1) + (#x62D3 . #xC2F3) + (#x62D4 . #xD9B6) + (#x62D5 . #x8FBFD3) + (#x62D6 . #x8FBFD4) + (#x62D7 . #xD9B9) + (#x62D8 . #xB9B4) + (#x62D9 . #xC0DB) + (#x62DA . #x8FBFD5) + (#x62DB . #xBEB7) + (#x62DC . #xD9C1) + (#x62DD . #xC7D2) + (#x62E0 . #xB5F2) + (#x62E1 . #xB3C8) + (#x62EA . #x8FBFD6) + (#x62EC . #xB3E7) + (#x62ED . #xBFA1) + (#x62EE . #xD9C9) + (#x62EF . #xD9CE) + (#x62F1 . #xD9CA) + (#x62F2 . #x8FBFD7) + (#x62F3 . #xB7FD) + (#x62F4 . #x8FBFD8) + (#x62F5 . #xD9CF) + (#x62F6 . #xBBA2) + (#x62F7 . #xB9E9) + (#x62FC . #x8FBFD9) + (#x62FD . #x8FBFDA) + (#x62FE . #xBDA6) + (#x62FF . #xD9BD) + (#x6301 . #xBBFD) + (#x6302 . #xD9CC) + (#x6303 . #x8FBFDB) + (#x6304 . #x8FBFDC) + (#x6307 . #xBBD8) + (#x6308 . #xD9CD) + (#x6309 . #xB0C4) + (#x630A . #x8FBFDD) + (#x630B . #x8FBFDE) + (#x630C . #xD9C8) + (#x630D . #x8FBFDF) + (#x6310 . #x8FBFE0) + (#x6311 . #xC4A9) + (#x6313 . #x8FBFE1) + (#x6316 . #x8FBFE2) + (#x6318 . #x8FBFE3) + (#x6319 . #xB5F3) + (#x631F . #xB6B4) + (#x6327 . #xD9CB) + (#x6328 . #xB0A7) + (#x6329 . #x8FBFE4) + (#x632A . #x8FBFE5) + (#x632B . #xBAC3) + (#x632D . #x8FBFE6) + (#x632F . #xBFB6) + (#x6335 . #x8FBFE7) + (#x6336 . #x8FBFE8) + (#x6339 . #x8FBFE9) + (#x633A . #xC4F2) + (#x633C . #x8FBFEA) + (#x633D . #xC8D4) + (#x633E . #xD9D1) + (#x633F . #xC1DE) + (#x6341 . #x8FBFEB) + (#x6342 . #x8FBFEC) + (#x6343 . #x8FBFED) + (#x6344 . #x8FBFEE) + (#x6346 . #x8FBFEF) + (#x6349 . #xC2AA) + (#x634A . #x8FBFF0) + (#x634B . #x8FBFF1) + (#x634C . #xBBAB) + (#x634D . #xD9D2) + (#x634E . #x8FBFF2) + (#x634F . #xD9D4) + (#x6350 . #xD9D0) + (#x6352 . #x8FBFF3) + (#x6353 . #x8FBFF4) + (#x6354 . #x8FBFF5) + (#x6355 . #xCAE1) + (#x6357 . #xC4BD) + (#x6358 . #x8FBFF6) + (#x635B . #x8FBFF7) + (#x635C . #xC1DC) + (#x6365 . #x8FBFF8) + (#x6366 . #x8FBFF9) + (#x6367 . #xCAFB) + (#x6368 . #xBCCE) + (#x6369 . #xD9E0) + (#x636B . #xD9DF) + (#x636C . #x8FBFFA) + (#x636D . #x8FBFFB) + (#x636E . #xBFF8) + (#x6371 . #x8FBFFC) + (#x6372 . #xB7FE) + (#x6374 . #x8FBFFD) + (#x6375 . #x8FBFFE) + (#x6376 . #xD9D9) + (#x6377 . #xBEB9) + (#x6378 . #x8FC0A1) + (#x637A . #xC6E8) + (#x637B . #xC7B1) + (#x637C . #x8FC0A2) + (#x637D . #x8FC0A3) + (#x637F . #x8FC0A4) + (#x6380 . #xD9D7) + (#x6382 . #x8FC0A5) + (#x6383 . #xC1DD) + (#x6384 . #x8FC0A6) + (#x6387 . #x8FC0A7) + (#x6388 . #xBCF8) + (#x6389 . #xD9DC) + (#x638A . #x8FC0A8) + (#x638C . #xBEB8) + (#x638E . #xD9D6) + (#x638F . #xD9DB) + (#x6390 . #x8FC0A9) + (#x6392 . #xC7D3) + (#x6394 . #x8FC0AA) + (#x6395 . #x8FC0AB) + (#x6396 . #xD9D5) + (#x6398 . #xB7A1) + (#x6399 . #x8FC0AC) + (#x639A . #x8FC0AD) + (#x639B . #xB3DD) + (#x639E . #x8FC0AE) + (#x639F . #xD9DD) + (#x63A0 . #xCEAB) + (#x63A1 . #xBACE) + (#x63A2 . #xC3B5) + (#x63A3 . #xD9DA) + (#x63A4 . #x8FC0AF) + (#x63A5 . #xC0DC) + (#x63A6 . #x8FC0B0) + (#x63A7 . #xB9B5) + (#x63A8 . #xBFE4) + (#x63A9 . #xB1E6) + (#x63AA . #xC1BC) + (#x63AB . #xD9D8) + (#x63AC . #xB5C5) + (#x63AD . #x8FC0B1) + (#x63AE . #x8FC0B2) + (#x63AF . #x8FC0B3) + (#x63B2 . #xB7C7) + (#x63B4 . #xC4CF) + (#x63B5 . #xD9DE) + (#x63BB . #xC1DF) + (#x63BD . #x8FC0B4) + (#x63BE . #xD9E1) + (#x63C0 . #xD9E3) + (#x63C1 . #x8FC0B5) + (#x63C3 . #xC2B7) + (#x63C4 . #xD9E9) + (#x63C5 . #x8FC0B6) + (#x63C6 . #xD9E4) + (#x63C8 . #x8FC0B7) + (#x63C9 . #xD9E6) + (#x63CE . #x8FC0B8) + (#x63CF . #xC9C1) + (#x63D0 . #xC4F3) + (#x63D1 . #x8FC0B9) + (#x63D2 . #xD9E7) + (#x63D3 . #x8FC0BA) + (#x63D4 . #x8FC0BB) + (#x63D5 . #x8FC0BC) + (#x63D6 . #xCDAC) + (#x63DA . #xCDC8) + (#x63DB . #xB4B9) + (#x63DC . #x8FC0BD) + (#x63E0 . #x8FC0BE) + (#x63E1 . #xB0AE) + (#x63E3 . #xD9E5) + (#x63E5 . #x8FC0BF) + (#x63E9 . #xD9E2) + (#x63EA . #x8FC0C0) + (#x63EC . #x8FC0C1) + (#x63EE . #xB4F8) + (#x63F2 . #x8FC0C2) + (#x63F3 . #x8FC0C3) + (#x63F4 . #xB1E7) + (#x63F5 . #x8FC0C4) + (#x63F6 . #xD9E8) + (#x63F8 . #x8FC0C5) + (#x63F9 . #x8FC0C6) + (#x63FA . #xCDC9) + (#x6406 . #xD9EC) + (#x6409 . #x8FC0C7) + (#x640A . #x8FC0C8) + (#x640D . #xC2BB) + (#x640F . #xD9F3) + (#x6410 . #x8FC0C9) + (#x6412 . #x8FC0CA) + (#x6413 . #xD9ED) + (#x6414 . #x8FC0CB) + (#x6416 . #xD9EA) + (#x6417 . #xD9F1) + (#x6418 . #x8FC0CC) + (#x641C . #xD9D3) + (#x641E . #x8FC0CD) + (#x6420 . #x8FC0CE) + (#x6422 . #x8FC0CF) + (#x6424 . #x8FC0D0) + (#x6425 . #x8FC0D1) + (#x6426 . #xD9EE) + (#x6428 . #xD9F2) + (#x6429 . #x8FC0D2) + (#x642A . #x8FC0D3) + (#x642C . #xC8C2) + (#x642D . #xC5EB) + (#x642F . #x8FC0D4) + (#x6430 . #x8FC0D5) + (#x6434 . #xD9EB) + (#x6435 . #x8FC0D6) + (#x6436 . #xD9EF) + (#x643A . #xB7C8) + (#x643D . #x8FC0D7) + (#x643E . #xBAF1) + (#x643F . #x8FC0D8) + (#x6442 . #xC0DD) + (#x644B . #x8FC0D9) + (#x644E . #xD9F7) + (#x644F . #x8FC0DA) + (#x6451 . #x8FC0DB) + (#x6452 . #x8FC0DC) + (#x6453 . #x8FC0DD) + (#x6454 . #x8FC0DE) + (#x6458 . #xC5A6) + (#x645A . #x8FC0DF) + (#x645B . #x8FC0E0) + (#x645C . #x8FC0E1) + (#x645D . #x8FC0E2) + (#x645F . #x8FC0E3) + (#x6460 . #x8FC0E4) + (#x6461 . #x8FC0E5) + (#x6463 . #x8FC0E6) + (#x6467 . #xD9F4) + (#x6469 . #xCBE0) + (#x646D . #x8FC0E7) + (#x646F . #xD9F5) + (#x6473 . #x8FC0E8) + (#x6474 . #x8FC0E9) + (#x6476 . #xD9F6) + (#x6478 . #xCCCE) + (#x647A . #xC0A2) + (#x647B . #x8FC0EA) + (#x647D . #x8FC0EB) + (#x6483 . #xB7E2) + (#x6485 . #x8FC0EC) + (#x6487 . #x8FC0ED) + (#x6488 . #xD9FD) + (#x648F . #x8FC0EE) + (#x6490 . #x8FC0EF) + (#x6491 . #x8FC0F0) + (#x6492 . #xBBB5) + (#x6493 . #xD9FA) + (#x6495 . #xD9F9) + (#x6498 . #x8FC0F1) + (#x6499 . #x8FC0F2) + (#x649A . #xC7B2) + (#x649B . #x8FC0F3) + (#x649D . #x8FC0F4) + (#x649E . #xC6B5) + (#x649F . #x8FC0F5) + (#x64A1 . #x8FC0F6) + (#x64A3 . #x8FC0F7) + (#x64A4 . #xC5B1) + (#x64A5 . #xD9FB) + (#x64A6 . #x8FC0F8) + (#x64A8 . #x8FC0F9) + (#x64A9 . #xD9FC) + (#x64AB . #xC9EF) + (#x64AC . #x8FC0FA) + (#x64AD . #xC7C5) + (#x64AE . #xBBA3) + (#x64B0 . #xC0F1) + (#x64B2 . #xCBD0) + (#x64B3 . #x8FC0FB) + (#x64B9 . #xB3C9) + (#x64BB . #xDAA5) + (#x64BC . #xD9FE) + (#x64BD . #x8FC0FC) + (#x64BE . #x8FC0FD) + (#x64BF . #x8FC0FE) + (#x64C1 . #xCDCA) + (#x64C2 . #xDAA7) + (#x64C4 . #x8FC1A1) + (#x64C5 . #xDAA3) + (#x64C7 . #xDAA4) + (#x64C9 . #x8FC1A2) + (#x64CA . #x8FC1A3) + (#x64CB . #x8FC1A4) + (#x64CC . #x8FC1A5) + (#x64CD . #xC1E0) + (#x64CE . #x8FC1A6) + (#x64D0 . #x8FC1A7) + (#x64D1 . #x8FC1A8) + (#x64D2 . #xDAA2) + (#x64D4 . #xD9BF) + (#x64D5 . #x8FC1A9) + (#x64D7 . #x8FC1AA) + (#x64D8 . #xDAA6) + (#x64DA . #xDAA1) + (#x64E0 . #xDAAB) + (#x64E1 . #xDAAC) + (#x64E2 . #xC5A7) + (#x64E3 . #xDAAE) + (#x64E4 . #x8FC1AB) + (#x64E5 . #x8FC1AC) + (#x64E6 . #xBBA4) + (#x64E7 . #xDAA9) + (#x64E9 . #x8FC1AD) + (#x64EA . #x8FC1AE) + (#x64EC . #xB5BC) + (#x64ED . #x8FC1AF) + (#x64EF . #xDAAF) + (#x64F0 . #x8FC1B0) + (#x64F1 . #xDAA8) + (#x64F2 . #xDAB3) + (#x64F4 . #xDAB2) + (#x64F5 . #x8FC1B1) + (#x64F6 . #xDAB1) + (#x64F7 . #x8FC1B2) + (#x64FA . #xDAB4) + (#x64FB . #x8FC1B3) + (#x64FD . #xDAB6) + (#x64FE . #xBEF1) + (#x64FF . #x8FC1B4) + (#x6500 . #xDAB5) + (#x6501 . #x8FC1B5) + (#x6504 . #x8FC1B6) + (#x6505 . #xDAB9) + (#x6508 . #x8FC1B7) + (#x6509 . #x8FC1B8) + (#x650A . #x8FC1B9) + (#x650F . #x8FC1BA) + (#x6513 . #x8FC1BB) + (#x6514 . #x8FC1BC) + (#x6516 . #x8FC1BD) + (#x6518 . #xDAB7) + (#x6519 . #x8FC1BE) + (#x651B . #x8FC1BF) + (#x651C . #xDAB8) + (#x651D . #xD9F0) + (#x651E . #x8FC1C0) + (#x651F . #x8FC1C1) + (#x6522 . #x8FC1C2) + (#x6523 . #xDABB) + (#x6524 . #xDABA) + (#x6526 . #x8FC1C3) + (#x6529 . #x8FC1C4) + (#x652A . #xD9F8) + (#x652B . #xDABC) + (#x652C . #xDAB0) + (#x652E . #x8FC1C5) + (#x652F . #xBBD9) + (#x6531 . #x8FC1C6) + (#x6534 . #xDABD) + (#x6535 . #xDABE) + (#x6536 . #xDAC0) + (#x6537 . #xDABF) + (#x6538 . #xDAC1) + (#x6539 . #xB2FE) + (#x653A . #x8FC1C7) + (#x653B . #xB9B6) + (#x653C . #x8FC1C8) + (#x653D . #x8FC1C9) + (#x653E . #xCAFC) + (#x653F . #xC0AF) + (#x6543 . #x8FC1CA) + (#x6545 . #xB8CE) + (#x6547 . #x8FC1CB) + (#x6548 . #xDAC3) + (#x6549 . #x8FC1CC) + (#x654D . #xDAC6) + (#x654F . #xC9D2) + (#x6550 . #x8FC1CD) + (#x6551 . #xB5DF) + (#x6552 . #x8FC1CE) + (#x6554 . #x8FC1CF) + (#x6555 . #xDAC5) + (#x6556 . #xDAC4) + (#x6557 . #xC7D4) + (#x6558 . #xDAC7) + (#x6559 . #xB6B5) + (#x655D . #xDAC9) + (#x655E . #xDAC8) + (#x655F . #x8FC1D0) + (#x6560 . #x8FC1D1) + (#x6562 . #xB4BA) + (#x6563 . #xBBB6) + (#x6566 . #xC6D8) + (#x6567 . #x8FC1D2) + (#x656B . #x8FC1D3) + (#x656C . #xB7C9) + (#x6570 . #xBFF4) + (#x6572 . #xDACA) + (#x6574 . #xC0B0) + (#x6575 . #xC5A8) + (#x6577 . #xC9DF) + (#x6578 . #xDACB) + (#x657A . #x8FC1D4) + (#x657D . #x8FC1D5) + (#x6581 . #x8FC1D6) + (#x6582 . #xDACC) + (#x6583 . #xDACD) + (#x6585 . #x8FC1D7) + (#x6587 . #xCAB8) + (#x6588 . #xD5DD) + (#x6589 . #xC0C6) + (#x658A . #x8FC1D8) + (#x658C . #xC9CC) + (#x658E . #xBAD8) + (#x6590 . #xC8E5) + (#x6591 . #xC8C3) + (#x6592 . #x8FC1D9) + (#x6595 . #x8FC1DA) + (#x6597 . #xC5CD) + (#x6598 . #x8FC1DB) + (#x6599 . #xCEC1) + (#x659B . #xDACF) + (#x659C . #xBCD0) + (#x659D . #x8FC1DC) + (#x659F . #xDAD0) + (#x65A0 . #x8FC1DD) + (#x65A1 . #xB0B6) + (#x65A3 . #x8FC1DE) + (#x65A4 . #xB6D4) + (#x65A5 . #xC0CD) + (#x65A6 . #x8FC1DF) + (#x65A7 . #xC9E0) + (#x65AB . #xDAD1) + (#x65AC . #xBBC2) + (#x65AD . #xC3C7) + (#x65AE . #x8FC1E0) + (#x65AF . #xBBDB) + (#x65B0 . #xBFB7) + (#x65B2 . #x8FC1E1) + (#x65B3 . #x8FC1E2) + (#x65B4 . #x8FC1E3) + (#x65B7 . #xDAD2) + (#x65B9 . #xCAFD) + (#x65BC . #xB1F7) + (#x65BD . #xBBDC) + (#x65BF . #x8FC1E4) + (#x65C1 . #xDAD5) + (#x65C2 . #x8FC1E5) + (#x65C3 . #xDAD3) + (#x65C4 . #xDAD6) + (#x65C5 . #xCEB9) + (#x65C6 . #xDAD4) + (#x65C8 . #x8FC1E6) + (#x65C9 . #x8FC1E7) + (#x65CB . #xC0FB) + (#x65CC . #xDAD7) + (#x65CE . #x8FC1E8) + (#x65CF . #xC2B2) + (#x65D0 . #x8FC1E9) + (#x65D2 . #xDAD8) + (#x65D4 . #x8FC1EA) + (#x65D6 . #x8FC1EB) + (#x65D7 . #xB4FA) + (#x65D8 . #x8FC1EC) + (#x65D9 . #xDADA) + (#x65DB . #xDAD9) + (#x65DF . #x8FC1ED) + (#x65E0 . #xDADB) + (#x65E1 . #xDADC) + (#x65E2 . #xB4FB) + (#x65E5 . #xC6FC) + (#x65E6 . #xC3B6) + (#x65E7 . #xB5EC) + (#x65E8 . #xBBDD) + (#x65E9 . #xC1E1) + (#x65EC . #xBDDC) + (#x65ED . #xB0B0) + (#x65F0 . #x8FC1EE) + (#x65F1 . #xDADD) + (#x65F2 . #x8FC1EF) + (#x65F4 . #x8FC1F0) + (#x65F5 . #x8FC1F1) + (#x65F9 . #x8FC1F2) + (#x65FA . #xB2A2) + (#x65FB . #xDAE1) + (#x65FE . #x8FC1F3) + (#x65FF . #x8FC1F4) + (#x6600 . #x8FC1F5) + (#x6602 . #xB9B7) + (#x6603 . #xDAE0) + (#x6604 . #x8FC1F6) + (#x6606 . #xBAAB) + (#x6607 . #xBEBA) + (#x6608 . #x8FC1F7) + (#x6609 . #x8FC1F8) + (#x660A . #xDADF) + (#x660C . #xBEBB) + (#x660D . #x8FC1F9) + (#x660E . #xCCC0) + (#x660F . #xBAAA) + (#x6611 . #x8FC1FA) + (#x6612 . #x8FC1FB) + (#x6613 . #xB0D7) + (#x6614 . #xC0CE) + (#x6615 . #x8FC1FC) + (#x6616 . #x8FC1FD) + (#x661C . #xDAE6) + (#x661D . #x8FC1FE) + (#x661E . #x8FC2A1) + (#x661F . #xC0B1) + (#x6620 . #xB1C7) + (#x6621 . #x8FC2A2) + (#x6622 . #x8FC2A3) + (#x6623 . #x8FC2A4) + (#x6624 . #x8FC2A5) + (#x6625 . #xBDD5) + (#x6626 . #x8FC2A6) + (#x6627 . #xCBE6) + (#x6628 . #xBAF2) + (#x6629 . #x8FC2A7) + (#x662A . #x8FC2A8) + (#x662B . #x8FC2A9) + (#x662C . #x8FC2AA) + (#x662D . #xBEBC) + (#x662E . #x8FC2AB) + (#x662F . #xC0A7) + (#x6630 . #x8FC2AC) + (#x6631 . #x8FC2AD) + (#x6633 . #x8FC2AE) + (#x6634 . #xDAE5) + (#x6635 . #xDAE3) + (#x6636 . #xDAE4) + (#x6637 . #x8FC2B0) + (#x6639 . #x8FC2AF) + (#x663C . #xC3EB) + (#x663F . #xDBA6) + (#x6640 . #x8FC2B1) + (#x6641 . #xDAEA) + (#x6642 . #xBBFE) + (#x6643 . #xB9B8) + (#x6644 . #xDAE8) + (#x6645 . #x8FC2B2) + (#x6646 . #x8FC2B3) + (#x6649 . #xDAE9) + (#x664A . #x8FC2B4) + (#x664B . #xBFB8) + (#x664C . #x8FC2B5) + (#x664E . #x8FC2B7) + (#x664F . #xDAE7) + (#x6651 . #x8FC2B6) + (#x6652 . #xBBAF) + (#x6657 . #x8FC2B8) + (#x6658 . #x8FC2B9) + (#x6659 . #x8FC2BA) + (#x665B . #x8FC2BB) + (#x665C . #x8FC2BC) + (#x665D . #xDAEC) + (#x665E . #xDAEB) + (#x665F . #xDAF0) + (#x6660 . #x8FC2BD) + (#x6661 . #x8FC2BE) + (#x6662 . #xDAF1) + (#x6664 . #xDAED) + (#x6666 . #xB3A2) + (#x6667 . #xDAEE) + (#x6668 . #xDAEF) + (#x6669 . #xC8D5) + (#x666A . #x8FC2C0) + (#x666B . #x8FC2C1) + (#x666C . #x8FC2C2) + (#x666E . #xC9E1) + (#x666F . #xB7CA) + (#x6670 . #xDAF2) + (#x6673 . #x8FC2C4) + (#x6674 . #xC0B2) + (#x6675 . #x8FC2C5) + (#x6676 . #xBEBD) + (#x6677 . #x8FC2C7) + (#x6678 . #x8FC2C8) + (#x6679 . #x8FC2C9) + (#x667A . #xC3D2) + (#x667B . #x8FC2CA) + (#x667C . #x8FC2CC) + (#x667E . #x8FC2C3) + (#x667F . #x8FC2C6) + (#x6680 . #x8FC2CB) + (#x6681 . #xB6C7) + (#x6683 . #xDAF3) + (#x6684 . #xDAF7) + (#x6687 . #xB2CB) + (#x6688 . #xDAF4) + (#x6689 . #xDAF6) + (#x668B . #x8FC2CD) + (#x668C . #x8FC2CE) + (#x668D . #x8FC2CF) + (#x668E . #xDAF5) + (#x6690 . #x8FC2D0) + (#x6691 . #xBDEB) + (#x6692 . #x8FC2D1) + (#x6696 . #xC3C8) + (#x6697 . #xB0C5) + (#x6698 . #xDAF8) + (#x6699 . #x8FC2D2) + (#x669A . #x8FC2D3) + (#x669B . #x8FC2D4) + (#x669C . #x8FC2D5) + (#x669D . #xDAF9) + (#x669F . #x8FC2D6) + (#x66A0 . #x8FC2D7) + (#x66A2 . #xC4AA) + (#x66A4 . #x8FC2D8) + (#x66A6 . #xCEF1) + (#x66AB . #xBBC3) + (#x66AD . #x8FC2D9) + (#x66AE . #xCAEB) + (#x66B1 . #x8FC2DA) + (#x66B2 . #x8FC2DB) + (#x66B4 . #xCBBD) + (#x66B5 . #x8FC2DC) + (#x66B8 . #xDBA2) + (#x66B9 . #xDAFB) + (#x66BB . #x8FC2DD) + (#x66BC . #xDAFE) + (#x66BE . #xDAFD) + (#x66BF . #x8FC2DE) + (#x66C0 . #x8FC2DF) + (#x66C1 . #xDAFA) + (#x66C2 . #x8FC2E0) + (#x66C3 . #x8FC2E1) + (#x66C4 . #xDBA1) + (#x66C7 . #xC6DE) + (#x66C8 . #x8FC2E2) + (#x66C9 . #xDAFC) + (#x66CC . #x8FC2E3) + (#x66CE . #x8FC2E4) + (#x66CF . #x8FC2E5) + (#x66D4 . #x8FC2E6) + (#x66D6 . #xDBA3) + (#x66D9 . #xBDEC) + (#x66DA . #xDBA4) + (#x66DB . #x8FC2E7) + (#x66DC . #xCDCB) + (#x66DD . #xC7F8) + (#x66DF . #x8FC2E8) + (#x66E0 . #xDBA5) + (#x66E6 . #xDBA7) + (#x66E8 . #x8FC2E9) + (#x66E9 . #xDBA8) + (#x66EB . #x8FC2EA) + (#x66EC . #x8FC2EB) + (#x66EE . #x8FC2EC) + (#x66F0 . #xDBA9) + (#x66F2 . #xB6CA) + (#x66F3 . #xB1C8) + (#x66F4 . #xB9B9) + (#x66F5 . #xDBAA) + (#x66F7 . #xDBAB) + (#x66F8 . #xBDF1) + (#x66F9 . #xC1E2) + (#x66FA . #x8FC2ED) + (#x66FB . #x8FC2BF) + (#x66FC . #xD2D8) + (#x66FD . #xC1BE) + (#x66FE . #xC1BD) + (#x66FF . #xC2D8) + (#x6700 . #xBAC7) + (#x6703 . #xD0F2) + (#x6705 . #x8FC2EE) + (#x6707 . #x8FC2EF) + (#x6708 . #xB7EE) + (#x6709 . #xCDAD) + (#x670B . #xCAFE) + (#x670D . #xC9FE) + (#x670E . #x8FC2F0) + (#x670F . #xDBAC) + (#x6713 . #x8FC2F1) + (#x6714 . #xBAF3) + (#x6715 . #xC4BF) + (#x6716 . #xDBAD) + (#x6717 . #xCFAF) + (#x6719 . #x8FC2F2) + (#x671B . #xCBBE) + (#x671C . #x8FC2F3) + (#x671D . #xC4AB) + (#x671E . #xDBAE) + (#x671F . #xB4FC) + (#x6720 . #x8FC2F4) + (#x6722 . #x8FC2F5) + (#x6726 . #xDBAF) + (#x6727 . #xDBB0) + (#x6728 . #xCCDA) + (#x672A . #xCCA4) + (#x672B . #xCBF6) + (#x672C . #xCBDC) + (#x672D . #xBBA5) + (#x672E . #xDBB2) + (#x6731 . #xBCEB) + (#x6733 . #x8FC2F6) + (#x6734 . #xCBD1) + (#x6736 . #xDBB4) + (#x6737 . #xDBB7) + (#x6738 . #xDBB6) + (#x673A . #xB4F9) + (#x673D . #xB5E0) + (#x673E . #x8FC2F7) + (#x673F . #xDBB3) + (#x6741 . #xDBB5) + (#x6745 . #x8FC2F8) + (#x6746 . #xDBB8) + (#x6747 . #x8FC2F9) + (#x6748 . #x8FC2FA) + (#x6749 . #xBFF9) + (#x674C . #x8FC2FB) + (#x674E . #xCDFB) + (#x674F . #xB0C9) + (#x6750 . #xBAE0) + (#x6751 . #xC2BC) + (#x6753 . #xBCDD) + (#x6754 . #x8FC2FC) + (#x6755 . #x8FC2FD) + (#x6756 . #xBEF3) + (#x6759 . #xDBBB) + (#x675C . #xC5CE) + (#x675D . #x8FC2FE) + (#x675E . #xDBB9) + (#x675F . #xC2AB) + (#x6760 . #xDBBA) + (#x6761 . #xBEF2) + (#x6762 . #xCCDD) + (#x6763 . #xDBBC) + (#x6764 . #xDBBD) + (#x6765 . #xCDE8) + (#x6766 . #x8FC3A1) + (#x676A . #xDBC2) + (#x676C . #x8FC3A2) + (#x676D . #xB9BA) + (#x676E . #x8FC3A3) + (#x676F . #xC7D5) + (#x6770 . #xDBBF) + (#x6771 . #xC5EC) + (#x6772 . #xDADE) + (#x6773 . #xDAE2) + (#x6774 . #x8FC3A4) + (#x6775 . #xB5CF) + (#x6776 . #x8FC3A5) + (#x6777 . #xC7C7) + (#x677B . #x8FC3A6) + (#x677C . #xDBC1) + (#x677E . #xBEBE) + (#x677F . #xC8C4) + (#x6781 . #x8FC3A7) + (#x6784 . #x8FC3A8) + (#x6785 . #xDBC7) + (#x6787 . #xC8FA) + (#x6789 . #xDBBE) + (#x678B . #xDBC4) + (#x678C . #xDBC3) + (#x678E . #x8FC3A9) + (#x678F . #x8FC3AA) + (#x6790 . #xC0CF) + (#x6791 . #x8FC3AB) + (#x6793 . #x8FC3AC) + (#x6795 . #xCBED) + (#x6796 . #x8FC3AD) + (#x6797 . #xCED3) + (#x6798 . #x8FC3AE) + (#x6799 . #x8FC3AF) + (#x679A . #xCBE7) + (#x679B . #x8FC3B0) + (#x679C . #xB2CC) + (#x679D . #xBBDE) + (#x67A0 . #xCFC8) + (#x67A1 . #xDBC6) + (#x67A2 . #xBFF5) + (#x67A6 . #xDBC5) + (#x67A9 . #xDBC0) + (#x67AF . #xB8CF) + (#x67B0 . #x8FC3B1) + (#x67B1 . #x8FC3B2) + (#x67B2 . #x8FC3B3) + (#x67B3 . #xDBCC) + (#x67B4 . #xDBCA) + (#x67B5 . #x8FC3B4) + (#x67B6 . #xB2CD) + (#x67B7 . #xDBC8) + (#x67B8 . #xDBCE) + (#x67B9 . #xDBD4) + (#x67BB . #x8FC3B5) + (#x67BC . #x8FC3B6) + (#x67BD . #x8FC3B7) + (#x67C0 . #x8FC3B9) + (#x67C1 . #xC2C8) + (#x67C2 . #x8FC3BA) + (#x67C3 . #x8FC3BB) + (#x67C4 . #xCAC1) + (#x67C5 . #x8FC3BC) + (#x67C6 . #xDBD6) + (#x67C8 . #x8FC3BD) + (#x67C9 . #x8FC3BE) + (#x67CA . #xC9A2) + (#x67CE . #xDBD5) + (#x67CF . #xC7F0) + (#x67D0 . #xCBBF) + (#x67D1 . #xB4BB) + (#x67D2 . #x8FC3BF) + (#x67D3 . #xC0F7) + (#x67D4 . #xBDC0) + (#x67D7 . #x8FC3C0) + (#x67D8 . #xC4D3) + (#x67D9 . #x8FC3C1) + (#x67DA . #xCDAE) + (#x67DC . #x8FC3C2) + (#x67DD . #xDBD1) + (#x67DE . #xDBD0) + (#x67E1 . #x8FC3C3) + (#x67E2 . #xDBD2) + (#x67E4 . #xDBCF) + (#x67E6 . #x8FC3C4) + (#x67E7 . #xDBD7) + (#x67E9 . #xDBCD) + (#x67EC . #xDBCB) + (#x67EE . #xDBD3) + (#x67EF . #xDBC9) + (#x67F0 . #x8FC3C5) + (#x67F1 . #xC3EC) + (#x67F2 . #x8FC3C6) + (#x67F3 . #xCCF8) + (#x67F4 . #xBCC6) + (#x67F5 . #xBAF4) + (#x67F6 . #x8FC3C7) + (#x67F7 . #x8FC3C8) + (#x67F9 . #x8FC3B8) + (#x67FB . #xBABA) + (#x67FE . #xCBEF) + (#x67FF . #xB3C1) + (#x6802 . #xC4CE) + (#x6803 . #xC6CA) + (#x6804 . #xB1C9) + (#x6813 . #xC0F2) + (#x6814 . #x8FC3CA) + (#x6816 . #xC0B4) + (#x6817 . #xB7AA) + (#x6819 . #x8FC3CB) + (#x681D . #x8FC3CC) + (#x681E . #xDBD9) + (#x681F . #x8FC3CD) + (#x6821 . #xB9BB) + (#x6822 . #xB3FC) + (#x6827 . #x8FC3CF) + (#x6828 . #x8FC3CE) + (#x6829 . #xDBDB) + (#x682A . #xB3F4) + (#x682B . #xDBE1) + (#x682C . #x8FC3D0) + (#x682D . #x8FC3D1) + (#x682F . #x8FC3D2) + (#x6830 . #x8FC3D3) + (#x6831 . #x8FC3D4) + (#x6832 . #xDBDE) + (#x6833 . #x8FC3D5) + (#x6834 . #xC0F3) + (#x6838 . #xB3CB) + (#x6839 . #xBAAC) + (#x683B . #x8FC3D6) + (#x683C . #xB3CA) + (#x683D . #xBACF) + (#x683F . #x8FC3D7) + (#x6840 . #xDBDC) + (#x6841 . #xB7E5) + (#x6842 . #xB7CB) + (#x6843 . #xC5ED) + (#x6844 . #x8FC3D8) + (#x6845 . #x8FC3D9) + (#x6846 . #xDBDA) + (#x6848 . #xB0C6) + (#x684A . #x8FC3DA) + (#x684C . #x8FC3DB) + (#x684D . #xDBDD) + (#x684E . #xDBDF) + (#x6850 . #xB6CD) + (#x6851 . #xB7AC) + (#x6852 . #x8FC3C9) + (#x6853 . #xB4BC) + (#x6854 . #xB5CB) + (#x6855 . #x8FC3DC) + (#x6857 . #x8FC3DD) + (#x6858 . #x8FC3DE) + (#x6859 . #xDBE2) + (#x685B . #x8FC3DF) + (#x685C . #xBAF9) + (#x685D . #xCBF1) + (#x685F . #xBBB7) + (#x6863 . #xDBE3) + (#x6867 . #xC9B0) + (#x686B . #x8FC3E0) + (#x686E . #x8FC3E1) + (#x686F . #x8FC3E2) + (#x6870 . #x8FC3E3) + (#x6871 . #x8FC3E4) + (#x6872 . #x8FC3E5) + (#x6874 . #xDBEF) + (#x6875 . #x8FC3E6) + (#x6876 . #xB2B3) + (#x6877 . #xDBE4) + (#x6879 . #x8FC3E7) + (#x687A . #x8FC3E8) + (#x687B . #x8FC3E9) + (#x687C . #x8FC3EA) + (#x687E . #xDBF5) + (#x687F . #xDBE5) + (#x6881 . #xCEC2) + (#x6882 . #x8FC3EB) + (#x6883 . #xDBEC) + (#x6884 . #x8FC3EC) + (#x6885 . #xC7DF) + (#x6886 . #x8FC3ED) + (#x6888 . #x8FC3EE) + (#x688D . #xDBF4) + (#x688F . #xDBE7) + (#x6893 . #xB0B4) + (#x6894 . #xDBE9) + (#x6896 . #x8FC3EF) + (#x6897 . #xB9BC) + (#x6898 . #x8FC3F0) + (#x689A . #x8FC3F1) + (#x689B . #xDBEB) + (#x689C . #x8FC3F2) + (#x689D . #xDBEA) + (#x689F . #xDBE6) + (#x68A0 . #xDBF1) + (#x68A1 . #x8FC3F3) + (#x68A2 . #xBEBF) + (#x68A3 . #x8FC3F4) + (#x68A5 . #x8FC3F5) + (#x68A6 . #xD4ED) + (#x68A7 . #xB8E8) + (#x68A8 . #xCDFC) + (#x68A9 . #x8FC3F6) + (#x68AA . #x8FC3F7) + (#x68AD . #xDBE8) + (#x68AE . #x8FC3F8) + (#x68AF . #xC4F4) + (#x68B0 . #xB3A3) + (#x68B1 . #xBAAD) + (#x68B2 . #x8FC3F9) + (#x68B3 . #xDBE0) + (#x68B5 . #xDBF0) + (#x68B6 . #xB3E1) + (#x68B9 . #xDBEE) + (#x68BA . #xDBF2) + (#x68BB . #x8FC3FA) + (#x68BC . #xC5EE) + (#x68C4 . #xB4FE) + (#x68C5 . #x8FC3FB) + (#x68C6 . #xDCB2) + (#x68C8 . #x8FC3FC) + (#x68C9 . #xCCC9) + (#x68CA . #xDBF7) + (#x68CB . #xB4FD) + (#x68CC . #x8FC3FD) + (#x68CD . #xDBFE) + (#x68CF . #x8FC3FE) + (#x68D0 . #x8FC4A1) + (#x68D1 . #x8FC4A2) + (#x68D2 . #xCBC0) + (#x68D3 . #x8FC4A3) + (#x68D4 . #xDCA1) + (#x68D5 . #xDCA3) + (#x68D6 . #x8FC4A4) + (#x68D7 . #xDCA7) + (#x68D8 . #xDBF9) + (#x68D9 . #x8FC4A5) + (#x68DA . #xC3AA) + (#x68DC . #x8FC4A6) + (#x68DD . #x8FC4A7) + (#x68DF . #xC5EF) + (#x68E0 . #xDCAB) + (#x68E1 . #xDBFC) + (#x68E3 . #xDCA8) + (#x68E5 . #x8FC4A8) + (#x68E7 . #xDCA2) + (#x68E8 . #x8FC4A9) + (#x68EA . #x8FC4AA) + (#x68EB . #x8FC4AB) + (#x68EC . #x8FC4AC) + (#x68ED . #x8FC4AD) + (#x68EE . #xBFB9) + (#x68EF . #xDCAC) + (#x68F0 . #x8FC4AE) + (#x68F1 . #x8FC4AF) + (#x68F2 . #xC0B3) + (#x68F5 . #x8FC4B0) + (#x68F6 . #x8FC4B1) + (#x68F9 . #xDCAA) + (#x68FA . #xB4BD) + (#x68FB . #x8FC4B2) + (#x68FC . #x8FC4B3) + (#x68FD . #x8FC4B4) + (#x6900 . #xCFD0) + (#x6901 . #xDBF6) + (#x6904 . #xDCA6) + (#x6905 . #xB0D8) + (#x6906 . #x8FC4B5) + (#x6908 . #xDBF8) + (#x6909 . #x8FC4B6) + (#x690A . #x8FC4B7) + (#x690B . #xCCBA) + (#x690C . #xDBFD) + (#x690D . #xBFA2) + (#x690E . #xC4C7) + (#x690F . #xDBF3) + (#x6910 . #x8FC4B8) + (#x6911 . #x8FC4B9) + (#x6912 . #xDCA5) + (#x6913 . #x8FC4BA) + (#x6916 . #x8FC4BB) + (#x6917 . #x8FC4BC) + (#x6919 . #xBFFA) + (#x691A . #xDCAF) + (#x691B . #xB3F1) + (#x691C . #xB8A1) + (#x6921 . #xDCB1) + (#x6922 . #xDBFA) + (#x6923 . #xDCB0) + (#x6925 . #xDCA9) + (#x6926 . #xDBFB) + (#x6928 . #xDCAD) + (#x692A . #xDCAE) + (#x6930 . #xDCBF) + (#x6931 . #x8FC4BD) + (#x6933 . #x8FC4BE) + (#x6934 . #xC6CE) + (#x6935 . #x8FC4BF) + (#x6936 . #xDCA4) + (#x6938 . #x8FC4C0) + (#x6939 . #xDCBB) + (#x693B . #x8FC4C1) + (#x693D . #xDCBD) + (#x693F . #xC4D8) + (#x6942 . #x8FC4C2) + (#x6945 . #x8FC4C3) + (#x6949 . #x8FC4C4) + (#x694A . #xCDCC) + (#x694E . #x8FC4C5) + (#x6953 . #xC9F6) + (#x6954 . #xDCB8) + (#x6955 . #xC2CA) + (#x6957 . #x8FC4C6) + (#x6959 . #xDCBE) + (#x695A . #xC1BF) + (#x695B . #x8FC4C7) + (#x695C . #xDCB5) + (#x695D . #xDCC2) + (#x695E . #xDCC1) + (#x6960 . #xC6EF) + (#x6961 . #xDCC0) + (#x6962 . #xC6EA) + (#x6963 . #x8FC4C8) + (#x6964 . #x8FC4C9) + (#x6965 . #x8FC4CA) + (#x6966 . #x8FC4CB) + (#x6968 . #x8FC4CC) + (#x6969 . #x8FC4CD) + (#x696A . #xDCC4) + (#x696B . #xDCB7) + (#x696C . #x8FC4CE) + (#x696D . #xB6C8) + (#x696E . #xDCBA) + (#x696F . #xBDDD) + (#x6970 . #x8FC4CF) + (#x6971 . #x8FC4D0) + (#x6972 . #x8FC4D1) + (#x6973 . #xC7E0) + (#x6974 . #xDCBC) + (#x6975 . #xB6CB) + (#x6977 . #xDCB4) + (#x6978 . #xDCB6) + (#x6979 . #xDCB3) + (#x697A . #x8FC4D2) + (#x697B . #x8FC4D3) + (#x697C . #xCFB0) + (#x697D . #xB3DA) + (#x697E . #xDCB9) + (#x697F . #x8FC4D4) + (#x6980 . #x8FC4D5) + (#x6981 . #xDCC3) + (#x6982 . #xB3B5) + (#x698A . #xBAE7) + (#x698D . #x8FC4D6) + (#x698E . #xB1DD) + (#x6991 . #xDCD4) + (#x6992 . #x8FC4D7) + (#x6994 . #xCFB1) + (#x6995 . #xDCD7) + (#x6996 . #x8FC4D8) + (#x6998 . #x8FC4D9) + (#x699B . #xBFBA) + (#x699C . #xDCD6) + (#x69A0 . #xDCD5) + (#x69A1 . #x8FC4DA) + (#x69A5 . #x8FC4DB) + (#x69A6 . #x8FC4DC) + (#x69A7 . #xDCD2) + (#x69A8 . #x8FC4DD) + (#x69AB . #x8FC4DE) + (#x69AD . #x8FC4DF) + (#x69AE . #xDCC6) + (#x69AF . #x8FC4E0) + (#x69B1 . #xDCE3) + (#x69B2 . #xDCC5) + (#x69B4 . #xDCD8) + (#x69B7 . #x8FC4E1) + (#x69B8 . #x8FC4E2) + (#x69BA . #x8FC4E3) + (#x69BB . #xDCD0) + (#x69BC . #x8FC4E4) + (#x69BE . #xDCCB) + (#x69BF . #xDCC8) + (#x69C1 . #xDCC9) + (#x69C3 . #xDCD1) + (#x69C5 . #x8FC4E5) + (#x69C7 . #xF4A2) + (#x69C8 . #x8FC4E6) + (#x69CA . #xDCCE) + (#x69CB . #xB9BD) + (#x69CC . #xC4C8) + (#x69CD . #xC1E4) + (#x69CE . #xDCCC) + (#x69D0 . #xDCC7) + (#x69D1 . #x8FC4E7) + (#x69D3 . #xDCCA) + (#x69D6 . #x8FC4E8) + (#x69D7 . #x8FC4E9) + (#x69D8 . #xCDCD) + (#x69D9 . #xCBEA) + (#x69DD . #xDCCF) + (#x69DE . #xDCD9) + (#x69E2 . #x8FC4EA) + (#x69E5 . #x8FC4EB) + (#x69E7 . #xDCE1) + (#x69E8 . #xDCDA) + (#x69EB . #xDCE7) + (#x69ED . #xDCE5) + (#x69EE . #x8FC4EC) + (#x69EF . #x8FC4ED) + (#x69F1 . #x8FC4EE) + (#x69F2 . #xDCE0) + (#x69F3 . #x8FC4EF) + (#x69F5 . #x8FC4F0) + (#x69F9 . #xDCDF) + (#x69FB . #xC4D0) + (#x69FD . #xC1E5) + (#x69FE . #x8FC4F1) + (#x69FF . #xDCDD) + (#x6A00 . #x8FC4F2) + (#x6A01 . #x8FC4F3) + (#x6A02 . #xDCDB) + (#x6A03 . #x8FC4F4) + (#x6A05 . #xDCE2) + (#x6A0A . #xDCE8) + (#x6A0B . #xC8F5) + (#x6A0C . #xDCEE) + (#x6A0F . #x8FC4F5) + (#x6A11 . #x8FC4F6) + (#x6A12 . #xDCE9) + (#x6A13 . #xDCEC) + (#x6A14 . #xDCE6) + (#x6A15 . #x8FC4F7) + (#x6A17 . #xC3F4) + (#x6A19 . #xC9B8) + (#x6A1A . #x8FC4F8) + (#x6A1B . #xDCDC) + (#x6A1D . #x8FC4F9) + (#x6A1E . #xDCE4) + (#x6A1F . #xBEC0) + (#x6A20 . #x8FC4FA) + (#x6A21 . #xCCCF) + (#x6A22 . #xDCF8) + (#x6A23 . #xDCEB) + (#x6A24 . #x8FC4FB) + (#x6A28 . #x8FC4FC) + (#x6A29 . #xB8A2) + (#x6A2A . #xB2A3) + (#x6A2B . #xB3DF) + (#x6A2E . #xDCD3) + (#x6A30 . #x8FC4FD) + (#x6A32 . #x8FC4FE) + (#x6A34 . #x8FC5A1) + (#x6A35 . #xBEC1) + (#x6A36 . #xDCF0) + (#x6A37 . #x8FC5A2) + (#x6A38 . #xDCF7) + (#x6A39 . #xBCF9) + (#x6A3A . #xB3F2) + (#x6A3B . #x8FC5A3) + (#x6A3D . #xC3AE) + (#x6A3E . #x8FC5A4) + (#x6A3F . #x8FC5A5) + (#x6A44 . #xDCED) + (#x6A45 . #x8FC5A6) + (#x6A46 . #x8FC5A7) + (#x6A47 . #xDCF2) + (#x6A48 . #xDCF6) + (#x6A49 . #x8FC5A8) + (#x6A4A . #x8FC5A9) + (#x6A4B . #xB6B6) + (#x6A4E . #x8FC5AA) + (#x6A50 . #x8FC5AB) + (#x6A51 . #x8FC5AC) + (#x6A52 . #x8FC5AD) + (#x6A55 . #x8FC5AE) + (#x6A56 . #x8FC5AF) + (#x6A58 . #xB5CC) + (#x6A59 . #xDCF4) + (#x6A5B . #x8FC5B0) + (#x6A5F . #xB5A1) + (#x6A61 . #xC6CB) + (#x6A62 . #xDCF3) + (#x6A64 . #x8FC5B1) + (#x6A66 . #xDCF5) + (#x6A67 . #x8FC5B2) + (#x6A6A . #x8FC5B3) + (#x6A71 . #x8FC5B4) + (#x6A72 . #xDCEF) + (#x6A73 . #x8FC5B5) + (#x6A78 . #xDCF1) + (#x6A7E . #x8FC5B6) + (#x6A7F . #xB3E0) + (#x6A80 . #xC3C9) + (#x6A81 . #x8FC5B7) + (#x6A83 . #x8FC5B8) + (#x6A84 . #xDCFC) + (#x6A86 . #x8FC5B9) + (#x6A87 . #x8FC5BA) + (#x6A89 . #x8FC5BB) + (#x6A8B . #x8FC5BC) + (#x6A8D . #xDCFA) + (#x6A8E . #xB8E9) + (#x6A90 . #xDCF9) + (#x6A91 . #x8FC5BD) + (#x6A97 . #xDDA1) + (#x6A9B . #x8FC5BE) + (#x6A9C . #xDBD8) + (#x6A9D . #x8FC5BF) + (#x6A9E . #x8FC5C0) + (#x6A9F . #x8FC5C1) + (#x6AA0 . #xDCFB) + (#x6AA2 . #xDCFD) + (#x6AA3 . #xDCFE) + (#x6AA5 . #x8FC5C2) + (#x6AAA . #xDDAC) + (#x6AAB . #x8FC5C3) + (#x6AAC . #xDDA8) + (#x6AAE . #xDBED) + (#x6AAF . #x8FC5C4) + (#x6AB0 . #x8FC5C5) + (#x6AB1 . #x8FC5C6) + (#x6AB3 . #xDDA7) + (#x6AB4 . #x8FC5C7) + (#x6AB8 . #xDDA6) + (#x6ABB . #xDDA3) + (#x6ABD . #x8FC5C8) + (#x6ABE . #x8FC5C9) + (#x6ABF . #x8FC5CA) + (#x6AC1 . #xDCEA) + (#x6AC2 . #xDDA5) + (#x6AC3 . #xDDA4) + (#x6AC6 . #x8FC5CB) + (#x6AC8 . #x8FC5CD) + (#x6AC9 . #x8FC5CC) + (#x6ACC . #x8FC5CE) + (#x6AD0 . #x8FC5CF) + (#x6AD1 . #xDDAA) + (#x6AD3 . #xCFA6) + (#x6AD4 . #x8FC5D0) + (#x6AD5 . #x8FC5D1) + (#x6AD6 . #x8FC5D2) + (#x6ADA . #xDDAD) + (#x6ADB . #xB6FB) + (#x6ADC . #x8FC5D3) + (#x6ADD . #x8FC5D4) + (#x6ADE . #xDDA9) + (#x6ADF . #xDDAB) + (#x6AE4 . #x8FC5D5) + (#x6AE7 . #x8FC5D6) + (#x6AE8 . #xC8A7) + (#x6AEA . #xDDAE) + (#x6AEC . #x8FC5D7) + (#x6AF0 . #x8FC5D8) + (#x6AF1 . #x8FC5D9) + (#x6AF2 . #x8FC5DA) + (#x6AFA . #xDDB2) + (#x6AFB . #xDDAF) + (#x6AFC . #x8FC5DB) + (#x6AFD . #x8FC5DC) + (#x6B02 . #x8FC5DD) + (#x6B03 . #x8FC5DE) + (#x6B04 . #xCDF3) + (#x6B05 . #xDDB0) + (#x6B06 . #x8FC5DF) + (#x6B07 . #x8FC5E0) + (#x6B09 . #x8FC5E1) + (#x6B0A . #xDCDE) + (#x6B0F . #x8FC5E2) + (#x6B10 . #x8FC5E3) + (#x6B11 . #x8FC5E4) + (#x6B12 . #xDDB3) + (#x6B16 . #xDDB4) + (#x6B17 . #x8FC5E5) + (#x6B1B . #x8FC5E6) + (#x6B1D . #xB1B5) + (#x6B1E . #x8FC5E7) + (#x6B1F . #xDDB6) + (#x6B20 . #xB7E7) + (#x6B21 . #xBCA1) + (#x6B23 . #xB6D5) + (#x6B24 . #x8FC5E8) + (#x6B27 . #xB2A4) + (#x6B28 . #x8FC5E9) + (#x6B2B . #x8FC5EA) + (#x6B2C . #x8FC5EB) + (#x6B2F . #x8FC5EC) + (#x6B32 . #xCDDF) + (#x6B35 . #x8FC5ED) + (#x6B36 . #x8FC5EE) + (#x6B37 . #xDDB8) + (#x6B38 . #xDDB7) + (#x6B39 . #xDDBA) + (#x6B3A . #xB5BD) + (#x6B3B . #x8FC5EF) + (#x6B3D . #xB6D6) + (#x6B3E . #xB4BE) + (#x6B3F . #x8FC5F0) + (#x6B43 . #xDDBD) + (#x6B46 . #x8FC5F1) + (#x6B47 . #xDDBC) + (#x6B49 . #xDDBE) + (#x6B4A . #x8FC5F2) + (#x6B4C . #xB2CE) + (#x6B4D . #x8FC5F3) + (#x6B4E . #xC3B7) + (#x6B50 . #xDDBF) + (#x6B52 . #x8FC5F4) + (#x6B53 . #xB4BF) + (#x6B54 . #xDDC1) + (#x6B56 . #x8FC5F5) + (#x6B58 . #x8FC5F6) + (#x6B59 . #xDDC0) + (#x6B5B . #xDDC2) + (#x6B5D . #x8FC5F7) + (#x6B5F . #xDDC3) + (#x6B60 . #x8FC5F8) + (#x6B61 . #xDDC4) + (#x6B62 . #xBBDF) + (#x6B63 . #xC0B5) + (#x6B64 . #xBAA1) + (#x6B66 . #xC9F0) + (#x6B67 . #x8FC5F9) + (#x6B69 . #xCAE2) + (#x6B6A . #xCFC4) + (#x6B6B . #x8FC5FA) + (#x6B6E . #x8FC5FB) + (#x6B6F . #xBBF5) + (#x6B70 . #x8FC5FC) + (#x6B73 . #xBAD0) + (#x6B74 . #xCEF2) + (#x6B75 . #x8FC5FD) + (#x6B78 . #xDDC5) + (#x6B79 . #xDDC6) + (#x6B7B . #xBBE0) + (#x6B7D . #x8FC5FE) + (#x6B7E . #x8FC6A1) + (#x6B7F . #xDDC7) + (#x6B80 . #xDDC8) + (#x6B82 . #x8FC6A2) + (#x6B83 . #xDDCA) + (#x6B84 . #xDDC9) + (#x6B85 . #x8FC6A3) + (#x6B86 . #xCBD8) + (#x6B89 . #xBDDE) + (#x6B8A . #xBCEC) + (#x6B8B . #xBBC4) + (#x6B8D . #xDDCB) + (#x6B95 . #xDDCD) + (#x6B96 . #xBFA3) + (#x6B97 . #x8FC6A4) + (#x6B98 . #xDDCC) + (#x6B9B . #x8FC6A5) + (#x6B9E . #xDDCE) + (#x6B9F . #x8FC6A6) + (#x6BA0 . #x8FC6A7) + (#x6BA2 . #x8FC6A8) + (#x6BA3 . #x8FC6A9) + (#x6BA4 . #xDDCF) + (#x6BA8 . #x8FC6AA) + (#x6BA9 . #x8FC6AB) + (#x6BAA . #xDDD0) + (#x6BAB . #xDDD1) + (#x6BAC . #x8FC6AC) + (#x6BAD . #x8FC6AD) + (#x6BAE . #x8FC6AE) + (#x6BAF . #xDDD2) + (#x6BB0 . #x8FC6AF) + (#x6BB1 . #xDDD4) + (#x6BB2 . #xDDD3) + (#x6BB3 . #xDDD5) + (#x6BB4 . #xB2A5) + (#x6BB5 . #xC3CA) + (#x6BB7 . #xDDD6) + (#x6BB8 . #x8FC6B0) + (#x6BB9 . #x8FC6B1) + (#x6BBA . #xBBA6) + (#x6BBB . #xB3CC) + (#x6BBC . #xDDD7) + (#x6BBD . #x8FC6B2) + (#x6BBE . #x8FC6B3) + (#x6BBF . #xC5C2) + (#x6BC0 . #xD4CC) + (#x6BC3 . #x8FC6B4) + (#x6BC4 . #x8FC6B5) + (#x6BC5 . #xB5A3) + (#x6BC6 . #xDDD8) + (#x6BC9 . #x8FC6B6) + (#x6BCB . #xDDD9) + (#x6BCC . #x8FC6B7) + (#x6BCD . #xCAEC) + (#x6BCE . #xCBE8) + (#x6BD2 . #xC6C7) + (#x6BD3 . #xDDDA) + (#x6BD4 . #xC8E6) + (#x6BD6 . #x8FC6B8) + (#x6BD8 . #xC8FB) + (#x6BDA . #x8FC6B9) + (#x6BDB . #xCCD3) + (#x6BDF . #xDDDB) + (#x6BE1 . #x8FC6BA) + (#x6BE3 . #x8FC6BB) + (#x6BE6 . #x8FC6BC) + (#x6BE7 . #x8FC6BD) + (#x6BEB . #xDDDD) + (#x6BEC . #xDDDC) + (#x6BEE . #x8FC6BE) + (#x6BEF . #xDDDF) + (#x6BF1 . #x8FC6BF) + (#x6BF3 . #xDDDE) + (#x6BF7 . #x8FC6C0) + (#x6BF9 . #x8FC6C1) + (#x6BFF . #x8FC6C2) + (#x6C02 . #x8FC6C3) + (#x6C04 . #x8FC6C4) + (#x6C05 . #x8FC6C5) + (#x6C08 . #xDDE1) + (#x6C09 . #x8FC6C6) + (#x6C0D . #x8FC6C7) + (#x6C0E . #x8FC6C8) + (#x6C0F . #xBBE1) + (#x6C10 . #x8FC6C9) + (#x6C11 . #xCCB1) + (#x6C12 . #x8FC6CA) + (#x6C13 . #xDDE2) + (#x6C14 . #xDDE3) + (#x6C17 . #xB5A4) + (#x6C19 . #x8FC6CB) + (#x6C1B . #xDDE4) + (#x6C1F . #x8FC6CC) + (#x6C23 . #xDDE6) + (#x6C24 . #xDDE5) + (#x6C26 . #x8FC6CD) + (#x6C27 . #x8FC6CE) + (#x6C28 . #x8FC6CF) + (#x6C2C . #x8FC6D0) + (#x6C2E . #x8FC6D1) + (#x6C33 . #x8FC6D2) + (#x6C34 . #xBFE5) + (#x6C35 . #x8FC6D3) + (#x6C36 . #x8FC6D4) + (#x6C37 . #xC9B9) + (#x6C38 . #xB1CA) + (#x6C3A . #x8FC6D5) + (#x6C3B . #x8FC6D6) + (#x6C3E . #xC8C5) + (#x6C3F . #x8FC6D7) + (#x6C40 . #xC4F5) + (#x6C41 . #xBDC1) + (#x6C42 . #xB5E1) + (#x6C4A . #x8FC6D8) + (#x6C4B . #x8FC6D9) + (#x6C4D . #x8FC6DA) + (#x6C4E . #xC8C6) + (#x6C4F . #x8FC6DB) + (#x6C50 . #xBCAE) + (#x6C52 . #x8FC6DC) + (#x6C54 . #x8FC6DD) + (#x6C55 . #xDDE8) + (#x6C57 . #xB4C0) + (#x6C59 . #x8FC6DE) + (#x6C5A . #xB1F8) + (#x6C5B . #x8FC6DF) + (#x6C5C . #x8FC6E0) + (#x6C5D . #xC6F2) + (#x6C5E . #xDDE7) + (#x6C5F . #xB9BE) + (#x6C60 . #xC3D3) + (#x6C62 . #xDDE9) + (#x6C67 . #x8FC7B6) + (#x6C68 . #xDDF1) + (#x6C6A . #xDDEA) + (#x6C6B . #x8FC6E1) + (#x6C6D . #x8FC6E2) + (#x6C6F . #x8FC6E3) + (#x6C70 . #xC2C1) + (#x6C72 . #xB5E2) + (#x6C73 . #xDDF2) + (#x6C74 . #x8FC6E4) + (#x6C76 . #x8FC6E5) + (#x6C78 . #x8FC6E6) + (#x6C79 . #x8FC6E7) + (#x6C7A . #xB7E8) + (#x6C7B . #x8FC6E8) + (#x6C7D . #xB5A5) + (#x6C7E . #xDDF0) + (#x6C81 . #xDDEE) + (#x6C82 . #xDDEB) + (#x6C83 . #xCDE0) + (#x6C85 . #x8FC6E9) + (#x6C86 . #x8FC6EA) + (#x6C87 . #x8FC6EB) + (#x6C88 . #xC4C0) + (#x6C89 . #x8FC6EC) + (#x6C8C . #xC6D9) + (#x6C8D . #xDDEC) + (#x6C90 . #xDDF4) + (#x6C92 . #xDDF3) + (#x6C93 . #xB7A3) + (#x6C94 . #x8FC6ED) + (#x6C95 . #x8FC6EE) + (#x6C96 . #xB2AD) + (#x6C97 . #x8FC6EF) + (#x6C98 . #x8FC6F0) + (#x6C99 . #xBABB) + (#x6C9A . #xDDED) + (#x6C9B . #xDDEF) + (#x6C9C . #x8FC6F1) + (#x6C9F . #x8FC6F2) + (#x6CA1 . #xCBD7) + (#x6CA2 . #xC2F4) + (#x6CAB . #xCBF7) + (#x6CAE . #xDDFC) + (#x6CB0 . #x8FC6F3) + (#x6CB1 . #xDDFD) + (#x6CB2 . #x8FC6F4) + (#x6CB3 . #xB2CF) + (#x6CB4 . #x8FC6F5) + (#x6CB8 . #xCAA8) + (#x6CB9 . #xCCFD) + (#x6CBA . #xDEA1) + (#x6CBB . #xBCA3) + (#x6CBC . #xBEC2) + (#x6CBD . #xDDF8) + (#x6CBE . #xDDFE) + (#x6CBF . #xB1E8) + (#x6CC1 . #xB6B7) + (#x6CC2 . #x8FC6F6) + (#x6CC4 . #xDDF5) + (#x6CC5 . #xDDFA) + (#x6CC6 . #x8FC6F7) + (#x6CC9 . #xC0F4) + (#x6CCA . #xC7F1) + (#x6CCC . #xC8E7) + (#x6CCD . #x8FC6F8) + (#x6CCF . #x8FC6F9) + (#x6CD0 . #x8FC6FA) + (#x6CD1 . #x8FC6FB) + (#x6CD2 . #x8FC6FC) + (#x6CD3 . #xDDF7) + (#x6CD4 . #x8FC6FD) + (#x6CD5 . #xCBA1) + (#x6CD6 . #x8FC6FE) + (#x6CD7 . #xDDF9) + (#x6CD9 . #xDEA4) + (#x6CDA . #x8FC7A1) + (#x6CDB . #xDEA2) + (#x6CDC . #x8FC7A2) + (#x6CDD . #xDDFB) + (#x6CE0 . #x8FC7A3) + (#x6CE1 . #xCBA2) + (#x6CE2 . #xC7C8) + (#x6CE3 . #xB5E3) + (#x6CE5 . #xC5A5) + (#x6CE7 . #x8FC7A4) + (#x6CE8 . #xC3ED) + (#x6CE9 . #x8FC7A5) + (#x6CEA . #xDEA5) + (#x6CEB . #x8FC7A6) + (#x6CEC . #x8FC7A7) + (#x6CEE . #x8FC7A8) + (#x6CEF . #xDEA3) + (#x6CF0 . #xC2D9) + (#x6CF1 . #xDDF6) + (#x6CF2 . #x8FC7A9) + (#x6CF3 . #xB1CB) + (#x6CF4 . #x8FC7AA) + (#x6D04 . #x8FC7AB) + (#x6D07 . #x8FC7AC) + (#x6D0A . #x8FC7AD) + (#x6D0B . #xCDCE) + (#x6D0C . #xDEB0) + (#x6D0E . #x8FC7AE) + (#x6D0F . #x8FC7AF) + (#x6D11 . #x8FC7B0) + (#x6D12 . #xDEAF) + (#x6D13 . #x8FC7B1) + (#x6D17 . #xC0F6) + (#x6D19 . #xDEAC) + (#x6D1A . #x8FC7B2) + (#x6D1B . #xCDEC) + (#x6D1E . #xC6B6) + (#x6D1F . #xDEA6) + (#x6D25 . #xC4C5) + (#x6D26 . #x8FC7B3) + (#x6D27 . #x8FC7B4) + (#x6D28 . #x8FC7B5) + (#x6D29 . #xB1CC) + (#x6D2A . #xB9BF) + (#x6D2B . #xDEA9) + (#x6D2E . #x8FC7B7) + (#x6D2F . #x8FC7B8) + (#x6D31 . #x8FC7B9) + (#x6D32 . #xBDA7) + (#x6D33 . #xDEAE) + (#x6D35 . #xDEAD) + (#x6D36 . #xDEA8) + (#x6D38 . #xDEAB) + (#x6D39 . #x8FC7BA) + (#x6D3B . #xB3E8) + (#x6D3C . #x8FC7BB) + (#x6D3D . #xDEAA) + (#x6D3E . #xC7C9) + (#x6D3F . #x8FC7BC) + (#x6D41 . #xCEAE) + (#x6D44 . #xBEF4) + (#x6D45 . #xC0F5) + (#x6D57 . #x8FC7BD) + (#x6D59 . #xDEB6) + (#x6D5A . #xDEB4) + (#x6D5C . #xC9CD) + (#x6D5E . #x8FC7BE) + (#x6D5F . #x8FC7BF) + (#x6D61 . #x8FC7C0) + (#x6D63 . #xDEB1) + (#x6D64 . #xDEB3) + (#x6D65 . #x8FC7C1) + (#x6D66 . #xB1BA) + (#x6D67 . #x8FC7C2) + (#x6D69 . #xB9C0) + (#x6D6A . #xCFB2) + (#x6D6C . #xB3BD) + (#x6D6E . #xC9E2) + (#x6D6F . #x8FC7C3) + (#x6D70 . #x8FC7C4) + (#x6D74 . #xCDE1) + (#x6D77 . #xB3A4) + (#x6D78 . #xBFBB) + (#x6D79 . #xDEB5) + (#x6D7C . #x8FC7C5) + (#x6D82 . #x8FC7C6) + (#x6D85 . #xDEBA) + (#x6D87 . #x8FC7C7) + (#x6D88 . #xBEC3) + (#x6D8C . #xCDB0) + (#x6D8E . #xDEB7) + (#x6D91 . #x8FC7C8) + (#x6D92 . #x8FC7C9) + (#x6D93 . #xDEB2) + (#x6D94 . #x8FC7CA) + (#x6D95 . #xDEB8) + (#x6D96 . #x8FC7CB) + (#x6D97 . #x8FC7CC) + (#x6D98 . #x8FC7CD) + (#x6D99 . #xCEDE) + (#x6D9B . #xC5F3) + (#x6D9C . #xC6C2) + (#x6DAA . #x8FC7CE) + (#x6DAC . #x8FC7CF) + (#x6DAF . #xB3B6) + (#x6DB2 . #xB1D5) + (#x6DB4 . #x8FC7D0) + (#x6DB5 . #xDEBE) + (#x6DB7 . #x8FC7D1) + (#x6DB8 . #xDEC1) + (#x6DB9 . #x8FC7D2) + (#x6DBC . #xCEC3) + (#x6DBD . #x8FC7D3) + (#x6DBF . #x8FC7D4) + (#x6DC0 . #xCDE4) + (#x6DC4 . #x8FC7D5) + (#x6DC5 . #xDEC8) + (#x6DC6 . #xDEC2) + (#x6DC7 . #xDEBF) + (#x6DC8 . #x8FC7D6) + (#x6DCA . #x8FC7D7) + (#x6DCB . #xCED4) + (#x6DCC . #xDEC5) + (#x6DCE . #x8FC7D8) + (#x6DCF . #x8FC7D9) + (#x6DD1 . #xBDCA) + (#x6DD2 . #xDEC7) + (#x6DD5 . #xDECC) + (#x6DD6 . #x8FC7DA) + (#x6DD8 . #xC5F1) + (#x6DD9 . #xDECA) + (#x6DDB . #x8FC7DB) + (#x6DDD . #x8FC7DC) + (#x6DDE . #xDEC4) + (#x6DDF . #x8FC7DD) + (#x6DE0 . #x8FC7DE) + (#x6DE1 . #xC3B8) + (#x6DE2 . #x8FC7DF) + (#x6DE4 . #xDECB) + (#x6DE5 . #x8FC7E0) + (#x6DE6 . #xDEC0) + (#x6DE8 . #xDEC6) + (#x6DE9 . #x8FC7E1) + (#x6DEA . #xDECD) + (#x6DEB . #xB0FC) + (#x6DEC . #xDEC3) + (#x6DEE . #xDECE) + (#x6DEF . #x8FC7E2) + (#x6DF0 . #x8FC7E3) + (#x6DF1 . #xBFBC) + (#x6DF3 . #xBDDF) + (#x6DF4 . #x8FC7E4) + (#x6DF5 . #xCAA5) + (#x6DF6 . #x8FC7E5) + (#x6DF7 . #xBAAE) + (#x6DF9 . #xDEBB) + (#x6DFA . #xDEC9) + (#x6DFB . #xC5BA) + (#x6DFC . #x8FC7E6) + (#x6E00 . #x8FC7E7) + (#x6E04 . #x8FC7E8) + (#x6E05 . #xC0B6) + (#x6E07 . #xB3E9) + (#x6E08 . #xBAD1) + (#x6E09 . #xBEC4) + (#x6E0A . #xDEBD) + (#x6E0B . #xBDC2) + (#x6E13 . #xB7CC) + (#x6E15 . #xDEBC) + (#x6E19 . #xDED2) + (#x6E1A . #xBDED) + (#x6E1B . #xB8BA) + (#x6E1D . #xDEE1) + (#x6E1E . #x8FC7E9) + (#x6E1F . #xDEDB) + (#x6E20 . #xB5F4) + (#x6E21 . #xC5CF) + (#x6E22 . #x8FC7EA) + (#x6E23 . #xDED6) + (#x6E24 . #xDEDF) + (#x6E25 . #xB0AF) + (#x6E26 . #xB1B2) + (#x6E27 . #x8FC7EB) + (#x6E29 . #xB2B9) + (#x6E2B . #xDED8) + (#x6E2C . #xC2AC) + (#x6E2D . #xDECF) + (#x6E2E . #xDED1) + (#x6E2F . #xB9C1) + (#x6E32 . #x8FC7EC) + (#x6E36 . #x8FC7ED) + (#x6E38 . #xDEE2) + (#x6E39 . #x8FC7EE) + (#x6E3A . #xDEDD) + (#x6E3B . #x8FC7EF) + (#x6E3C . #x8FC7F0) + (#x6E3E . #xDED5) + (#x6E43 . #xDEDC) + (#x6E44 . #x8FC7F1) + (#x6E45 . #x8FC7F2) + (#x6E48 . #x8FC7F3) + (#x6E49 . #x8FC7F4) + (#x6E4A . #xCCAB) + (#x6E4B . #x8FC7F5) + (#x6E4D . #xDEDA) + (#x6E4E . #xDEDE) + (#x6E4F . #x8FC7F6) + (#x6E51 . #x8FC7F7) + (#x6E52 . #x8FC7F8) + (#x6E53 . #x8FC7F9) + (#x6E54 . #x8FC7FA) + (#x6E56 . #xB8D0) + (#x6E57 . #x8FC7FB) + (#x6E58 . #xBEC5) + (#x6E5B . #xC3B9) + (#x6E5C . #x8FC7FC) + (#x6E5D . #x8FC7FD) + (#x6E5E . #x8FC7FE) + (#x6E5F . #xDED4) + (#x6E62 . #x8FC8A1) + (#x6E63 . #x8FC8A2) + (#x6E67 . #xCDAF) + (#x6E68 . #x8FC8A3) + (#x6E6B . #xDED7) + (#x6E6E . #xDED0) + (#x6E6F . #xC5F2) + (#x6E72 . #xDED3) + (#x6E73 . #x8FC8A4) + (#x6E76 . #xDED9) + (#x6E7B . #x8FC8A5) + (#x6E7D . #x8FC8A6) + (#x6E7E . #xCFD1) + (#x6E7F . #xBCBE) + (#x6E80 . #xCBFE) + (#x6E82 . #xDEE3) + (#x6E8C . #xC8AE) + (#x6E8D . #x8FC8A7) + (#x6E8F . #xDEEF) + (#x6E90 . #xB8BB) + (#x6E93 . #x8FC8A8) + (#x6E96 . #xBDE0) + (#x6E98 . #xDEE5) + (#x6E99 . #x8FC8A9) + (#x6E9C . #xCEAF) + (#x6E9D . #xB9C2) + (#x6E9F . #xDEF2) + (#x6EA0 . #x8FC8AA) + (#x6EA2 . #xB0EE) + (#x6EA5 . #xDEF0) + (#x6EA7 . #x8FC8AB) + (#x6EAA . #xDEE4) + (#x6EAD . #x8FC8AC) + (#x6EAE . #x8FC8AD) + (#x6EAF . #xDEEA) + (#x6EB1 . #x8FC8AE) + (#x6EB2 . #xDEEC) + (#x6EB3 . #x8FC8AF) + (#x6EB6 . #xCDCF) + (#x6EB7 . #xDEE7) + (#x6EBA . #xC5AE) + (#x6EBB . #x8FC8B0) + (#x6EBD . #xDEE9) + (#x6EBF . #x8FC8B1) + (#x6EC0 . #x8FC8B2) + (#x6EC1 . #x8FC8B3) + (#x6EC2 . #xDEF1) + (#x6EC3 . #x8FC8B4) + (#x6EC4 . #xDEEB) + (#x6EC5 . #xCCC7) + (#x6EC7 . #x8FC8B5) + (#x6EC8 . #x8FC8B6) + (#x6EC9 . #xDEE6) + (#x6ECA . #x8FC8B7) + (#x6ECB . #xBCA2) + (#x6ECC . #xDEFE) + (#x6ECD . #x8FC8B8) + (#x6ECE . #x8FC8B9) + (#x6ECF . #x8FC8BA) + (#x6ED1 . #xB3EA) + (#x6ED3 . #xDEE8) + (#x6ED4 . #xDEED) + (#x6ED5 . #xDEEE) + (#x6EDD . #xC2EC) + (#x6EDE . #xC2DA) + (#x6EEB . #x8FC8BB) + (#x6EEC . #xDEF6) + (#x6EED . #x8FC8BC) + (#x6EEE . #x8FC8BD) + (#x6EEF . #xDEFC) + (#x6EF2 . #xDEFA) + (#x6EF4 . #xC5A9) + (#x6EF7 . #xDFA3) + (#x6EF8 . #xDEF7) + (#x6EF9 . #x8FC8BE) + (#x6EFB . #x8FC8BF) + (#x6EFD . #x8FC8C0) + (#x6EFE . #xDEF8) + (#x6EFF . #xDEE0) + (#x6F01 . #xB5F9) + (#x6F02 . #xC9BA) + (#x6F04 . #x8FC8C1) + (#x6F06 . #xBCBF) + (#x6F08 . #x8FC8C2) + (#x6F09 . #xB9F7) + (#x6F0A . #x8FC8C3) + (#x6F0C . #x8FC8C4) + (#x6F0D . #x8FC8C5) + (#x6F0F . #xCFB3) + (#x6F11 . #xDEF4) + (#x6F13 . #xDFA2) + (#x6F14 . #xB1E9) + (#x6F15 . #xC1E6) + (#x6F16 . #x8FC8C6) + (#x6F18 . #x8FC8C7) + (#x6F1A . #x8FC8C8) + (#x6F1B . #x8FC8C9) + (#x6F20 . #xC7F9) + (#x6F22 . #xB4C1) + (#x6F23 . #xCEFA) + (#x6F26 . #x8FC8CA) + (#x6F29 . #x8FC8CB) + (#x6F2A . #x8FC8CC) + (#x6F2B . #xCCA1) + (#x6F2C . #xC4D2) + (#x6F2D . #x8FC8D3) + (#x6F2F . #x8FC8CD) + (#x6F30 . #x8FC8CE) + (#x6F31 . #xDEFB) + (#x6F32 . #xDEFD) + (#x6F33 . #x8FC8CF) + (#x6F36 . #x8FC8D0) + (#x6F38 . #xC1B2) + (#x6F3B . #x8FC8D1) + (#x6F3C . #x8FC8D2) + (#x6F3E . #xDFA1) + (#x6F3F . #xDEF9) + (#x6F41 . #xDEF3) + (#x6F45 . #xB4C3) + (#x6F4F . #x8FC8D4) + (#x6F51 . #x8FC8D5) + (#x6F52 . #x8FC8D6) + (#x6F53 . #x8FC8D7) + (#x6F54 . #xB7E9) + (#x6F57 . #x8FC8D8) + (#x6F58 . #xDFAF) + (#x6F59 . #x8FC8D9) + (#x6F5A . #x8FC8DA) + (#x6F5B . #xDFAA) + (#x6F5C . #xC0F8) + (#x6F5D . #x8FC8DB) + (#x6F5E . #x8FC8DC) + (#x6F5F . #xB3E3) + (#x6F61 . #x8FC8DD) + (#x6F62 . #x8FC8DE) + (#x6F64 . #xBDE1) + (#x6F66 . #xDFB3) + (#x6F68 . #x8FC8DF) + (#x6F6C . #x8FC8E0) + (#x6F6D . #xDFAC) + (#x6F6E . #xC4AC) + (#x6F6F . #xDFA9) + (#x6F70 . #xC4D9) + (#x6F74 . #xDFCC) + (#x6F78 . #xDFA6) + (#x6F7A . #xDFA5) + (#x6F7C . #xDFAE) + (#x6F7D . #x8FC8E1) + (#x6F7E . #x8FC8E2) + (#x6F80 . #xDFA8) + (#x6F81 . #xDFA7) + (#x6F82 . #xDFAD) + (#x6F83 . #x8FC8E3) + (#x6F84 . #xC0A1) + (#x6F86 . #xDFA4) + (#x6F87 . #x8FC8E4) + (#x6F88 . #x8FC8E5) + (#x6F8B . #x8FC8E6) + (#x6F8C . #x8FC8E7) + (#x6F8D . #x8FC8E8) + (#x6F8E . #xDFB0) + (#x6F90 . #x8FC8E9) + (#x6F91 . #xDFB1) + (#x6F92 . #x8FC8EA) + (#x6F93 . #x8FC8EB) + (#x6F94 . #x8FC8EC) + (#x6F96 . #x8FC8ED) + (#x6F97 . #xB4C2) + (#x6F9A . #x8FC8EE) + (#x6F9F . #x8FC8EF) + (#x6FA0 . #x8FC8F0) + (#x6FA1 . #xDFB6) + (#x6FA3 . #xDFB5) + (#x6FA4 . #xDFB7) + (#x6FA5 . #x8FC8F1) + (#x6FA6 . #x8FC8F2) + (#x6FA7 . #x8FC8F3) + (#x6FA8 . #x8FC8F4) + (#x6FAA . #xDFBA) + (#x6FAE . #x8FC8F5) + (#x6FAF . #x8FC8F6) + (#x6FB0 . #x8FC8F7) + (#x6FB1 . #xC5C3) + (#x6FB3 . #xDFB4) + (#x6FB5 . #x8FC8F8) + (#x6FB6 . #x8FC8F9) + (#x6FB9 . #xDFB8) + (#x6FBC . #x8FC8FA) + (#x6FC0 . #xB7E3) + (#x6FC1 . #xC2F9) + (#x6FC2 . #xDFB2) + (#x6FC3 . #xC7BB) + (#x6FC5 . #x8FC8FB) + (#x6FC6 . #xDFB9) + (#x6FC7 . #x8FC8FC) + (#x6FC8 . #x8FC8FD) + (#x6FCA . #x8FC8FE) + (#x6FD4 . #xDFBE) + (#x6FD5 . #xDFBC) + (#x6FD8 . #xDFBF) + (#x6FDA . #x8FC9A1) + (#x6FDB . #xDFC2) + (#x6FDE . #x8FC9A2) + (#x6FDF . #xDFBB) + (#x6FE0 . #xB9EA) + (#x6FE1 . #xC7A8) + (#x6FE4 . #xDEB9) + (#x6FE8 . #x8FC9A3) + (#x6FE9 . #x8FC9A4) + (#x6FEB . #xCDF4) + (#x6FEC . #xDFBD) + (#x6FEE . #xDFC1) + (#x6FEF . #xC2F5) + (#x6FF0 . #x8FC9A5) + (#x6FF1 . #xDFC0) + (#x6FF3 . #xDFAB) + (#x6FF5 . #x8FC9A6) + (#x6FF6 . #xEFE9) + (#x6FF9 . #x8FC9A7) + (#x6FFA . #xDFC5) + (#x6FFC . #x8FC9A8) + (#x6FFD . #x8FC9A9) + (#x6FFE . #xDFC9) + (#x7000 . #x8FC9AA) + (#x7001 . #xDFC7) + (#x7005 . #x8FC9AB) + (#x7006 . #x8FC9AC) + (#x7007 . #x8FC9AD) + (#x7009 . #xDFC3) + (#x700B . #xDFC4) + (#x700D . #x8FC9AE) + (#x700F . #xDFC8) + (#x7011 . #xDFC6) + (#x7015 . #xC9CE) + (#x7017 . #x8FC9AF) + (#x7018 . #xDFCE) + (#x701A . #xDFCB) + (#x701B . #xDFCA) + (#x701D . #xDFCD) + (#x701E . #xC6D4) + (#x701F . #xDFCF) + (#x7020 . #x8FC9B0) + (#x7023 . #x8FC9B1) + (#x7026 . #xC3F5) + (#x7027 . #xC2ED) + (#x702C . #xC0A5) + (#x702F . #x8FC9B2) + (#x7030 . #xDFD0) + (#x7032 . #xDFD2) + (#x7034 . #x8FC9B3) + (#x7037 . #x8FC9B4) + (#x7039 . #x8FC9B5) + (#x703C . #x8FC9B6) + (#x703E . #xDFD1) + (#x7043 . #x8FC9B7) + (#x7044 . #x8FC9B8) + (#x7048 . #x8FC9B9) + (#x7049 . #x8FC9BA) + (#x704A . #x8FC9BB) + (#x704B . #x8FC9BC) + (#x704C . #xDEF5) + (#x704E . #x8FC9C1) + (#x7051 . #xDFD3) + (#x7054 . #x8FC9BD) + (#x7055 . #x8FC9BE) + (#x7058 . #xC6E7) + (#x705D . #x8FC9BF) + (#x705E . #x8FC9C0) + (#x7063 . #xDFD4) + (#x7064 . #x8FC9C2) + (#x7065 . #x8FC9C3) + (#x706B . #xB2D0) + (#x706C . #x8FC9C4) + (#x706E . #x8FC9C5) + (#x706F . #xC5F4) + (#x7070 . #xB3A5) + (#x7075 . #x8FC9C6) + (#x7076 . #x8FC9C7) + (#x7078 . #xB5E4) + (#x707C . #xBCDE) + (#x707D . #xBAD2) + (#x707E . #x8FC9C8) + (#x7081 . #x8FC9C9) + (#x7085 . #x8FC9CA) + (#x7086 . #x8FC9CB) + (#x7089 . #xCFA7) + (#x708A . #xBFE6) + (#x708E . #xB1EA) + (#x7092 . #xDFD6) + (#x7094 . #x8FC9CC) + (#x7095 . #x8FC9CD) + (#x7096 . #x8FC9CE) + (#x7097 . #x8FC9CF) + (#x7098 . #x8FC9D0) + (#x7099 . #xDFD5) + (#x709B . #x8FC9D1) + (#x70A4 . #x8FC9D2) + (#x70AB . #x8FC9D3) + (#x70AC . #xDFD9) + (#x70AD . #xC3BA) + (#x70AE . #xDFDC) + (#x70AF . #xDFD7) + (#x70B0 . #x8FC9D4) + (#x70B1 . #x8FC9D5) + (#x70B3 . #xDFDB) + (#x70B4 . #x8FC9D6) + (#x70B7 . #x8FC9D7) + (#x70B8 . #xDFDA) + (#x70B9 . #xC5C0) + (#x70BA . #xB0D9) + (#x70C8 . #xCEF5) + (#x70CA . #x8FC9D8) + (#x70CB . #xDFDE) + (#x70CF . #xB1A8) + (#x70D1 . #x8FC9D9) + (#x70D3 . #x8FC9DA) + (#x70D4 . #x8FC9DB) + (#x70D5 . #x8FC9DC) + (#x70D6 . #x8FC9DD) + (#x70D8 . #x8FC9DE) + (#x70D9 . #xDFE0) + (#x70DC . #x8FC9DF) + (#x70DD . #xDFDF) + (#x70DF . #xDFDD) + (#x70E4 . #x8FC9E0) + (#x70F1 . #xDFD8) + (#x70F9 . #xCBA3) + (#x70FA . #x8FC9E1) + (#x70FD . #xDFE2) + (#x7103 . #x8FC9E2) + (#x7104 . #x8FC9E3) + (#x7105 . #x8FC9E4) + (#x7106 . #x8FC9E5) + (#x7107 . #x8FC9E6) + (#x7109 . #xDFE1) + (#x710B . #x8FC9E7) + (#x710C . #x8FC9E8) + (#x710F . #x8FC9E9) + (#x7114 . #xB1EB) + (#x7119 . #xDFE4) + (#x711A . #xCAB2) + (#x711C . #xDFE3) + (#x711E . #x8FC9EA) + (#x7120 . #x8FC9EB) + (#x7121 . #xCCB5) + (#x7126 . #xBEC7) + (#x712B . #x8FC9EC) + (#x712D . #x8FC9ED) + (#x712F . #x8FC9EE) + (#x7130 . #x8FC9EF) + (#x7131 . #x8FC9F0) + (#x7136 . #xC1B3) + (#x7138 . #x8FC9F1) + (#x713C . #xBEC6) + (#x7141 . #x8FC9F2) + (#x7145 . #x8FC9F3) + (#x7146 . #x8FC9F4) + (#x7147 . #x8FC9F5) + (#x7149 . #xCEFB) + (#x714A . #x8FC9F6) + (#x714B . #x8FC9F7) + (#x714C . #xDFEA) + (#x714E . #xC0F9) + (#x7150 . #x8FC9F8) + (#x7152 . #x8FC9F9) + (#x7155 . #xDFE6) + (#x7156 . #xDFEB) + (#x7157 . #x8FC9FA) + (#x7159 . #xB1EC) + (#x715A . #x8FC9FB) + (#x715C . #x8FC9FC) + (#x715E . #x8FC9FD) + (#x7160 . #x8FC9FE) + (#x7162 . #xDFE9) + (#x7164 . #xC7E1) + (#x7165 . #xDFE5) + (#x7166 . #xDFE8) + (#x7167 . #xBEC8) + (#x7168 . #x8FCAA1) + (#x7169 . #xC8D1) + (#x716C . #xDFEC) + (#x716E . #xBCD1) + (#x7179 . #x8FCAA2) + (#x717D . #xC0FA) + (#x7180 . #x8FCAA3) + (#x7184 . #xDFEF) + (#x7185 . #x8FCAA4) + (#x7187 . #x8FCAA5) + (#x7188 . #xDFE7) + (#x718A . #xB7A7) + (#x718C . #x8FCAA6) + (#x718F . #xDFED) + (#x7192 . #x8FCAA7) + (#x7194 . #xCDD0) + (#x7195 . #xDFF0) + (#x7199 . #xF4A6) + (#x719A . #x8FCAA8) + (#x719B . #x8FCAA9) + (#x719F . #xBDCF) + (#x71A0 . #x8FCAAA) + (#x71A2 . #x8FCAAB) + (#x71A8 . #xDFF1) + (#x71AC . #xDFF2) + (#x71AF . #x8FCAAC) + (#x71B0 . #x8FCAAD) + (#x71B1 . #xC7AE) + (#x71B2 . #x8FCAAE) + (#x71B3 . #x8FCAAF) + (#x71B9 . #xDFF4) + (#x71BA . #x8FCAB0) + (#x71BE . #xDFF5) + (#x71BF . #x8FCAB1) + (#x71C0 . #x8FCAB2) + (#x71C1 . #x8FCAB3) + (#x71C3 . #xC7B3) + (#x71C4 . #x8FCAB4) + (#x71C8 . #xC5F5) + (#x71C9 . #xDFF7) + (#x71CB . #x8FCAB5) + (#x71CC . #x8FCAB6) + (#x71CE . #xDFF9) + (#x71D0 . #xCED5) + (#x71D2 . #xDFF6) + (#x71D3 . #x8FCAB7) + (#x71D4 . #xDFF8) + (#x71D5 . #xB1ED) + (#x71D6 . #x8FCAB8) + (#x71D7 . #xDFF3) + (#x71D9 . #x8FCAB9) + (#x71DA . #x8FCABA) + (#x71DC . #x8FCABB) + (#x71DF . #xD3DB) + (#x71E0 . #xDFFA) + (#x71E5 . #xC1E7) + (#x71E6 . #xBBB8) + (#x71E7 . #xDFFC) + (#x71EC . #xDFFB) + (#x71ED . #xBFA4) + (#x71EE . #xD2D9) + (#x71F5 . #xDFFD) + (#x71F8 . #x8FCABC) + (#x71F9 . #xE0A1) + (#x71FB . #xDFEE) + (#x71FC . #xDFFE) + (#x71FE . #x8FCABD) + (#x71FF . #xE0A2) + (#x7200 . #x8FCABE) + (#x7206 . #xC7FA) + (#x7207 . #x8FCABF) + (#x7208 . #x8FCAC0) + (#x7209 . #x8FCAC1) + (#x720D . #xE0A3) + (#x7210 . #xE0A4) + (#x7213 . #x8FCAC2) + (#x7217 . #x8FCAC3) + (#x721A . #x8FCAC4) + (#x721B . #xE0A5) + (#x721D . #x8FCAC5) + (#x721F . #x8FCAC6) + (#x7224 . #x8FCAC7) + (#x7228 . #xE0A6) + (#x722A . #xC4DE) + (#x722B . #x8FCAC8) + (#x722C . #xE0A8) + (#x722D . #xE0A7) + (#x722F . #x8FCAC9) + (#x7230 . #xE0A9) + (#x7232 . #xE0AA) + (#x7234 . #x8FCACA) + (#x7235 . #xBCDF) + (#x7236 . #xC9E3) + (#x7238 . #x8FCACB) + (#x7239 . #x8FCACC) + (#x723A . #xCCEC) + (#x723B . #xE0AB) + (#x723C . #xE0AC) + (#x723D . #xC1D6) + (#x723E . #xBCA4) + (#x723F . #xE0AD) + (#x7240 . #xE0AE) + (#x7241 . #x8FCACD) + (#x7242 . #x8FCACE) + (#x7243 . #x8FCACF) + (#x7245 . #x8FCAD0) + (#x7246 . #xE0AF) + (#x7247 . #xCAD2) + (#x7248 . #xC8C7) + (#x724B . #xE0B0) + (#x724C . #xC7D7) + (#x724E . #x8FCAD1) + (#x724F . #x8FCAD2) + (#x7250 . #x8FCAD3) + (#x7252 . #xC4AD) + (#x7253 . #x8FCAD4) + (#x7255 . #x8FCAD5) + (#x7256 . #x8FCAD6) + (#x7258 . #xE0B1) + (#x7259 . #xB2E7) + (#x725A . #x8FCAD7) + (#x725B . #xB5ED) + (#x725C . #x8FCAD8) + (#x725D . #xCCC6) + (#x725E . #x8FCAD9) + (#x725F . #xCCB6) + (#x7260 . #x8FCADA) + (#x7261 . #xB2B4) + (#x7262 . #xCFB4) + (#x7263 . #x8FCADB) + (#x7267 . #xCBD2) + (#x7268 . #x8FCADC) + (#x7269 . #xCAAA) + (#x726B . #x8FCADD) + (#x726E . #x8FCADE) + (#x726F . #x8FCADF) + (#x7271 . #x8FCAE0) + (#x7272 . #xC0B7) + (#x7274 . #xE0B2) + (#x7277 . #x8FCAE1) + (#x7278 . #x8FCAE2) + (#x7279 . #xC6C3) + (#x727B . #x8FCAE3) + (#x727C . #x8FCAE4) + (#x727D . #xB8A3) + (#x727E . #xE0B3) + (#x727F . #x8FCAE5) + (#x7280 . #xBAD4) + (#x7281 . #xE0B5) + (#x7282 . #xE0B4) + (#x7284 . #x8FCAE6) + (#x7287 . #xE0B6) + (#x7289 . #x8FCAE7) + (#x728D . #x8FCAE8) + (#x728E . #x8FCAE9) + (#x7292 . #xE0B7) + (#x7293 . #x8FCAEA) + (#x7296 . #xE0B8) + (#x729B . #x8FCAEB) + (#x72A0 . #xB5BE) + (#x72A2 . #xE0B9) + (#x72A7 . #xE0BA) + (#x72A8 . #x8FCAEC) + (#x72AC . #xB8A4) + (#x72AD . #x8FCAED) + (#x72AE . #x8FCAEE) + (#x72AF . #xC8C8) + (#x72B1 . #x8FCAEF) + (#x72B2 . #xE0BC) + (#x72B4 . #x8FCAF0) + (#x72B6 . #xBEF5) + (#x72B9 . #xE0BB) + (#x72BE . #x8FCAF1) + (#x72C1 . #x8FCAF2) + (#x72C2 . #xB6B8) + (#x72C3 . #xE0BD) + (#x72C4 . #xE0BF) + (#x72C6 . #xE0BE) + (#x72C7 . #x8FCAF3) + (#x72C9 . #x8FCAF4) + (#x72CC . #x8FCAF5) + (#x72CE . #xE0C0) + (#x72D0 . #xB8D1) + (#x72D2 . #xE0C1) + (#x72D5 . #x8FCAF6) + (#x72D6 . #x8FCAF7) + (#x72D7 . #xB6E9) + (#x72D8 . #x8FCAF8) + (#x72D9 . #xC1C0) + (#x72DB . #xB9FD) + (#x72DF . #x8FCAF9) + (#x72E0 . #xE0C3) + (#x72E1 . #xE0C4) + (#x72E2 . #xE0C2) + (#x72E5 . #x8FCAFA) + (#x72E9 . #xBCED) + (#x72EC . #xC6C8) + (#x72ED . #xB6B9) + (#x72F3 . #x8FCAFB) + (#x72F4 . #x8FCAFC) + (#x72F7 . #xE0C6) + (#x72F8 . #xC3AC) + (#x72F9 . #xE0C5) + (#x72FA . #x8FCAFD) + (#x72FB . #x8FCAFE) + (#x72FC . #xCFB5) + (#x72FD . #xC7E2) + (#x72FE . #x8FCBA1) + (#x7302 . #x8FCBA2) + (#x7304 . #x8FCBA3) + (#x7305 . #x8FCBA4) + (#x7307 . #x8FCBA5) + (#x730A . #xE0C9) + (#x730B . #x8FCBA6) + (#x730D . #x8FCBA7) + (#x7312 . #x8FCBA8) + (#x7313 . #x8FCBA9) + (#x7316 . #xE0CB) + (#x7317 . #xE0C8) + (#x7318 . #x8FCBAA) + (#x7319 . #x8FCBAB) + (#x731B . #xCCD4) + (#x731C . #xE0CA) + (#x731D . #xE0CC) + (#x731E . #x8FCBAC) + (#x731F . #xCEC4) + (#x7322 . #x8FCBAD) + (#x7324 . #x8FCBAE) + (#x7325 . #xE0D0) + (#x7327 . #x8FCBAF) + (#x7328 . #x8FCBB0) + (#x7329 . #xE0CF) + (#x732A . #xC3F6) + (#x732B . #xC7AD) + (#x732C . #x8FCBB1) + (#x732E . #xB8A5) + (#x732F . #xE0CE) + (#x7331 . #x8FCBB2) + (#x7332 . #x8FCBB3) + (#x7334 . #xE0CD) + (#x7335 . #x8FCBB4) + (#x7336 . #xCDB1) + (#x7337 . #xCDB2) + (#x733A . #x8FCBB5) + (#x733B . #x8FCBB6) + (#x733D . #x8FCBB7) + (#x733E . #xE0D1) + (#x733F . #xB1EE) + (#x7343 . #x8FCBB8) + (#x7344 . #xB9F6) + (#x7345 . #xBBE2) + (#x734D . #x8FCBB9) + (#x734E . #xE0D2) + (#x734F . #xE0D3) + (#x7350 . #x8FCBBA) + (#x7352 . #x8FCBBB) + (#x7356 . #x8FCBBC) + (#x7357 . #xE0D5) + (#x7358 . #x8FCBBD) + (#x735D . #x8FCBBE) + (#x735E . #x8FCBBF) + (#x735F . #x8FCBC0) + (#x7360 . #x8FCBC1) + (#x7363 . #xBDC3) + (#x7366 . #x8FCBC2) + (#x7367 . #x8FCBC3) + (#x7368 . #xE0D7) + (#x7369 . #x8FCBC4) + (#x736A . #xE0D6) + (#x736B . #x8FCBC5) + (#x736C . #x8FCBC6) + (#x736E . #x8FCBC7) + (#x736F . #x8FCBC8) + (#x7370 . #xE0D8) + (#x7371 . #x8FCBC9) + (#x7372 . #xB3CD) + (#x7375 . #xE0DA) + (#x7377 . #x8FCBCA) + (#x7378 . #xE0D9) + (#x7379 . #x8FCBCB) + (#x737A . #xE0DC) + (#x737B . #xE0DB) + (#x737C . #x8FCBCC) + (#x7380 . #x8FCBCD) + (#x7381 . #x8FCBCE) + (#x7383 . #x8FCBCF) + (#x7384 . #xB8BC) + (#x7385 . #x8FCBD0) + (#x7386 . #x8FCBD1) + (#x7387 . #xCEA8) + (#x7389 . #xB6CC) + (#x738B . #xB2A6) + (#x738E . #x8FCBD2) + (#x7390 . #x8FCBD3) + (#x7393 . #x8FCBD4) + (#x7395 . #x8FCBD5) + (#x7396 . #xB6EA) + (#x7397 . #x8FCBD6) + (#x7398 . #x8FCBD7) + (#x739C . #x8FCBD8) + (#x739E . #x8FCBD9) + (#x739F . #x8FCBDA) + (#x73A0 . #x8FCBDB) + (#x73A2 . #x8FCBDC) + (#x73A5 . #x8FCBDD) + (#x73A6 . #x8FCBDE) + (#x73A9 . #xB4E1) + (#x73AA . #x8FCBDF) + (#x73AB . #x8FCBE0) + (#x73AD . #x8FCBE1) + (#x73B2 . #xCEE8) + (#x73B3 . #xE0DE) + (#x73B5 . #x8FCBE2) + (#x73B7 . #x8FCBE3) + (#x73B9 . #x8FCBE4) + (#x73BB . #xE0E0) + (#x73BC . #x8FCBE5) + (#x73BD . #x8FCBE6) + (#x73BF . #x8FCBE7) + (#x73C0 . #xE0E1) + (#x73C2 . #xB2D1) + (#x73C5 . #x8FCBE8) + (#x73C6 . #x8FCBE9) + (#x73C8 . #xE0DD) + (#x73C9 . #x8FCBEA) + (#x73CA . #xBBB9) + (#x73CB . #x8FCBEB) + (#x73CC . #x8FCBEC) + (#x73CD . #xC4C1) + (#x73CE . #xE0DF) + (#x73CF . #x8FCBED) + (#x73D2 . #x8FCBEE) + (#x73D3 . #x8FCBEF) + (#x73D6 . #x8FCBF0) + (#x73D9 . #x8FCBF1) + (#x73DD . #x8FCBF2) + (#x73DE . #xE0E4) + (#x73E0 . #xBCEE) + (#x73E1 . #x8FCBF3) + (#x73E3 . #x8FCBF4) + (#x73E5 . #xE0E2) + (#x73E6 . #x8FCBF5) + (#x73E7 . #x8FCBF6) + (#x73E9 . #x8FCBF7) + (#x73EA . #xB7BE) + (#x73ED . #xC8C9) + (#x73EE . #xE0E3) + (#x73F1 . #xE0FE) + (#x73F4 . #x8FCBF8) + (#x73F5 . #x8FCBF9) + (#x73F7 . #x8FCBFA) + (#x73F8 . #xE0E9) + (#x73F9 . #x8FCBFB) + (#x73FA . #x8FCBFC) + (#x73FB . #x8FCBFD) + (#x73FD . #x8FCBFE) + (#x73FE . #xB8BD) + (#x73FF . #x8FCCA1) + (#x7400 . #x8FCCA2) + (#x7401 . #x8FCCA3) + (#x7403 . #xB5E5) + (#x7404 . #x8FCCA4) + (#x7405 . #xE0E6) + (#x7406 . #xCDFD) + (#x7407 . #x8FCCA5) + (#x7409 . #xCEB0) + (#x740A . #x8FCCA6) + (#x7411 . #x8FCCA7) + (#x741A . #x8FCCA8) + (#x741B . #x8FCCA9) + (#x7422 . #xC2F6) + (#x7424 . #x8FCCAA) + (#x7425 . #xE0E8) + (#x7426 . #x8FCCAB) + (#x7428 . #x8FCCAC) + (#x7429 . #x8FCCAD) + (#x742A . #x8FCCAE) + (#x742B . #x8FCCAF) + (#x742C . #x8FCCB0) + (#x742D . #x8FCCB1) + (#x742E . #x8FCCB2) + (#x742F . #x8FCCB3) + (#x7430 . #x8FCCB4) + (#x7431 . #x8FCCB5) + (#x7432 . #xE0EA) + (#x7433 . #xCED6) + (#x7434 . #xB6D7) + (#x7435 . #xC8FC) + (#x7436 . #xC7CA) + (#x7439 . #x8FCCB6) + (#x743A . #xE0EB) + (#x743F . #xE0ED) + (#x7440 . #x8FCCB7) + (#x7441 . #xE0F0) + (#x7443 . #x8FCCB8) + (#x7444 . #x8FCCB9) + (#x7446 . #x8FCCBA) + (#x7447 . #x8FCCBB) + (#x744B . #x8FCCBC) + (#x744D . #x8FCCBD) + (#x7451 . #x8FCCBE) + (#x7452 . #x8FCCBF) + (#x7455 . #xE0EC) + (#x7457 . #x8FCCC0) + (#x7459 . #xE0EF) + (#x745A . #xB8EA) + (#x745B . #xB1CD) + (#x745C . #xE0F1) + (#x745D . #x8FCCC1) + (#x745E . #xBFF0) + (#x745F . #xE0EE) + (#x7460 . #xCEDC) + (#x7462 . #x8FCCC2) + (#x7463 . #xE0F4) + (#x7464 . #xF4A4) + (#x7466 . #x8FCCC3) + (#x7467 . #x8FCCC4) + (#x7468 . #x8FCCC5) + (#x7469 . #xE0F2) + (#x746A . #xE0F5) + (#x746B . #x8FCCC6) + (#x746D . #x8FCCC7) + (#x746E . #x8FCCC8) + (#x746F . #xE0E7) + (#x7470 . #xE0F3) + (#x7471 . #x8FCCC9) + (#x7472 . #x8FCCCA) + (#x7473 . #xBABC) + (#x7476 . #xE0F6) + (#x747E . #xE0F7) + (#x7480 . #x8FCCCB) + (#x7481 . #x8FCCCC) + (#x7483 . #xCDFE) + (#x7485 . #x8FCCCD) + (#x7486 . #x8FCCCE) + (#x7487 . #x8FCCCF) + (#x7489 . #x8FCCD0) + (#x748B . #xE0F8) + (#x748F . #x8FCCD1) + (#x7490 . #x8FCCD2) + (#x7491 . #x8FCCD3) + (#x7492 . #x8FCCD4) + (#x7498 . #x8FCCD5) + (#x7499 . #x8FCCD6) + (#x749A . #x8FCCD7) + (#x749C . #x8FCCD8) + (#x749E . #xE0F9) + (#x749F . #x8FCCD9) + (#x74A0 . #x8FCCDA) + (#x74A1 . #x8FCCDB) + (#x74A2 . #xE0E5) + (#x74A3 . #x8FCCDC) + (#x74A6 . #x8FCCDD) + (#x74A7 . #xE0FA) + (#x74A8 . #x8FCCDE) + (#x74A9 . #x8FCCDF) + (#x74AA . #x8FCCE0) + (#x74AB . #x8FCCE1) + (#x74AE . #x8FCCE2) + (#x74AF . #x8FCCE3) + (#x74B0 . #xB4C4) + (#x74B1 . #x8FCCE4) + (#x74B2 . #x8FCCE5) + (#x74B5 . #x8FCCE6) + (#x74B9 . #x8FCCE7) + (#x74BB . #x8FCCE8) + (#x74BD . #xBCA5) + (#x74BF . #x8FCCE9) + (#x74C8 . #x8FCCEA) + (#x74C9 . #x8FCCEB) + (#x74CA . #xE0FB) + (#x74CC . #x8FCCEC) + (#x74CF . #xE0FC) + (#x74D0 . #x8FCCED) + (#x74D3 . #x8FCCEE) + (#x74D4 . #xE0FD) + (#x74D8 . #x8FCCEF) + (#x74DA . #x8FCCF0) + (#x74DB . #x8FCCF1) + (#x74DC . #xB1BB) + (#x74DE . #x8FCCF2) + (#x74DF . #x8FCCF3) + (#x74E0 . #xE1A1) + (#x74E2 . #xC9BB) + (#x74E3 . #xE1A2) + (#x74E4 . #x8FCCF4) + (#x74E6 . #xB4A4) + (#x74E7 . #xE1A3) + (#x74E8 . #x8FCCF5) + (#x74E9 . #xE1A4) + (#x74EA . #x8FCCF6) + (#x74EB . #x8FCCF7) + (#x74EE . #xE1A5) + (#x74EF . #x8FCCF8) + (#x74F0 . #xE1A7) + (#x74F1 . #xE1A8) + (#x74F2 . #xE1A6) + (#x74F4 . #x8FCCF9) + (#x74F6 . #xC9D3) + (#x74F7 . #xE1AA) + (#x74F8 . #xE1A9) + (#x74FA . #x8FCCFA) + (#x74FB . #x8FCCFB) + (#x74FC . #x8FCCFC) + (#x74FF . #x8FCCFD) + (#x7503 . #xE1AC) + (#x7504 . #xE1AB) + (#x7505 . #xE1AD) + (#x7506 . #x8FCCFE) + (#x750C . #xE1AE) + (#x750D . #xE1B0) + (#x750E . #xE1AF) + (#x7511 . #xB9F9) + (#x7512 . #x8FCDA1) + (#x7513 . #xE1B2) + (#x7515 . #xE1B1) + (#x7516 . #x8FCDA2) + (#x7517 . #x8FCDA3) + (#x7518 . #xB4C5) + (#x751A . #xBFD3) + (#x751C . #xC5BC) + (#x751E . #xE1B3) + (#x751F . #xC0B8) + (#x7520 . #x8FCDA4) + (#x7521 . #x8FCDA5) + (#x7523 . #xBBBA) + (#x7524 . #x8FCDA6) + (#x7525 . #xB1F9) + (#x7526 . #xE1B4) + (#x7527 . #x8FCDA7) + (#x7528 . #xCDD1) + (#x7529 . #x8FCDA8) + (#x752A . #x8FCDA9) + (#x752B . #xCAE3) + (#x752C . #xE1B5) + (#x752F . #x8FCDAA) + (#x7530 . #xC5C4) + (#x7531 . #xCDB3) + (#x7532 . #xB9C3) + (#x7533 . #xBFBD) + (#x7536 . #x8FCDAB) + (#x7537 . #xC3CB) + (#x7538 . #xD2B4) + (#x7539 . #x8FCDAC) + (#x753A . #xC4AE) + (#x753B . #xB2E8) + (#x753C . #xE1B6) + (#x753D . #x8FCDAD) + (#x753E . #x8FCDAE) + (#x753F . #x8FCDAF) + (#x7540 . #x8FCDB0) + (#x7543 . #x8FCDB1) + (#x7544 . #xE1B7) + (#x7546 . #xE1BC) + (#x7547 . #x8FCDB2) + (#x7548 . #x8FCDB3) + (#x7549 . #xE1BA) + (#x754A . #xE1B9) + (#x754B . #xDAC2) + (#x754C . #xB3A6) + (#x754D . #xE1B8) + (#x754E . #x8FCDB4) + (#x754F . #xB0DA) + (#x7550 . #x8FCDB5) + (#x7551 . #xC8AA) + (#x7552 . #x8FCDB6) + (#x7554 . #xC8CA) + (#x7557 . #x8FCDB7) + (#x7559 . #xCEB1) + (#x755A . #xE1BD) + (#x755B . #xE1BB) + (#x755C . #xC3DC) + (#x755D . #xC0A6) + (#x755E . #x8FCDB8) + (#x755F . #x8FCDB9) + (#x7560 . #xC8AB) + (#x7561 . #x8FCDBA) + (#x7562 . #xC9AD) + (#x7564 . #xE1BF) + (#x7565 . #xCEAC) + (#x7566 . #xB7CD) + (#x7567 . #xE1C0) + (#x7569 . #xE1BE) + (#x756A . #xC8D6) + (#x756B . #xE1C1) + (#x756D . #xE1C2) + (#x756F . #x8FCDBB) + (#x7570 . #xB0DB) + (#x7571 . #x8FCDBC) + (#x7573 . #xBEF6) + (#x7574 . #xE1C7) + (#x7576 . #xE1C4) + (#x7577 . #xC6ED) + (#x7578 . #xE1C3) + (#x7579 . #x8FCDBD) + (#x757A . #x8FCDBE) + (#x757B . #x8FCDBF) + (#x757C . #x8FCDC0) + (#x757D . #x8FCDC1) + (#x757E . #x8FCDC2) + (#x757F . #xB5A6) + (#x7581 . #x8FCDC3) + (#x7582 . #xE1CA) + (#x7585 . #x8FCDC4) + (#x7586 . #xE1C5) + (#x7587 . #xE1C6) + (#x7589 . #xE1C9) + (#x758A . #xE1C8) + (#x758B . #xC9A5) + (#x758E . #xC1C2) + (#x758F . #xC1C1) + (#x7590 . #x8FCDC5) + (#x7591 . #xB5BF) + (#x7592 . #x8FCDC6) + (#x7593 . #x8FCDC7) + (#x7594 . #xE1CB) + (#x7595 . #x8FCDC8) + (#x7599 . #x8FCDC9) + (#x759A . #xE1CC) + (#x759C . #x8FCDCA) + (#x759D . #xE1CD) + (#x75A2 . #x8FCDCB) + (#x75A3 . #xE1CF) + (#x75A4 . #x8FCDCC) + (#x75A5 . #xE1CE) + (#x75AB . #xB1D6) + (#x75B1 . #xE1D7) + (#x75B2 . #xC8E8) + (#x75B3 . #xE1D1) + (#x75B4 . #x8FCDCD) + (#x75B5 . #xE1D3) + (#x75B8 . #xE1D5) + (#x75B9 . #xBFBE) + (#x75BA . #x8FCDCE) + (#x75BC . #xE1D6) + (#x75BD . #xE1D4) + (#x75BE . #xBCC0) + (#x75BF . #x8FCDCF) + (#x75C0 . #x8FCDD0) + (#x75C1 . #x8FCDD1) + (#x75C2 . #xE1D0) + (#x75C3 . #xE1D2) + (#x75C4 . #x8FCDD2) + (#x75C5 . #xC9C2) + (#x75C6 . #x8FCDD3) + (#x75C7 . #xBEC9) + (#x75CA . #xE1D9) + (#x75CC . #x8FCDD4) + (#x75CD . #xE1D8) + (#x75CE . #x8FCDD5) + (#x75CF . #x8FCDD6) + (#x75D2 . #xE1DA) + (#x75D4 . #xBCA6) + (#x75D5 . #xBAAF) + (#x75D7 . #x8FCDD7) + (#x75D8 . #xC5F7) + (#x75D9 . #xE1DB) + (#x75DB . #xC4CB) + (#x75DC . #x8FCDD8) + (#x75DE . #xE1DD) + (#x75DF . #x8FCDD9) + (#x75E0 . #x8FCDDA) + (#x75E1 . #x8FCDDB) + (#x75E2 . #xCEA1) + (#x75E3 . #xE1DC) + (#x75E4 . #x8FCDDC) + (#x75E7 . #x8FCDDD) + (#x75E9 . #xC1E9) + (#x75EC . #x8FCDDE) + (#x75EE . #x8FCDDF) + (#x75EF . #x8FCDE0) + (#x75F0 . #xE1E2) + (#x75F1 . #x8FCDE1) + (#x75F2 . #xE1E4) + (#x75F3 . #xE1E5) + (#x75F4 . #xC3D4) + (#x75F9 . #x8FCDE2) + (#x75FA . #xE1E3) + (#x75FC . #xE1E0) + (#x75FE . #xE1DE) + (#x75FF . #xE1DF) + (#x7600 . #x8FCDE3) + (#x7601 . #xE1E1) + (#x7602 . #x8FCDE4) + (#x7603 . #x8FCDE5) + (#x7604 . #x8FCDE6) + (#x7607 . #x8FCDE7) + (#x7608 . #x8FCDE8) + (#x7609 . #xE1E8) + (#x760A . #x8FCDE9) + (#x760B . #xE1E6) + (#x760C . #x8FCDEA) + (#x760D . #xE1E7) + (#x760F . #x8FCDEB) + (#x7612 . #x8FCDEC) + (#x7613 . #x8FCDED) + (#x7615 . #x8FCDEE) + (#x7616 . #x8FCDEF) + (#x7619 . #x8FCDF0) + (#x761B . #x8FCDF1) + (#x761C . #x8FCDF2) + (#x761D . #x8FCDF3) + (#x761E . #x8FCDF4) + (#x761F . #xE1E9) + (#x7620 . #xE1EB) + (#x7621 . #xE1EC) + (#x7622 . #xE1ED) + (#x7623 . #x8FCDF5) + (#x7624 . #xE1EE) + (#x7625 . #x8FCDF6) + (#x7626 . #x8FCDF7) + (#x7627 . #xE1EA) + (#x7629 . #x8FCDF8) + (#x762D . #x8FCDF9) + (#x7630 . #xE1F0) + (#x7632 . #x8FCDFA) + (#x7633 . #x8FCDFB) + (#x7634 . #xE1EF) + (#x7635 . #x8FCDFC) + (#x7638 . #x8FCDFD) + (#x7639 . #x8FCDFE) + (#x763A . #x8FCEA1) + (#x763B . #xE1F1) + (#x763C . #x8FCEA2) + (#x7640 . #x8FCEA4) + (#x7641 . #x8FCEA5) + (#x7642 . #xCEC5) + (#x7643 . #x8FCEA6) + (#x7644 . #x8FCEA7) + (#x7645 . #x8FCEA8) + (#x7646 . #xE1F4) + (#x7647 . #xE1F2) + (#x7648 . #xE1F3) + (#x7649 . #x8FCEA9) + (#x764A . #x8FCEA3) + (#x764B . #x8FCEAA) + (#x764C . #xB4E2) + (#x7652 . #xCCFE) + (#x7655 . #x8FCEAB) + (#x7656 . #xCACA) + (#x7658 . #xE1F6) + (#x7659 . #x8FCEAC) + (#x765C . #xE1F5) + (#x765F . #x8FCEAD) + (#x7661 . #xE1F7) + (#x7662 . #xE1F8) + (#x7664 . #x8FCEAE) + (#x7665 . #x8FCEAF) + (#x7667 . #xE1FC) + (#x7668 . #xE1F9) + (#x7669 . #xE1FA) + (#x766A . #xE1FB) + (#x766C . #xE1FD) + (#x766D . #x8FCEB0) + (#x766E . #x8FCEB1) + (#x766F . #x8FCEB2) + (#x7670 . #xE1FE) + (#x7671 . #x8FCEB3) + (#x7672 . #xE2A1) + (#x7674 . #x8FCEB4) + (#x7676 . #xE2A2) + (#x7678 . #xE2A3) + (#x767A . #xC8AF) + (#x767B . #xC5D0) + (#x767C . #xE2A4) + (#x767D . #xC7F2) + (#x767E . #xC9B4) + (#x7680 . #xE2A5) + (#x7681 . #x8FCEB5) + (#x7683 . #xE2A6) + (#x7684 . #xC5AA) + (#x7685 . #x8FCEB6) + (#x7686 . #xB3A7) + (#x7687 . #xB9C4) + (#x7688 . #xE2A7) + (#x768B . #xE2A8) + (#x768C . #x8FCEB7) + (#x768D . #x8FCEB8) + (#x768E . #xE2A9) + (#x7690 . #xBBA9) + (#x7693 . #xE2AB) + (#x7695 . #x8FCEB9) + (#x7696 . #xE2AA) + (#x7699 . #xE2AC) + (#x769A . #xE2AD) + (#x769B . #x8FCEBA) + (#x769C . #x8FCEBB) + (#x769D . #x8FCEBC) + (#x769F . #x8FCEBD) + (#x76A0 . #x8FCEBE) + (#x76A2 . #x8FCEBF) + (#x76A3 . #x8FCEC0) + (#x76A4 . #x8FCEC1) + (#x76A5 . #x8FCEC2) + (#x76A6 . #x8FCEC3) + (#x76A7 . #x8FCEC4) + (#x76A8 . #x8FCEC5) + (#x76AA . #x8FCEC6) + (#x76AD . #x8FCEC7) + (#x76AE . #xC8E9) + (#x76B0 . #xE2AE) + (#x76B4 . #xE2AF) + (#x76B7 . #xF3E9) + (#x76B8 . #xE2B0) + (#x76B9 . #xE2B1) + (#x76BA . #xE2B2) + (#x76BD . #x8FCEC8) + (#x76BF . #xBBAE) + (#x76C1 . #x8FCEC9) + (#x76C2 . #xE2B3) + (#x76C3 . #xC7D6) + (#x76C5 . #x8FCECA) + (#x76C6 . #xCBDF) + (#x76C8 . #xB1CE) + (#x76C9 . #x8FCECB) + (#x76CA . #xB1D7) + (#x76CB . #x8FCECC) + (#x76CC . #x8FCECD) + (#x76CD . #xE2B4) + (#x76CE . #x8FCECE) + (#x76D2 . #xE2B6) + (#x76D4 . #x8FCECF) + (#x76D6 . #xE2B5) + (#x76D7 . #xC5F0) + (#x76D9 . #x8FCED0) + (#x76DB . #xC0B9) + (#x76DC . #xDDB9) + (#x76DE . #xE2B7) + (#x76DF . #xCCC1) + (#x76E0 . #x8FCED1) + (#x76E1 . #xE2B8) + (#x76E3 . #xB4C6) + (#x76E4 . #xC8D7) + (#x76E5 . #xE2B9) + (#x76E6 . #x8FCED2) + (#x76E7 . #xE2BA) + (#x76E8 . #x8FCED3) + (#x76EA . #xE2BB) + (#x76EC . #x8FCED4) + (#x76EE . #xCCDC) + (#x76F0 . #x8FCED5) + (#x76F1 . #x8FCED6) + (#x76F2 . #xCCD5) + (#x76F4 . #xC4BE) + (#x76F6 . #x8FCED7) + (#x76F8 . #xC1EA) + (#x76F9 . #x8FCED8) + (#x76FB . #xE2BD) + (#x76FC . #x8FCED9) + (#x76FE . #xBDE2) + (#x7700 . #x8FCEDA) + (#x7701 . #xBECA) + (#x7704 . #xE2C0) + (#x7706 . #x8FCEDB) + (#x7707 . #xE2BF) + (#x7708 . #xE2BE) + (#x7709 . #xC8FD) + (#x770A . #x8FCEDC) + (#x770B . #xB4C7) + (#x770C . #xB8A9) + (#x770E . #x8FCEDD) + (#x7712 . #x8FCEDE) + (#x7714 . #x8FCEDF) + (#x7715 . #x8FCEE0) + (#x7717 . #x8FCEE1) + (#x7719 . #x8FCEE2) + (#x771A . #x8FCEE3) + (#x771B . #xE2C6) + (#x771C . #x8FCEE4) + (#x771E . #xE2C3) + (#x771F . #xBFBF) + (#x7720 . #xCCB2) + (#x7722 . #x8FCEE5) + (#x7724 . #xE2C2) + (#x7725 . #xE2C4) + (#x7726 . #xE2C5) + (#x7728 . #x8FCEE6) + (#x7729 . #xE2C1) + (#x772D . #x8FCEE7) + (#x772E . #x8FCEE8) + (#x772F . #x8FCEE9) + (#x7734 . #x8FCEEA) + (#x7735 . #x8FCEEB) + (#x7736 . #x8FCEEC) + (#x7737 . #xE2C7) + (#x7738 . #xE2C8) + (#x7739 . #x8FCEED) + (#x773A . #xC4AF) + (#x773C . #xB4E3) + (#x773D . #x8FCEEE) + (#x773E . #x8FCEEF) + (#x7740 . #xC3E5) + (#x7742 . #x8FCEF0) + (#x7745 . #x8FCEF1) + (#x7746 . #x8FCEF2) + (#x7747 . #xE2C9) + (#x774A . #x8FCEF3) + (#x774D . #x8FCEF4) + (#x774E . #x8FCEF5) + (#x774F . #x8FCEF6) + (#x7752 . #x8FCEF7) + (#x7756 . #x8FCEF8) + (#x7757 . #x8FCEF9) + (#x775A . #xE2CA) + (#x775B . #xE2CD) + (#x775C . #x8FCEFA) + (#x775E . #x8FCEFB) + (#x775F . #x8FCEFC) + (#x7760 . #x8FCEFD) + (#x7761 . #xBFE7) + (#x7762 . #x8FCEFE) + (#x7763 . #xC6C4) + (#x7764 . #x8FCFA1) + (#x7765 . #xE2CE) + (#x7766 . #xCBD3) + (#x7767 . #x8FCFA2) + (#x7768 . #xE2CB) + (#x776A . #x8FCFA3) + (#x776B . #xE2CC) + (#x776C . #x8FCFA4) + (#x7770 . #x8FCFA5) + (#x7772 . #x8FCFA6) + (#x7773 . #x8FCFA7) + (#x7774 . #x8FCFA8) + (#x7779 . #xE2D1) + (#x777A . #x8FCFA9) + (#x777D . #x8FCFAA) + (#x777E . #xE2D0) + (#x777F . #xE2CF) + (#x7780 . #x8FCFAB) + (#x7784 . #x8FCFAC) + (#x778B . #xE2D3) + (#x778C . #x8FCFAD) + (#x778D . #x8FCFAE) + (#x778E . #xE2D2) + (#x7791 . #xE2D4) + (#x7794 . #x8FCFAF) + (#x7795 . #x8FCFB0) + (#x7796 . #x8FCFB1) + (#x779A . #x8FCFB2) + (#x779E . #xE2D6) + (#x779F . #x8FCFB3) + (#x77A0 . #xE2D5) + (#x77A2 . #x8FCFB4) + (#x77A5 . #xCACD) + (#x77A7 . #x8FCFB5) + (#x77AA . #x8FCFB6) + (#x77AC . #xBDD6) + (#x77AD . #xCEC6) + (#x77AE . #x8FCFB7) + (#x77AF . #x8FCFB8) + (#x77B0 . #xE2D7) + (#x77B1 . #x8FCFB9) + (#x77B3 . #xC6B7) + (#x77B5 . #x8FCFBA) + (#x77B6 . #xE2D8) + (#x77B9 . #xE2D9) + (#x77BB . #xE2DD) + (#x77BC . #xE2DB) + (#x77BD . #xE2DC) + (#x77BE . #x8FCFBB) + (#x77BF . #xE2DA) + (#x77C3 . #x8FCFBC) + (#x77C7 . #xE2DE) + (#x77C9 . #x8FCFBD) + (#x77CD . #xE2DF) + (#x77D1 . #x8FCFBE) + (#x77D2 . #x8FCFBF) + (#x77D5 . #x8FCFC0) + (#x77D7 . #xE2E0) + (#x77D9 . #x8FCFC1) + (#x77DA . #xE2E1) + (#x77DB . #xCCB7) + (#x77DC . #xE2E2) + (#x77DE . #x8FCFC2) + (#x77DF . #x8FCFC3) + (#x77E0 . #x8FCFC4) + (#x77E2 . #xCCF0) + (#x77E3 . #xE2E3) + (#x77E4 . #x8FCFC5) + (#x77E5 . #xC3CE) + (#x77E6 . #x8FCFC6) + (#x77E7 . #xC7EA) + (#x77E9 . #xB6EB) + (#x77EA . #x8FCFC7) + (#x77EC . #x8FCFC8) + (#x77ED . #xC3BB) + (#x77EE . #xE2E4) + (#x77EF . #xB6BA) + (#x77F0 . #x8FCFC9) + (#x77F1 . #x8FCFCA) + (#x77F3 . #xC0D0) + (#x77F4 . #x8FCFCB) + (#x77F8 . #x8FCFCC) + (#x77FB . #x8FCFCD) + (#x77FC . #xE2E5) + (#x7802 . #xBABD) + (#x7805 . #x8FCFCE) + (#x7806 . #x8FCFCF) + (#x7809 . #x8FCFD0) + (#x780C . #xE2E6) + (#x780D . #x8FCFD1) + (#x780E . #x8FCFD2) + (#x7811 . #x8FCFD3) + (#x7812 . #xE2E7) + (#x7814 . #xB8A6) + (#x7815 . #xBAD5) + (#x781D . #x8FCFD4) + (#x7820 . #xE2E9) + (#x7821 . #x8FCFD5) + (#x7822 . #x8FCFD6) + (#x7823 . #x8FCFD7) + (#x7825 . #xC5D6) + (#x7826 . #xBAD6) + (#x7827 . #xB5CE) + (#x782D . #x8FCFD8) + (#x782E . #x8FCFD9) + (#x7830 . #x8FCFDA) + (#x7832 . #xCBA4) + (#x7834 . #xC7CB) + (#x7835 . #x8FCFDB) + (#x7837 . #x8FCFDC) + (#x783A . #xC5D7) + (#x783F . #xB9DC) + (#x7843 . #x8FCFDD) + (#x7844 . #x8FCFDE) + (#x7845 . #xE2EB) + (#x7847 . #x8FCFDF) + (#x7848 . #x8FCFE0) + (#x784C . #x8FCFE1) + (#x784E . #x8FCFE2) + (#x7852 . #x8FCFE3) + (#x785C . #x8FCFE4) + (#x785D . #xBECB) + (#x785E . #x8FCFE5) + (#x7860 . #x8FCFE6) + (#x7861 . #x8FCFE7) + (#x7863 . #x8FCFE8) + (#x7864 . #x8FCFE9) + (#x7868 . #x8FCFEA) + (#x786A . #x8FCFEB) + (#x786B . #xCEB2) + (#x786C . #xB9C5) + (#x786E . #x8FCFEC) + (#x786F . #xB8A7) + (#x7872 . #xC8A3) + (#x7874 . #xE2ED) + (#x787A . #x8FCFED) + (#x787C . #xE2EF) + (#x787E . #x8FCFEE) + (#x7881 . #xB8EB) + (#x7886 . #xE2EE) + (#x7887 . #xC4F6) + (#x788A . #x8FCFEF) + (#x788C . #xE2F1) + (#x788D . #xB3B7) + (#x788E . #xE2EC) + (#x788F . #x8FCFF0) + (#x7891 . #xC8EA) + (#x7893 . #xB1B0) + (#x7894 . #x8FCFF1) + (#x7895 . #xBAEC) + (#x7897 . #xCFD2) + (#x7898 . #x8FCFF2) + (#x789A . #xE2F0) + (#x789D . #x8FCFF4) + (#x789E . #x8FCFF5) + (#x789F . #x8FCFF6) + (#x78A1 . #x8FCFF3) + (#x78A3 . #xE2F2) + (#x78A4 . #x8FCFF7) + (#x78A7 . #xCACB) + (#x78A8 . #x8FCFF8) + (#x78A9 . #xC0D9) + (#x78AA . #xE2F4) + (#x78AC . #x8FCFF9) + (#x78AD . #x8FCFFA) + (#x78AF . #xE2F5) + (#x78B0 . #x8FCFFB) + (#x78B1 . #x8FCFFC) + (#x78B2 . #x8FCFFD) + (#x78B3 . #x8FCFFE) + (#x78B5 . #xE2F3) + (#x78BA . #xB3CE) + (#x78BB . #x8FD0A1) + (#x78BC . #xE2FB) + (#x78BD . #x8FD0A2) + (#x78BE . #xE2FA) + (#x78BF . #x8FD0A3) + (#x78C1 . #xBCA7) + (#x78C5 . #xE2FC) + (#x78C6 . #xE2F7) + (#x78C7 . #x8FD0A4) + (#x78C8 . #x8FD0A5) + (#x78C9 . #x8FD0A6) + (#x78CA . #xE2FD) + (#x78CB . #xE2F8) + (#x78CC . #x8FD0A7) + (#x78CE . #x8FD0A8) + (#x78D0 . #xC8D8) + (#x78D1 . #xE2F6) + (#x78D2 . #x8FD0A9) + (#x78D3 . #x8FD0AA) + (#x78D4 . #xE2F9) + (#x78D5 . #x8FD0AB) + (#x78D6 . #x8FD0AC) + (#x78DA . #xE3A2) + (#x78DB . #x8FD0AE) + (#x78DF . #x8FD0AF) + (#x78E0 . #x8FD0B0) + (#x78E1 . #x8FD0B1) + (#x78E4 . #x8FD0AD) + (#x78E6 . #x8FD0B2) + (#x78E7 . #xE3A1) + (#x78E8 . #xCBE1) + (#x78EA . #x8FD0B3) + (#x78EC . #xE2FE) + (#x78EF . #xB0EB) + (#x78F2 . #x8FD0B4) + (#x78F3 . #x8FD0B5) + (#x78F4 . #xE3A4) + (#x78F6 . #x8FD0B7) + (#x78F7 . #x8FD0B8) + (#x78FA . #x8FD0B9) + (#x78FB . #x8FD0BA) + (#x78FD . #xE3A3) + (#x78FF . #x8FD0BB) + (#x7900 . #x8FD0B6) + (#x7901 . #xBECC) + (#x7906 . #x8FD0BC) + (#x7907 . #xE3A5) + (#x790C . #x8FD0BD) + (#x790E . #xC1C3) + (#x7910 . #x8FD0BE) + (#x7911 . #xE3A7) + (#x7912 . #xE3A6) + (#x7919 . #xE3A8) + (#x791A . #x8FD0BF) + (#x791C . #x8FD0C0) + (#x791E . #x8FD0C1) + (#x791F . #x8FD0C2) + (#x7920 . #x8FD0C3) + (#x7925 . #x8FD0C4) + (#x7926 . #xE2E8) + (#x7927 . #x8FD0C5) + (#x7929 . #x8FD0C6) + (#x792A . #xE2EA) + (#x792B . #xE3AA) + (#x792C . #xE3A9) + (#x792D . #x8FD0C7) + (#x7931 . #x8FD0C8) + (#x7934 . #x8FD0C9) + (#x7935 . #x8FD0CA) + (#x793A . #xBCA8) + (#x793B . #x8FD0CB) + (#x793C . #xCEE9) + (#x793D . #x8FD0CC) + (#x793E . #xBCD2) + (#x793F . #x8FD0CD) + (#x7940 . #xE3AB) + (#x7941 . #xB7B7) + (#x7944 . #x8FD0CE) + (#x7945 . #x8FD0CF) + (#x7946 . #x8FD0D0) + (#x7947 . #xB5C0) + (#x7948 . #xB5A7) + (#x7949 . #xBBE3) + (#x794A . #x8FD0D1) + (#x794B . #x8FD0D2) + (#x794F . #x8FD0D3) + (#x7950 . #xCDB4) + (#x7951 . #x8FD0D4) + (#x7953 . #xE3B1) + (#x7954 . #x8FD0D5) + (#x7955 . #xE3B0) + (#x7956 . #xC1C4) + (#x7957 . #xE3AD) + (#x7958 . #x8FD0D6) + (#x795A . #xE3AF) + (#x795B . #x8FD0D7) + (#x795C . #x8FD0D8) + (#x795D . #xBDCB) + (#x795E . #xBFC0) + (#x795F . #xE3AE) + (#x7960 . #xE3AC) + (#x7962 . #xC7AA) + (#x7965 . #xBECD) + (#x7967 . #x8FD0D9) + (#x7968 . #xC9BC) + (#x7969 . #x8FD0DA) + (#x796B . #x8FD0DB) + (#x796D . #xBAD7) + (#x7972 . #x8FD0DC) + (#x7977 . #xC5F8) + (#x7979 . #x8FD0DD) + (#x797A . #xE3B2) + (#x797B . #x8FD0DE) + (#x797C . #x8FD0DF) + (#x797E . #x8FD0E0) + (#x797F . #xE3B3) + (#x7980 . #xE3C9) + (#x7981 . #xB6D8) + (#x7984 . #xCFBD) + (#x7985 . #xC1B5) + (#x798A . #xE3B4) + (#x798B . #x8FD0E1) + (#x798C . #x8FD0E2) + (#x798D . #xB2D2) + (#x798E . #xC4F7) + (#x798F . #xCAA1) + (#x7991 . #x8FD0E3) + (#x7993 . #x8FD0E4) + (#x7994 . #x8FD0E5) + (#x7995 . #x8FD0E6) + (#x7996 . #x8FD0E7) + (#x7998 . #x8FD0E8) + (#x799B . #x8FD0E9) + (#x799C . #x8FD0EA) + (#x799D . #xE3B5) + (#x79A1 . #x8FD0EB) + (#x79A6 . #xB5FA) + (#x79A7 . #xE3B6) + (#x79A8 . #x8FD0EC) + (#x79A9 . #x8FD0ED) + (#x79AA . #xE3B8) + (#x79AB . #x8FD0EE) + (#x79AE . #xE3B9) + (#x79AF . #x8FD0EF) + (#x79B0 . #xC7A9) + (#x79B1 . #x8FD0F0) + (#x79B3 . #xE3BA) + (#x79B4 . #x8FD0F1) + (#x79B8 . #x8FD0F2) + (#x79B9 . #xE3BB) + (#x79BA . #xE3BC) + (#x79BB . #x8FD0F3) + (#x79BD . #xB6D9) + (#x79BE . #xB2D3) + (#x79BF . #xC6C5) + (#x79C0 . #xBDA8) + (#x79C1 . #xBBE4) + (#x79C2 . #x8FD0F4) + (#x79C4 . #x8FD0F5) + (#x79C7 . #x8FD0F6) + (#x79C8 . #x8FD0F7) + (#x79C9 . #xE3BD) + (#x79CA . #x8FD0F8) + (#x79CB . #xBDA9) + (#x79CF . #x8FD0F9) + (#x79D1 . #xB2CA) + (#x79D2 . #xC9C3) + (#x79D4 . #x8FD0FA) + (#x79D5 . #xE3BE) + (#x79D6 . #x8FD0FB) + (#x79D8 . #xC8EB) + (#x79DA . #x8FD0FC) + (#x79DD . #x8FD0FD) + (#x79DE . #x8FD0FE) + (#x79DF . #xC1C5) + (#x79E0 . #x8FD1A1) + (#x79E1 . #xE3C1) + (#x79E2 . #x8FD1A2) + (#x79E3 . #xE3C2) + (#x79E4 . #xC7E9) + (#x79E5 . #x8FD1A3) + (#x79E6 . #xBFC1) + (#x79E7 . #xE3BF) + (#x79E9 . #xC3E1) + (#x79EA . #x8FD1A4) + (#x79EB . #x8FD1A5) + (#x79EC . #xE3C0) + (#x79ED . #x8FD1A6) + (#x79F0 . #xBECE) + (#x79F1 . #x8FD1A7) + (#x79F8 . #x8FD1A8) + (#x79FB . #xB0DC) + (#x79FC . #x8FD1A9) + (#x7A00 . #xB5A9) + (#x7A02 . #x8FD1AA) + (#x7A03 . #x8FD1AB) + (#x7A07 . #x8FD1AC) + (#x7A08 . #xE3C3) + (#x7A09 . #x8FD1AD) + (#x7A0A . #x8FD1AE) + (#x7A0B . #xC4F8) + (#x7A0C . #x8FD1AF) + (#x7A0D . #xE3C4) + (#x7A0E . #xC0C7) + (#x7A11 . #x8FD1B0) + (#x7A14 . #xCCAD) + (#x7A15 . #x8FD1B1) + (#x7A17 . #xC9A3) + (#x7A18 . #xE3C5) + (#x7A19 . #xE3C6) + (#x7A1A . #xC3D5) + (#x7A1B . #x8FD1B2) + (#x7A1C . #xCEC7) + (#x7A1E . #x8FD1B3) + (#x7A1F . #xE3C8) + (#x7A20 . #xE3C7) + (#x7A21 . #x8FD1B4) + (#x7A27 . #x8FD1B5) + (#x7A2B . #x8FD1B6) + (#x7A2D . #x8FD1B7) + (#x7A2E . #xBCEF) + (#x7A2F . #x8FD1B8) + (#x7A30 . #x8FD1B9) + (#x7A31 . #xE3CA) + (#x7A32 . #xB0F0) + (#x7A34 . #x8FD1BA) + (#x7A35 . #x8FD1BB) + (#x7A37 . #xE3CD) + (#x7A38 . #x8FD1BC) + (#x7A39 . #x8FD1BD) + (#x7A3A . #x8FD1BE) + (#x7A3B . #xE3CB) + (#x7A3C . #xB2D4) + (#x7A3D . #xB7CE) + (#x7A3E . #xE3CC) + (#x7A3F . #xB9C6) + (#x7A40 . #xB9F2) + (#x7A42 . #xCAE6) + (#x7A43 . #xE3CE) + (#x7A44 . #x8FD1BF) + (#x7A45 . #x8FD1C0) + (#x7A46 . #xCBD4) + (#x7A47 . #x8FD1C1) + (#x7A48 . #x8FD1C2) + (#x7A49 . #xE3D0) + (#x7A4C . #x8FD1C3) + (#x7A4D . #xC0D1) + (#x7A4E . #xB1CF) + (#x7A4F . #xB2BA) + (#x7A50 . #xB0AC) + (#x7A55 . #x8FD1C4) + (#x7A56 . #x8FD1C5) + (#x7A57 . #xE3CF) + (#x7A59 . #x8FD1C6) + (#x7A5C . #x8FD1C7) + (#x7A5D . #x8FD1C8) + (#x7A5F . #x8FD1C9) + (#x7A60 . #x8FD1CA) + (#x7A61 . #xE3D1) + (#x7A62 . #xE3D2) + (#x7A63 . #xBEF7) + (#x7A65 . #x8FD1CB) + (#x7A67 . #x8FD1CC) + (#x7A69 . #xE3D3) + (#x7A6A . #x8FD1CD) + (#x7A6B . #xB3CF) + (#x7A6D . #x8FD1CE) + (#x7A70 . #xE3D5) + (#x7A74 . #xB7EA) + (#x7A75 . #x8FD1CF) + (#x7A76 . #xB5E6) + (#x7A78 . #x8FD1D0) + (#x7A79 . #xE3D6) + (#x7A7A . #xB6F5) + (#x7A7D . #xE3D7) + (#x7A7E . #x8FD1D1) + (#x7A7F . #xC0FC) + (#x7A80 . #x8FD1D2) + (#x7A81 . #xC6CD) + (#x7A82 . #x8FD1D3) + (#x7A83 . #xC0E0) + (#x7A84 . #xBAF5) + (#x7A85 . #x8FD1D4) + (#x7A86 . #x8FD1D5) + (#x7A88 . #xE3D8) + (#x7A8A . #x8FD1D6) + (#x7A8B . #x8FD1D7) + (#x7A90 . #x8FD1D8) + (#x7A91 . #x8FD1D9) + (#x7A92 . #xC3E2) + (#x7A93 . #xC1EB) + (#x7A94 . #x8FD1DA) + (#x7A95 . #xE3DA) + (#x7A96 . #xE3DC) + (#x7A97 . #xE3D9) + (#x7A98 . #xE3DB) + (#x7A9E . #x8FD1DB) + (#x7A9F . #xB7A2) + (#x7AA0 . #x8FD1DC) + (#x7AA3 . #x8FD1DD) + (#x7AA9 . #xE3DD) + (#x7AAA . #xB7A6) + (#x7AAC . #x8FD1DE) + (#x7AAE . #xB5E7) + (#x7AAF . #xCDD2) + (#x7AB0 . #xE3DF) + (#x7AB3 . #x8FD1DF) + (#x7AB5 . #x8FD1E0) + (#x7AB6 . #xE3E0) + (#x7AB9 . #x8FD1E1) + (#x7ABA . #xB1AE) + (#x7ABB . #x8FD1E2) + (#x7ABC . #x8FD1E3) + (#x7ABF . #xE3E3) + (#x7AC3 . #xB3F6) + (#x7AC4 . #xE3E2) + (#x7AC5 . #xE3E1) + (#x7AC6 . #x8FD1E4) + (#x7AC7 . #xE3E5) + (#x7AC8 . #xE3DE) + (#x7AC9 . #x8FD1E5) + (#x7ACA . #xE3E6) + (#x7ACB . #xCEA9) + (#x7ACC . #x8FD1E6) + (#x7ACD . #xE3E7) + (#x7ACE . #x8FD1E7) + (#x7ACF . #xE3E8) + (#x7AD1 . #x8FD1E8) + (#x7AD2 . #xD4F4) + (#x7AD3 . #xE3EA) + (#x7AD5 . #xE3E9) + (#x7AD9 . #xE3EB) + (#x7ADA . #xE3EC) + (#x7ADB . #x8FD1E9) + (#x7ADC . #xCEB5) + (#x7ADD . #xE3ED) + (#x7ADF . #xF0EF) + (#x7AE0 . #xBECF) + (#x7AE1 . #xE3EE) + (#x7AE2 . #xE3EF) + (#x7AE3 . #xBDD7) + (#x7AE5 . #xC6B8) + (#x7AE6 . #xE3F0) + (#x7AE8 . #x8FD1EA) + (#x7AE9 . #x8FD1EB) + (#x7AEA . #xC3A8) + (#x7AEB . #x8FD1EC) + (#x7AEC . #x8FD1ED) + (#x7AED . #xE3F1) + (#x7AEF . #xC3BC) + (#x7AF0 . #xE3F2) + (#x7AF1 . #x8FD1EE) + (#x7AF4 . #x8FD1EF) + (#x7AF6 . #xB6A5) + (#x7AF8 . #xD1BF) + (#x7AF9 . #xC3DD) + (#x7AFA . #xBCB3) + (#x7AFB . #x8FD1F0) + (#x7AFD . #x8FD1F1) + (#x7AFE . #x8FD1F2) + (#x7AFF . #xB4C8) + (#x7B02 . #xE3F3) + (#x7B04 . #xE4A2) + (#x7B06 . #xE3F6) + (#x7B07 . #x8FD1F3) + (#x7B08 . #xB5E8) + (#x7B0A . #xE3F5) + (#x7B0B . #xE4A4) + (#x7B0F . #xE3F4) + (#x7B11 . #xBED0) + (#x7B14 . #x8FD1F4) + (#x7B18 . #xE3F8) + (#x7B19 . #xE3F9) + (#x7B1B . #xC5AB) + (#x7B1E . #xE3FA) + (#x7B1F . #x8FD1F5) + (#x7B20 . #xB3DE) + (#x7B23 . #x8FD1F6) + (#x7B25 . #xBFDA) + (#x7B26 . #xC9E4) + (#x7B27 . #x8FD1F7) + (#x7B28 . #xE3FC) + (#x7B29 . #x8FD1F8) + (#x7B2A . #x8FD1F9) + (#x7B2B . #x8FD1FA) + (#x7B2C . #xC2E8) + (#x7B2D . #x8FD1FB) + (#x7B2E . #x8FD1FC) + (#x7B2F . #x8FD1FD) + (#x7B30 . #x8FD1FE) + (#x7B31 . #x8FD2A1) + (#x7B33 . #xE3F7) + (#x7B34 . #x8FD2A2) + (#x7B35 . #xE3FB) + (#x7B36 . #xE3FD) + (#x7B39 . #xBAFB) + (#x7B3D . #x8FD2A3) + (#x7B3F . #x8FD2A4) + (#x7B40 . #x8FD2A5) + (#x7B41 . #x8FD2A6) + (#x7B45 . #xE4A6) + (#x7B46 . #xC9AE) + (#x7B47 . #x8FD2A7) + (#x7B48 . #xC8A6) + (#x7B49 . #xC5F9) + (#x7B4B . #xB6DA) + (#x7B4C . #xE4A5) + (#x7B4D . #xE4A3) + (#x7B4E . #x8FD2A8) + (#x7B4F . #xC8B5) + (#x7B50 . #xE3FE) + (#x7B51 . #xC3DE) + (#x7B52 . #xC5FB) + (#x7B54 . #xC5FA) + (#x7B55 . #x8FD2A9) + (#x7B56 . #xBAF6) + (#x7B5D . #xE4B8) + (#x7B60 . #x8FD2AA) + (#x7B64 . #x8FD2AB) + (#x7B65 . #xE4A8) + (#x7B66 . #x8FD2AC) + (#x7B67 . #xE4AA) + (#x7B69 . #x8FD2AD) + (#x7B6A . #x8FD2AE) + (#x7B6C . #xE4AD) + (#x7B6D . #x8FD2AF) + (#x7B6E . #xE4AE) + (#x7B6F . #x8FD2B0) + (#x7B70 . #xE4AB) + (#x7B71 . #xE4AC) + (#x7B72 . #x8FD2B1) + (#x7B73 . #x8FD2B2) + (#x7B74 . #xE4A9) + (#x7B75 . #xE4A7) + (#x7B77 . #x8FD2B3) + (#x7B7A . #xE4A1) + (#x7B84 . #x8FD2B4) + (#x7B86 . #xCACF) + (#x7B87 . #xB2D5) + (#x7B89 . #x8FD2B5) + (#x7B8B . #xE4B5) + (#x7B8D . #xE4B2) + (#x7B8E . #x8FD2B6) + (#x7B8F . #xE4B7) + (#x7B90 . #x8FD2B7) + (#x7B91 . #x8FD2B8) + (#x7B92 . #xE4B6) + (#x7B94 . #xC7F3) + (#x7B95 . #xCCA7) + (#x7B96 . #x8FD2B9) + (#x7B97 . #xBBBB) + (#x7B98 . #xE4B0) + (#x7B99 . #xE4B9) + (#x7B9A . #xE4B4) + (#x7B9B . #x8FD2BA) + (#x7B9C . #xE4B3) + (#x7B9D . #xE4AF) + (#x7B9E . #x8FD2BB) + (#x7B9F . #xE4B1) + (#x7BA0 . #x8FD2BC) + (#x7BA1 . #xB4C9) + (#x7BA5 . #x8FD2BD) + (#x7BAA . #xC3BD) + (#x7BAC . #x8FD2BE) + (#x7BAD . #xC0FD) + (#x7BAF . #x8FD2BF) + (#x7BB0 . #x8FD2C0) + (#x7BB1 . #xC8A2) + (#x7BB2 . #x8FD2C1) + (#x7BB4 . #xE4BE) + (#x7BB5 . #x8FD2C2) + (#x7BB6 . #x8FD2C3) + (#x7BB8 . #xC8A4) + (#x7BBA . #x8FD2C4) + (#x7BBB . #x8FD2C5) + (#x7BBC . #x8FD2C6) + (#x7BBD . #x8FD2C7) + (#x7BC0 . #xC0E1) + (#x7BC1 . #xE4BB) + (#x7BC2 . #x8FD2C8) + (#x7BC4 . #xC8CF) + (#x7BC5 . #x8FD2C9) + (#x7BC6 . #xE4BF) + (#x7BC7 . #xCAD3) + (#x7BC8 . #x8FD2CA) + (#x7BC9 . #xC3DB) + (#x7BCA . #x8FD2CB) + (#x7BCB . #xE4BA) + (#x7BCC . #xE4BC) + (#x7BCF . #xE4BD) + (#x7BD4 . #x8FD2CC) + (#x7BD6 . #x8FD2CD) + (#x7BD7 . #x8FD2CE) + (#x7BD9 . #x8FD2CF) + (#x7BDA . #x8FD2D0) + (#x7BDB . #x8FD2D1) + (#x7BDD . #xE4C0) + (#x7BE0 . #xBCC4) + (#x7BE4 . #xC6C6) + (#x7BE5 . #xE4C5) + (#x7BE6 . #xE4C4) + (#x7BE8 . #x8FD2D2) + (#x7BE9 . #xE4C1) + (#x7BEA . #x8FD2D3) + (#x7BED . #xCFB6) + (#x7BF2 . #x8FD2D4) + (#x7BF3 . #xE4CA) + (#x7BF4 . #x8FD2D5) + (#x7BF5 . #x8FD2D6) + (#x7BF6 . #xE4CE) + (#x7BF7 . #xE4CB) + (#x7BF8 . #x8FD2D7) + (#x7BF9 . #x8FD2D8) + (#x7BFA . #x8FD2D9) + (#x7BFC . #x8FD2DA) + (#x7BFE . #x8FD2DB) + (#x7C00 . #xE4C7) + (#x7C01 . #x8FD2DC) + (#x7C02 . #x8FD2DD) + (#x7C03 . #x8FD2DE) + (#x7C04 . #x8FD2DF) + (#x7C06 . #x8FD2E0) + (#x7C07 . #xE4C8) + (#x7C09 . #x8FD2E1) + (#x7C0B . #x8FD2E2) + (#x7C0C . #x8FD2E3) + (#x7C0D . #xE4CD) + (#x7C0E . #x8FD2E4) + (#x7C0F . #x8FD2E5) + (#x7C11 . #xE4C2) + (#x7C12 . #xD2D5) + (#x7C13 . #xE4C9) + (#x7C14 . #xE4C3) + (#x7C17 . #xE4CC) + (#x7C19 . #x8FD2E6) + (#x7C1B . #x8FD2E7) + (#x7C1F . #xE4D2) + (#x7C20 . #x8FD2E8) + (#x7C21 . #xB4CA) + (#x7C23 . #xE4CF) + (#x7C25 . #x8FD2E9) + (#x7C26 . #x8FD2EA) + (#x7C27 . #xE4D0) + (#x7C28 . #x8FD2EB) + (#x7C2A . #xE4D1) + (#x7C2B . #xE4D4) + (#x7C2C . #x8FD2EC) + (#x7C31 . #x8FD2ED) + (#x7C33 . #x8FD2EE) + (#x7C34 . #x8FD2EF) + (#x7C36 . #x8FD2F0) + (#x7C37 . #xE4D3) + (#x7C38 . #xC8F6) + (#x7C39 . #x8FD2F1) + (#x7C3A . #x8FD2F2) + (#x7C3D . #xE4D5) + (#x7C3E . #xCEFC) + (#x7C3F . #xCAED) + (#x7C40 . #xE4DA) + (#x7C43 . #xE4D7) + (#x7C46 . #x8FD2F3) + (#x7C4A . #x8FD2F4) + (#x7C4C . #xE4D6) + (#x7C4D . #xC0D2) + (#x7C4F . #xE4D9) + (#x7C50 . #xE4DB) + (#x7C51 . #x8FD2F6) + (#x7C52 . #x8FD2F7) + (#x7C53 . #x8FD2F8) + (#x7C54 . #xE4D8) + (#x7C55 . #x8FD2F5) + (#x7C56 . #xE4DF) + (#x7C58 . #xE4DC) + (#x7C59 . #x8FD2F9) + (#x7C5A . #x8FD2FA) + (#x7C5B . #x8FD2FB) + (#x7C5C . #x8FD2FC) + (#x7C5D . #x8FD2FD) + (#x7C5E . #x8FD2FE) + (#x7C5F . #xE4DD) + (#x7C60 . #xE4C6) + (#x7C61 . #x8FD3A1) + (#x7C63 . #x8FD3A2) + (#x7C64 . #xE4DE) + (#x7C65 . #xE4E0) + (#x7C67 . #x8FD3A3) + (#x7C69 . #x8FD3A4) + (#x7C6C . #xE4E1) + (#x7C6D . #x8FD3A5) + (#x7C6E . #x8FD3A6) + (#x7C70 . #x8FD3A7) + (#x7C72 . #x8FD3A8) + (#x7C73 . #xCAC6) + (#x7C75 . #xE4E2) + (#x7C79 . #x8FD3A9) + (#x7C7C . #x8FD3AA) + (#x7C7D . #x8FD3AB) + (#x7C7E . #xCCE2) + (#x7C81 . #xB6CE) + (#x7C82 . #xB7A9) + (#x7C83 . #xE4E3) + (#x7C86 . #x8FD3AC) + (#x7C87 . #x8FD3AD) + (#x7C89 . #xCAB4) + (#x7C8B . #xBFE8) + (#x7C8D . #xCCB0) + (#x7C8F . #x8FD3AE) + (#x7C90 . #xE4E4) + (#x7C92 . #xCEB3) + (#x7C94 . #x8FD3AF) + (#x7C95 . #xC7F4) + (#x7C97 . #xC1C6) + (#x7C98 . #xC7B4) + (#x7C9B . #xBDCD) + (#x7C9E . #x8FD3B0) + (#x7C9F . #xB0C0) + (#x7CA0 . #x8FD3B1) + (#x7CA1 . #xE4E9) + (#x7CA2 . #xE4E7) + (#x7CA4 . #xE4E5) + (#x7CA5 . #xB4A1) + (#x7CA6 . #x8FD3B2) + (#x7CA7 . #xBED1) + (#x7CA8 . #xE4EA) + (#x7CAB . #xE4E8) + (#x7CAD . #xE4E6) + (#x7CAE . #xE4EE) + (#x7CB0 . #x8FD3B3) + (#x7CB1 . #xE4ED) + (#x7CB2 . #xE4EC) + (#x7CB3 . #xE4EB) + (#x7CB6 . #x8FD3B4) + (#x7CB7 . #x8FD3B5) + (#x7CB9 . #xE4EF) + (#x7CBA . #x8FD3B6) + (#x7CBB . #x8FD3B7) + (#x7CBC . #x8FD3B8) + (#x7CBD . #xE4F0) + (#x7CBE . #xC0BA) + (#x7CBF . #x8FD3B9) + (#x7CC0 . #xE4F1) + (#x7CC2 . #xE4F3) + (#x7CC4 . #x8FD3BA) + (#x7CC5 . #xE4F2) + (#x7CC7 . #x8FD3BB) + (#x7CC8 . #x8FD3BC) + (#x7CC9 . #x8FD3BD) + (#x7CCA . #xB8D2) + (#x7CCD . #x8FD3BE) + (#x7CCE . #xC1B8) + (#x7CCF . #x8FD3BF) + (#x7CD2 . #xE4F5) + (#x7CD3 . #x8FD3C0) + (#x7CD4 . #x8FD3C1) + (#x7CD5 . #x8FD3C2) + (#x7CD6 . #xC5FC) + (#x7CD7 . #x8FD3C3) + (#x7CD8 . #xE4F4) + (#x7CD9 . #x8FD3C4) + (#x7CDA . #x8FD3C5) + (#x7CDC . #xE4F6) + (#x7CDD . #x8FD3C6) + (#x7CDE . #xCAB5) + (#x7CDF . #xC1EC) + (#x7CE0 . #xB9C7) + (#x7CE2 . #xE4F7) + (#x7CE6 . #x8FD3C7) + (#x7CE7 . #xCEC8) + (#x7CE9 . #x8FD3C8) + (#x7CEB . #x8FD3C9) + (#x7CEF . #xE4F9) + (#x7CF2 . #xE4FA) + (#x7CF4 . #xE4FB) + (#x7CF5 . #x8FD3CA) + (#x7CF6 . #xE4FC) + (#x7CF8 . #xBBE5) + (#x7CFA . #xE4FD) + (#x7CFB . #xB7CF) + (#x7CFE . #xB5EA) + (#x7D00 . #xB5AA) + (#x7D02 . #xE5A1) + (#x7D03 . #x8FD3CB) + (#x7D04 . #xCCF3) + (#x7D05 . #xB9C8) + (#x7D06 . #xE4FE) + (#x7D07 . #x8FD3CC) + (#x7D08 . #x8FD3CD) + (#x7D09 . #x8FD3CE) + (#x7D0A . #xE5A4) + (#x7D0B . #xCCE6) + (#x7D0D . #xC7BC) + (#x7D0F . #x8FD3CF) + (#x7D10 . #xC9B3) + (#x7D11 . #x8FD3D0) + (#x7D12 . #x8FD3D1) + (#x7D13 . #x8FD3D2) + (#x7D14 . #xBDE3) + (#x7D15 . #xE5A3) + (#x7D16 . #x8FD3D3) + (#x7D17 . #xBCD3) + (#x7D18 . #xB9C9) + (#x7D19 . #xBBE6) + (#x7D1A . #xB5E9) + (#x7D1B . #xCAB6) + (#x7D1C . #xE5A2) + (#x7D1D . #x8FD3D4) + (#x7D1E . #x8FD3D5) + (#x7D20 . #xC1C7) + (#x7D21 . #xCBC2) + (#x7D22 . #xBAF7) + (#x7D23 . #x8FD3D6) + (#x7D26 . #x8FD3D7) + (#x7D2A . #x8FD3D8) + (#x7D2B . #xBBE7) + (#x7D2C . #xC4DD) + (#x7D2D . #x8FD3D9) + (#x7D2E . #xE5A7) + (#x7D2F . #xCEDF) + (#x7D30 . #xBAD9) + (#x7D31 . #x8FD3DA) + (#x7D32 . #xE5A8) + (#x7D33 . #xBFC2) + (#x7D35 . #xE5AA) + (#x7D39 . #xBED2) + (#x7D3A . #xBAB0) + (#x7D3C . #x8FD3DB) + (#x7D3D . #x8FD3DC) + (#x7D3E . #x8FD3DD) + (#x7D3F . #xE5A9) + (#x7D40 . #x8FD3DE) + (#x7D41 . #x8FD3DF) + (#x7D42 . #xBDAA) + (#x7D43 . #xB8BE) + (#x7D44 . #xC1C8) + (#x7D45 . #xE5A5) + (#x7D46 . #xE5AB) + (#x7D47 . #x8FD3E0) + (#x7D48 . #x8FD3E1) + (#x7D4B . #xE5A6) + (#x7D4C . #xB7D0) + (#x7D4D . #x8FD3E2) + (#x7D4E . #xE5AE) + (#x7D4F . #xE5B2) + (#x7D50 . #xB7EB) + (#x7D51 . #x8FD3E3) + (#x7D53 . #x8FD3E4) + (#x7D56 . #xE5AD) + (#x7D57 . #x8FD3E5) + (#x7D59 . #x8FD3E6) + (#x7D5A . #x8FD3E7) + (#x7D5B . #xE5B6) + (#x7D5C . #x8FD3E8) + (#x7D5D . #x8FD3E9) + (#x7D5E . #xB9CA) + (#x7D61 . #xCDED) + (#x7D62 . #xB0BC) + (#x7D63 . #xE5B3) + (#x7D65 . #x8FD3EA) + (#x7D66 . #xB5EB) + (#x7D67 . #x8FD3EB) + (#x7D68 . #xE5B0) + (#x7D6A . #x8FD3EC) + (#x7D6E . #xE5B1) + (#x7D70 . #x8FD3ED) + (#x7D71 . #xC5FD) + (#x7D72 . #xE5AF) + (#x7D73 . #xE5AC) + (#x7D75 . #xB3A8) + (#x7D76 . #xC0E4) + (#x7D78 . #x8FD3EE) + (#x7D79 . #xB8A8) + (#x7D7A . #x8FD3EF) + (#x7D7B . #x8FD3F0) + (#x7D7D . #xE5B8) + (#x7D7F . #x8FD3F1) + (#x7D81 . #x8FD3F2) + (#x7D82 . #x8FD3F3) + (#x7D83 . #x8FD3F4) + (#x7D85 . #x8FD3F5) + (#x7D86 . #x8FD3F6) + (#x7D88 . #x8FD3F7) + (#x7D89 . #xE5B5) + (#x7D8B . #x8FD3F8) + (#x7D8C . #x8FD3F9) + (#x7D8D . #x8FD3FA) + (#x7D8F . #xE5B7) + (#x7D91 . #x8FD3FB) + (#x7D93 . #xE5B4) + (#x7D96 . #x8FD3FC) + (#x7D97 . #x8FD3FD) + (#x7D99 . #xB7D1) + (#x7D9A . #xC2B3) + (#x7D9B . #xE5B9) + (#x7D9C . #xC1EE) + (#x7D9D . #x8FD3FE) + (#x7D9E . #x8FD4A1) + (#x7D9F . #xE5C6) + (#x7DA2 . #xE5C2) + (#x7DA3 . #xE5BC) + (#x7DA6 . #x8FD4A2) + (#x7DA7 . #x8FD4A3) + (#x7DAA . #x8FD4A4) + (#x7DAB . #xE5C0) + (#x7DAC . #xBCFA) + (#x7DAD . #xB0DD) + (#x7DAE . #xE5BB) + (#x7DAF . #xE5C3) + (#x7DB0 . #xE5C7) + (#x7DB1 . #xB9CB) + (#x7DB2 . #xCCD6) + (#x7DB3 . #x8FD4A5) + (#x7DB4 . #xC4D6) + (#x7DB5 . #xE5BD) + (#x7DB6 . #x8FD4A6) + (#x7DB7 . #x8FD4A7) + (#x7DB8 . #xE5C5) + (#x7DB9 . #x8FD4A8) + (#x7DBA . #xE5BA) + (#x7DBB . #xC3BE) + (#x7DBD . #xE5BF) + (#x7DBE . #xB0BD) + (#x7DBF . #xCCCA) + (#x7DC2 . #x8FD4A9) + (#x7DC3 . #x8FD4AA) + (#x7DC4 . #x8FD4AB) + (#x7DC5 . #x8FD4AC) + (#x7DC6 . #x8FD4AD) + (#x7DC7 . #xE5BE) + (#x7DCA . #xB6DB) + (#x7DCB . #xC8EC) + (#x7DCC . #x8FD4AE) + (#x7DCD . #x8FD4AF) + (#x7DCE . #x8FD4B0) + (#x7DCF . #xC1ED) + (#x7DD1 . #xCED0) + (#x7DD2 . #xBDEF) + (#x7DD5 . #xE5EE) + (#x7DD7 . #x8FD4B1) + (#x7DD8 . #xE5C8) + (#x7DD9 . #x8FD4B2) + (#x7DDA . #xC0FE) + (#x7DDC . #xE5C4) + (#x7DDD . #xE5C9) + (#x7DDE . #xE5CB) + (#x7DE0 . #xC4F9) + (#x7DE1 . #xE5CE) + (#x7DE2 . #x8FD4B4) + (#x7DE4 . #xE5CA) + (#x7DE5 . #x8FD4B5) + (#x7DE6 . #x8FD4B6) + (#x7DE8 . #xCAD4) + (#x7DE9 . #xB4CB) + (#x7DEA . #x8FD4B7) + (#x7DEB . #x8FD4B8) + (#x7DEC . #xCCCB) + (#x7DED . #x8FD4B9) + (#x7DEF . #xB0DE) + (#x7DF1 . #x8FD4BA) + (#x7DF2 . #xE5CD) + (#x7DF4 . #xCEFD) + (#x7DF5 . #x8FD4BB) + (#x7DF6 . #x8FD4BC) + (#x7DF9 . #x8FD4BD) + (#x7DFA . #x8FD4BE) + (#x7DFB . #xE5CC) + (#x7E00 . #x8FD4B3) + (#x7E01 . #xB1EF) + (#x7E04 . #xC6EC) + (#x7E05 . #xE5CF) + (#x7E08 . #x8FD4BF) + (#x7E09 . #xE5D6) + (#x7E0A . #xE5D0) + (#x7E0B . #xE5D7) + (#x7E10 . #x8FD4C0) + (#x7E11 . #x8FD4C1) + (#x7E12 . #xE5D3) + (#x7E15 . #x8FD4C2) + (#x7E17 . #x8FD4C3) + (#x7E1B . #xC7FB) + (#x7E1C . #x8FD4C4) + (#x7E1D . #x8FD4C5) + (#x7E1E . #xBCCA) + (#x7E1F . #xE5D5) + (#x7E20 . #x8FD4C6) + (#x7E21 . #xE5D2) + (#x7E22 . #xE5D8) + (#x7E23 . #xE5D1) + (#x7E26 . #xBDC4) + (#x7E27 . #x8FD4C7) + (#x7E28 . #x8FD4C8) + (#x7E2B . #xCBA5) + (#x7E2C . #x8FD4C9) + (#x7E2D . #x8FD4CA) + (#x7E2E . #xBDCC) + (#x7E2F . #x8FD4CB) + (#x7E31 . #xE5D4) + (#x7E32 . #xE5E0) + (#x7E33 . #x8FD4CC) + (#x7E35 . #xE5DC) + (#x7E36 . #x8FD4CD) + (#x7E37 . #xE5DF) + (#x7E39 . #xE5DD) + (#x7E3A . #xE5E1) + (#x7E3B . #xE5DB) + (#x7E3D . #xE5C1) + (#x7E3E . #xC0D3) + (#x7E3F . #x8FD4CE) + (#x7E41 . #xC8CB) + (#x7E43 . #xE5DE) + (#x7E44 . #x8FD4CF) + (#x7E45 . #x8FD4D0) + (#x7E46 . #xE5D9) + (#x7E47 . #x8FD4D1) + (#x7E4A . #xC1A1) + (#x7E4B . #xB7D2) + (#x7E4D . #xBDAB) + (#x7E4E . #x8FD4D2) + (#x7E50 . #x8FD4D3) + (#x7E52 . #x8FD4D4) + (#x7E54 . #xBFA5) + (#x7E55 . #xC1B6) + (#x7E56 . #xE5E4) + (#x7E58 . #x8FD4D5) + (#x7E59 . #xE5E6) + (#x7E5A . #xE5E7) + (#x7E5D . #xE5E3) + (#x7E5E . #xE5E5) + (#x7E5F . #x8FD4D6) + (#x7E61 . #x8FD4D7) + (#x7E62 . #x8FD4D8) + (#x7E65 . #x8FD4D9) + (#x7E66 . #xE5DA) + (#x7E67 . #xE5E2) + (#x7E69 . #xE5EA) + (#x7E6A . #xE5E9) + (#x7E6B . #x8FD4DA) + (#x7E6D . #xCBFA) + (#x7E6E . #x8FD4DB) + (#x7E6F . #x8FD4DC) + (#x7E70 . #xB7AB) + (#x7E73 . #x8FD4DD) + (#x7E78 . #x8FD4DE) + (#x7E79 . #xE5E8) + (#x7E7B . #xE5EC) + (#x7E7C . #xE5EB) + (#x7E7D . #xE5EF) + (#x7E7E . #x8FD4DF) + (#x7E7F . #xE5F1) + (#x7E81 . #x8FD4E0) + (#x7E82 . #xBBBC) + (#x7E83 . #xE5ED) + (#x7E86 . #x8FD4E1) + (#x7E87 . #x8FD4E2) + (#x7E88 . #xE5F2) + (#x7E89 . #xE5F3) + (#x7E8A . #x8FD4E3) + (#x7E8C . #xE5F4) + (#x7E8D . #x8FD4E4) + (#x7E8E . #xE5FA) + (#x7E8F . #xC5BB) + (#x7E90 . #xE5F6) + (#x7E91 . #x8FD4E5) + (#x7E92 . #xE5F5) + (#x7E93 . #xE5F7) + (#x7E94 . #xE5F8) + (#x7E95 . #x8FD4E6) + (#x7E96 . #xE5F9) + (#x7E98 . #x8FD4E7) + (#x7E9A . #x8FD4E8) + (#x7E9B . #xE5FB) + (#x7E9C . #xE5FC) + (#x7E9D . #x8FD4E9) + (#x7E9E . #x8FD4EA) + (#x7F36 . #xB4CC) + (#x7F38 . #xE5FD) + (#x7F3A . #xE5FE) + (#x7F3B . #x8FD4EC) + (#x7F3C . #x8FD4EB) + (#x7F3D . #x8FD4ED) + (#x7F3E . #x8FD4EE) + (#x7F3F . #x8FD4EF) + (#x7F43 . #x8FD4F0) + (#x7F44 . #x8FD4F1) + (#x7F45 . #xE6A1) + (#x7F47 . #x8FD4F2) + (#x7F4C . #xE6A2) + (#x7F4D . #xE6A3) + (#x7F4E . #xE6A4) + (#x7F4F . #x8FD4F3) + (#x7F50 . #xE6A5) + (#x7F51 . #xE6A6) + (#x7F52 . #x8FD4F4) + (#x7F53 . #x8FD4F5) + (#x7F54 . #xE6A8) + (#x7F55 . #xE6A7) + (#x7F58 . #xE6A9) + (#x7F5B . #x8FD4F6) + (#x7F5C . #x8FD4F7) + (#x7F5D . #x8FD4F8) + (#x7F5F . #xE6AA) + (#x7F60 . #xE6AB) + (#x7F61 . #x8FD4F9) + (#x7F63 . #x8FD4FA) + (#x7F64 . #x8FD4FB) + (#x7F65 . #x8FD4FC) + (#x7F66 . #x8FD4FD) + (#x7F67 . #xE6AE) + (#x7F68 . #xE6AC) + (#x7F69 . #xE6AD) + (#x7F6A . #xBAE1) + (#x7F6B . #xB7D3) + (#x7F6D . #x8FD4FE) + (#x7F6E . #xC3D6) + (#x7F70 . #xC8B3) + (#x7F71 . #x8FD5A1) + (#x7F72 . #xBDF0) + (#x7F75 . #xC7CD) + (#x7F77 . #xC8ED) + (#x7F78 . #xE6AF) + (#x7F79 . #xD8ED) + (#x7F7D . #x8FD5A2) + (#x7F7E . #x8FD5A3) + (#x7F7F . #x8FD5A4) + (#x7F80 . #x8FD5A5) + (#x7F82 . #xE6B0) + (#x7F83 . #xE6B2) + (#x7F85 . #xCDE5) + (#x7F86 . #xE6B1) + (#x7F87 . #xE6B4) + (#x7F88 . #xE6B3) + (#x7F8A . #xCDD3) + (#x7F8B . #x8FD5A6) + (#x7F8C . #xE6B5) + (#x7F8D . #x8FD5A7) + (#x7F8E . #xC8FE) + (#x7F8F . #x8FD5A8) + (#x7F90 . #x8FD5A9) + (#x7F91 . #x8FD5AA) + (#x7F94 . #xE6B6) + (#x7F96 . #x8FD5AB) + (#x7F97 . #x8FD5AC) + (#x7F9A . #xE6B9) + (#x7F9C . #x8FD5AD) + (#x7F9D . #xE6B8) + (#x7F9E . #xE6B7) + (#x7FA1 . #x8FD5AE) + (#x7FA2 . #x8FD5AF) + (#x7FA3 . #xE6BA) + (#x7FA4 . #xB7B2) + (#x7FA6 . #x8FD5B0) + (#x7FA8 . #xC1A2) + (#x7FA9 . #xB5C1) + (#x7FAA . #x8FD5B1) + (#x7FAD . #x8FD5B2) + (#x7FAE . #xE6BE) + (#x7FAF . #xE6BB) + (#x7FB2 . #xE6BC) + (#x7FB4 . #x8FD5B3) + (#x7FB6 . #xE6BF) + (#x7FB8 . #xE6C0) + (#x7FB9 . #xE6BD) + (#x7FBC . #x8FD5B4) + (#x7FBD . #xB1A9) + (#x7FBF . #x8FD5B5) + (#x7FC0 . #x8FD5B6) + (#x7FC1 . #xB2A7) + (#x7FC3 . #x8FD5B7) + (#x7FC5 . #xE6C2) + (#x7FC6 . #xE6C3) + (#x7FC8 . #x8FD5B8) + (#x7FCA . #xE6C4) + (#x7FCC . #xCDE2) + (#x7FCE . #x8FD5B9) + (#x7FCF . #x8FD5BA) + (#x7FD2 . #xBDAC) + (#x7FD4 . #xE6C6) + (#x7FD5 . #xE6C5) + (#x7FDB . #x8FD5BB) + (#x7FDF . #x8FD5BC) + (#x7FE0 . #xBFE9) + (#x7FE1 . #xE6C7) + (#x7FE3 . #x8FD5BD) + (#x7FE5 . #x8FD5BE) + (#x7FE6 . #xE6C8) + (#x7FE8 . #x8FD5BF) + (#x7FE9 . #xE6C9) + (#x7FEB . #xB4E5) + (#x7FEC . #x8FD5C0) + (#x7FEE . #x8FD5C1) + (#x7FEF . #x8FD5C2) + (#x7FF0 . #xB4CD) + (#x7FF2 . #x8FD5C3) + (#x7FF3 . #xE6CA) + (#x7FF9 . #xE6CB) + (#x7FFA . #x8FD5C4) + (#x7FFB . #xCBDD) + (#x7FFC . #xCDE3) + (#x7FFD . #x8FD5C5) + (#x7FFE . #x8FD5C6) + (#x7FFF . #x8FD5C7) + (#x8000 . #xCDD4) + (#x8001 . #xCFB7) + (#x8003 . #xB9CD) + (#x8004 . #xE6CE) + (#x8005 . #xBCD4) + (#x8006 . #xE6CD) + (#x8007 . #x8FD5C8) + (#x8008 . #x8FD5C9) + (#x800A . #x8FD5CA) + (#x800B . #xE6CF) + (#x800C . #xBCA9) + (#x800D . #x8FD5CB) + (#x800E . #x8FD5CC) + (#x800F . #x8FD5CD) + (#x8010 . #xC2D1) + (#x8011 . #x8FD5CE) + (#x8012 . #xE6D0) + (#x8013 . #x8FD5CF) + (#x8014 . #x8FD5D0) + (#x8015 . #xB9CC) + (#x8016 . #x8FD5D1) + (#x8017 . #xCCD7) + (#x8018 . #xE6D1) + (#x8019 . #xE6D2) + (#x801C . #xE6D3) + (#x801D . #x8FD5D2) + (#x801E . #x8FD5D3) + (#x801F . #x8FD5D4) + (#x8020 . #x8FD5D5) + (#x8021 . #xE6D4) + (#x8024 . #x8FD5D6) + (#x8026 . #x8FD5D7) + (#x8028 . #xE6D5) + (#x802C . #x8FD5D8) + (#x802E . #x8FD5D9) + (#x8030 . #x8FD5DA) + (#x8033 . #xBCAA) + (#x8034 . #x8FD5DB) + (#x8035 . #x8FD5DC) + (#x8036 . #xCCED) + (#x8037 . #x8FD5DD) + (#x8039 . #x8FD5DE) + (#x803A . #x8FD5DF) + (#x803B . #xE6D7) + (#x803C . #x8FD5E0) + (#x803D . #xC3BF) + (#x803E . #x8FD5E1) + (#x803F . #xE6D6) + (#x8040 . #x8FD5E2) + (#x8044 . #x8FD5E3) + (#x8046 . #xE6D9) + (#x804A . #xE6D8) + (#x8052 . #xE6DA) + (#x8056 . #xC0BB) + (#x8058 . #xE6DB) + (#x805A . #xE6DC) + (#x805E . #xCAB9) + (#x805F . #xE6DD) + (#x8060 . #x8FD5E4) + (#x8061 . #xC1EF) + (#x8062 . #xE6DE) + (#x8064 . #x8FD5E5) + (#x8066 . #x8FD5E6) + (#x8068 . #xE6DF) + (#x806D . #x8FD5E7) + (#x806F . #xCEFE) + (#x8070 . #xE6E2) + (#x8071 . #x8FD5E8) + (#x8072 . #xE6E1) + (#x8073 . #xE6E0) + (#x8074 . #xC4B0) + (#x8075 . #x8FD5E9) + (#x8076 . #xE6E3) + (#x8077 . #xBFA6) + (#x8079 . #xE6E4) + (#x807D . #xE6E5) + (#x807E . #xCFB8) + (#x807F . #xE6E6) + (#x8081 . #x8FD5EA) + (#x8084 . #xE6E7) + (#x8085 . #xE6E9) + (#x8086 . #xE6E8) + (#x8087 . #xC8A5) + (#x8088 . #x8FD5EB) + (#x8089 . #xC6F9) + (#x808B . #xCFBE) + (#x808C . #xC8A9) + (#x808E . #x8FD5EC) + (#x8093 . #xE6EB) + (#x8096 . #xBED3) + (#x8098 . #xC9AA) + (#x809A . #xE6EC) + (#x809B . #xE6EA) + (#x809C . #x8FD5ED) + (#x809D . #xB4CE) + (#x809E . #x8FD5EE) + (#x80A1 . #xB8D4) + (#x80A2 . #xBBE8) + (#x80A5 . #xC8EE) + (#x80A6 . #x8FD5EF) + (#x80A7 . #x8FD5F0) + (#x80A9 . #xB8AA) + (#x80AA . #xCBC3) + (#x80AB . #x8FD5F1) + (#x80AC . #xE6EF) + (#x80AD . #xE6ED) + (#x80AF . #xB9CE) + (#x80B1 . #xB9CF) + (#x80B2 . #xB0E9) + (#x80B4 . #xBAE8) + (#x80B8 . #x8FD5F2) + (#x80B9 . #x8FD5F3) + (#x80BA . #xC7D9) + (#x80C3 . #xB0DF) + (#x80C4 . #xE6F4) + (#x80C6 . #xC3C0) + (#x80C8 . #x8FD5F4) + (#x80CC . #xC7D8) + (#x80CD . #x8FD5F5) + (#x80CE . #xC2DB) + (#x80CF . #x8FD5F6) + (#x80D2 . #x8FD5F7) + (#x80D4 . #x8FD5F8) + (#x80D5 . #x8FD5F9) + (#x80D6 . #xE6F6) + (#x80D7 . #x8FD5FA) + (#x80D8 . #x8FD5FB) + (#x80D9 . #xE6F2) + (#x80DA . #xE6F5) + (#x80DB . #xE6F0) + (#x80DD . #xE6F3) + (#x80DE . #xCBA6) + (#x80E0 . #x8FD5FC) + (#x80E1 . #xB8D5) + (#x80E4 . #xB0FD) + (#x80E5 . #xE6F1) + (#x80ED . #x8FD5FD) + (#x80EE . #x8FD5FE) + (#x80EF . #xE6F8) + (#x80F0 . #x8FD6A1) + (#x80F1 . #xE6F9) + (#x80F2 . #x8FD6A2) + (#x80F3 . #x8FD6A3) + (#x80F4 . #xC6B9) + (#x80F6 . #x8FD6A4) + (#x80F8 . #xB6BB) + (#x80F9 . #x8FD6A5) + (#x80FA . #x8FD6A6) + (#x80FC . #xE7A6) + (#x80FD . #xC7BD) + (#x80FE . #x8FD6A7) + (#x8102 . #xBBE9) + (#x8103 . #x8FD6A8) + (#x8105 . #xB6BC) + (#x8106 . #xC0C8) + (#x8107 . #xCFC6) + (#x8108 . #xCCAE) + (#x8109 . #xE6F7) + (#x810A . #xC0D4) + (#x810B . #x8FD6A9) + (#x8116 . #x8FD6AA) + (#x8117 . #x8FD6AB) + (#x8118 . #x8FD6AC) + (#x811A . #xB5D3) + (#x811B . #xE6FA) + (#x811C . #x8FD6AD) + (#x811E . #x8FD6AE) + (#x8120 . #x8FD6AF) + (#x8123 . #xE6FC) + (#x8124 . #x8FD6B0) + (#x8127 . #x8FD6B1) + (#x8129 . #xE6FB) + (#x812C . #x8FD6B2) + (#x812F . #xE6FD) + (#x8130 . #x8FD6B3) + (#x8131 . #xC3A6) + (#x8133 . #xC7BE) + (#x8135 . #x8FD6B4) + (#x8139 . #xC4B1) + (#x813A . #x8FD6B5) + (#x813C . #x8FD6B6) + (#x813E . #xE7A3) + (#x8145 . #x8FD6B7) + (#x8146 . #xE7A2) + (#x8147 . #x8FD6B8) + (#x814A . #x8FD6B9) + (#x814B . #xE6FE) + (#x814C . #x8FD6BA) + (#x814E . #xBFD5) + (#x8150 . #xC9E5) + (#x8151 . #xE7A5) + (#x8152 . #x8FD6BB) + (#x8153 . #xE7A4) + (#x8154 . #xB9D0) + (#x8155 . #xCFD3) + (#x8157 . #x8FD6BC) + (#x815F . #xE7B5) + (#x8160 . #x8FD6BD) + (#x8161 . #x8FD6BE) + (#x8165 . #xE7A9) + (#x8166 . #xE7AA) + (#x8167 . #x8FD6BF) + (#x8168 . #x8FD6C0) + (#x8169 . #x8FD6C1) + (#x816B . #xBCF0) + (#x816D . #x8FD6C2) + (#x816E . #xE7A8) + (#x816F . #x8FD6C3) + (#x8170 . #xB9F8) + (#x8171 . #xE7A7) + (#x8174 . #xE7AB) + (#x8177 . #x8FD6C4) + (#x8178 . #xC4B2) + (#x8179 . #xCAA2) + (#x817A . #xC1A3) + (#x817F . #xC2DC) + (#x8180 . #xE7AF) + (#x8181 . #x8FD6C5) + (#x8182 . #xE7B0) + (#x8183 . #xE7AC) + (#x8184 . #x8FD6C7) + (#x8185 . #x8FD6C8) + (#x8186 . #x8FD6C9) + (#x8188 . #xE7AD) + (#x818A . #xE7AE) + (#x818B . #x8FD6CA) + (#x818E . #x8FD6CB) + (#x818F . #xB9D1) + (#x8190 . #x8FD6C6) + (#x8193 . #xE7B6) + (#x8195 . #xE7B2) + (#x8196 . #x8FD6CC) + (#x8198 . #x8FD6CD) + (#x819A . #xC9E6) + (#x819B . #x8FD6CE) + (#x819C . #xCBEC) + (#x819D . #xC9A8) + (#x819E . #x8FD6CF) + (#x81A0 . #xE7B1) + (#x81A2 . #x8FD6D0) + (#x81A3 . #xE7B4) + (#x81A4 . #xE7B3) + (#x81A8 . #xCBC4) + (#x81A9 . #xE7B7) + (#x81AE . #x8FD6D1) + (#x81B0 . #xE7B8) + (#x81B2 . #x8FD6D2) + (#x81B3 . #xC1B7) + (#x81B4 . #x8FD6D3) + (#x81B5 . #xE7B9) + (#x81B8 . #xE7BB) + (#x81BA . #xE7BF) + (#x81BB . #x8FD6D4) + (#x81BD . #xE7BC) + (#x81BE . #xE7BA) + (#x81BF . #xC7BF) + (#x81C0 . #xE7BD) + (#x81C2 . #xE7BE) + (#x81C3 . #x8FD6D6) + (#x81C5 . #x8FD6D7) + (#x81C6 . #xB2B2) + (#x81C8 . #xE7C5) + (#x81C9 . #xE7C0) + (#x81CA . #x8FD6D8) + (#x81CB . #x8FD6D5) + (#x81CD . #xE7C1) + (#x81CE . #x8FD6D9) + (#x81CF . #x8FD6DA) + (#x81D1 . #xE7C2) + (#x81D3 . #xC2A1) + (#x81D5 . #x8FD6DB) + (#x81D7 . #x8FD6DC) + (#x81D8 . #xE7C4) + (#x81D9 . #xE7C3) + (#x81DA . #xE7C6) + (#x81DB . #x8FD6DD) + (#x81DD . #x8FD6DE) + (#x81DE . #x8FD6DF) + (#x81DF . #xE7C7) + (#x81E0 . #xE7C8) + (#x81E1 . #x8FD6E0) + (#x81E3 . #xBFC3) + (#x81E4 . #x8FD6E1) + (#x81E5 . #xB2E9) + (#x81E7 . #xE7C9) + (#x81E8 . #xCED7) + (#x81EA . #xBCAB) + (#x81EB . #x8FD6E2) + (#x81EC . #x8FD6E3) + (#x81ED . #xBDAD) + (#x81F0 . #x8FD6E4) + (#x81F1 . #x8FD6E5) + (#x81F2 . #x8FD6E6) + (#x81F3 . #xBBEA) + (#x81F4 . #xC3D7) + (#x81F5 . #x8FD6E7) + (#x81F6 . #x8FD6E8) + (#x81F8 . #x8FD6E9) + (#x81F9 . #x8FD6EA) + (#x81FA . #xE7CA) + (#x81FB . #xE7CB) + (#x81FC . #xB1B1) + (#x81FD . #x8FD6EB) + (#x81FE . #xE7CC) + (#x81FF . #x8FD6EC) + (#x8200 . #x8FD6ED) + (#x8201 . #xE7CD) + (#x8202 . #xE7CE) + (#x8203 . #x8FD6EE) + (#x8205 . #xE7CF) + (#x8207 . #xE7D0) + (#x8208 . #xB6BD) + (#x8209 . #xDAAA) + (#x820A . #xE7D1) + (#x820C . #xC0E5) + (#x820D . #xE7D2) + (#x820E . #xBCCB) + (#x820F . #x8FD6EF) + (#x8210 . #xE7D3) + (#x8212 . #xD0B0) + (#x8213 . #x8FD6F0) + (#x8214 . #x8FD6F1) + (#x8216 . #xE7D4) + (#x8217 . #xCADE) + (#x8218 . #xB4DC) + (#x8219 . #x8FD6F2) + (#x821A . #x8FD6F3) + (#x821B . #xC1A4) + (#x821C . #xBDD8) + (#x821D . #x8FD6F4) + (#x821E . #xC9F1) + (#x821F . #xBDAE) + (#x8221 . #x8FD6F5) + (#x8222 . #x8FD6F6) + (#x8228 . #x8FD6F7) + (#x8229 . #xE7D5) + (#x822A . #xB9D2) + (#x822B . #xE7D6) + (#x822C . #xC8CC) + (#x822E . #xE7E4) + (#x8232 . #x8FD6F8) + (#x8233 . #xE7D8) + (#x8234 . #x8FD6F9) + (#x8235 . #xC2C9) + (#x8236 . #xC7F5) + (#x8237 . #xB8BF) + (#x8238 . #xE7D7) + (#x8239 . #xC1A5) + (#x823A . #x8FD6FA) + (#x8240 . #xE7D9) + (#x8243 . #x8FD6FB) + (#x8244 . #x8FD6FC) + (#x8245 . #x8FD6FD) + (#x8246 . #x8FD6FE) + (#x8247 . #xC4FA) + (#x824B . #x8FD7A1) + (#x824E . #x8FD7A2) + (#x824F . #x8FD7A3) + (#x8251 . #x8FD7A4) + (#x8256 . #x8FD7A5) + (#x8258 . #xE7DB) + (#x8259 . #xE7DA) + (#x825A . #xE7DD) + (#x825C . #x8FD7A6) + (#x825D . #xE7DC) + (#x825F . #xE7DE) + (#x8260 . #x8FD7A7) + (#x8262 . #xE7E0) + (#x8263 . #x8FD7A8) + (#x8264 . #xE7DF) + (#x8266 . #xB4CF) + (#x8267 . #x8FD7A9) + (#x8268 . #xE7E1) + (#x826A . #xE7E2) + (#x826B . #xE7E3) + (#x826D . #x8FD7AA) + (#x826E . #xBAB1) + (#x826F . #xCEC9) + (#x8271 . #xE7E5) + (#x8272 . #xBFA7) + (#x8274 . #x8FD7AB) + (#x8276 . #xB1F0) + (#x8277 . #xE7E6) + (#x8278 . #xE7E7) + (#x827B . #x8FD7AC) + (#x827D . #x8FD7AD) + (#x827E . #xE7E8) + (#x827F . #x8FD7AE) + (#x8280 . #x8FD7AF) + (#x8281 . #x8FD7B0) + (#x8283 . #x8FD7B1) + (#x8284 . #x8FD7B2) + (#x8287 . #x8FD7B3) + (#x8289 . #x8FD7B4) + (#x828A . #x8FD7B5) + (#x828B . #xB0F2) + (#x828D . #xE7E9) + (#x828E . #x8FD7B6) + (#x8291 . #x8FD7B7) + (#x8292 . #xE7EA) + (#x8294 . #x8FD7B8) + (#x8296 . #x8FD7B9) + (#x8298 . #x8FD7BA) + (#x8299 . #xC9E7) + (#x829A . #x8FD7BB) + (#x829B . #x8FD7BC) + (#x829D . #xBCC7) + (#x829F . #xE7EC) + (#x82A0 . #x8FD7BD) + (#x82A1 . #x8FD7BE) + (#x82A3 . #x8FD7BF) + (#x82A4 . #x8FD7C0) + (#x82A5 . #xB3A9) + (#x82A6 . #xB0B2) + (#x82A7 . #x8FD7C1) + (#x82A8 . #x8FD7C2) + (#x82A9 . #x8FD7C3) + (#x82AA . #x8FD7C4) + (#x82AB . #xE7EB) + (#x82AC . #xE7EE) + (#x82AD . #xC7CE) + (#x82AE . #x8FD7C5) + (#x82AF . #xBFC4) + (#x82B0 . #x8FD7C6) + (#x82B1 . #xB2D6) + (#x82B2 . #x8FD7C7) + (#x82B3 . #xCBA7) + (#x82B4 . #x8FD7C8) + (#x82B7 . #x8FD7C9) + (#x82B8 . #xB7DD) + (#x82B9 . #xB6DC) + (#x82BA . #x8FD7CA) + (#x82BB . #xE7ED) + (#x82BC . #x8FD7CB) + (#x82BD . #xB2EA) + (#x82BE . #x8FD7CC) + (#x82BF . #x8FD7CD) + (#x82C5 . #xB4A3) + (#x82C6 . #x8FD7CE) + (#x82D0 . #x8FD7CF) + (#x82D1 . #xB1F1) + (#x82D2 . #xE7F2) + (#x82D3 . #xCEEA) + (#x82D4 . #xC2DD) + (#x82D5 . #x8FD7D0) + (#x82D7 . #xC9C4) + (#x82D9 . #xE7FE) + (#x82DA . #x8FD7D1) + (#x82DB . #xB2D7) + (#x82DC . #xE7FC) + (#x82DE . #xE7FA) + (#x82DF . #xE7F1) + (#x82E0 . #x8FD7D2) + (#x82E1 . #xE7EF) + (#x82E2 . #x8FD7D3) + (#x82E3 . #xE7F0) + (#x82E4 . #x8FD7D4) + (#x82E5 . #xBCE3) + (#x82E6 . #xB6EC) + (#x82E7 . #xC3F7) + (#x82E8 . #x8FD7D5) + (#x82EA . #x8FD7D6) + (#x82EB . #xC6D1) + (#x82ED . #x8FD7D7) + (#x82EF . #x8FD7D8) + (#x82F1 . #xB1D1) + (#x82F3 . #xE7F4) + (#x82F4 . #xE7F3) + (#x82F6 . #x8FD7D9) + (#x82F7 . #x8FD7DA) + (#x82F9 . #xE7F9) + (#x82FA . #xE7F5) + (#x82FB . #xE7F8) + (#x82FD . #x8FD7DB) + (#x82FE . #x8FD7DC) + (#x8300 . #x8FD7DD) + (#x8301 . #x8FD7DE) + (#x8302 . #xCCD0) + (#x8303 . #xE7F7) + (#x8304 . #xB2D8) + (#x8305 . #xB3FD) + (#x8306 . #xE7FB) + (#x8307 . #x8FD7DF) + (#x8308 . #x8FD7E0) + (#x8309 . #xE7FD) + (#x830A . #x8FD7E1) + (#x830B . #x8FD7E2) + (#x830E . #xB7D4) + (#x8316 . #xE8A3) + (#x8317 . #xE8AC) + (#x8318 . #xE8AD) + (#x831B . #x8FD7E4) + (#x831C . #xB0AB) + (#x831D . #x8FD7E5) + (#x831E . #x8FD7E6) + (#x831F . #x8FD7E7) + (#x8321 . #x8FD7E8) + (#x8322 . #x8FD7E9) + (#x8323 . #xE8B4) + (#x8328 . #xB0F1) + (#x832B . #xE8AB) + (#x832C . #x8FD7EA) + (#x832D . #x8FD7EB) + (#x832E . #x8FD7EC) + (#x832F . #xE8AA) + (#x8330 . #x8FD7ED) + (#x8331 . #xE8A5) + (#x8332 . #xE8A4) + (#x8333 . #x8FD7EE) + (#x8334 . #xE8A2) + (#x8335 . #xE8A1) + (#x8336 . #xC3E3) + (#x8337 . #x8FD7EF) + (#x8338 . #xC2FB) + (#x8339 . #xE8A7) + (#x833A . #x8FD7F0) + (#x833C . #x8FD7F1) + (#x833D . #x8FD7F2) + (#x8340 . #xE8A6) + (#x8342 . #x8FD7F3) + (#x8343 . #x8FD7F4) + (#x8344 . #x8FD7F5) + (#x8345 . #xE8A9) + (#x8347 . #x8FD7F6) + (#x8349 . #xC1F0) + (#x834A . #xB7D5) + (#x834D . #x8FD7F7) + (#x834E . #x8FD7F8) + (#x834F . #xB1C1) + (#x8350 . #xE8A8) + (#x8351 . #x8FD7F9) + (#x8352 . #xB9D3) + (#x8353 . #x8FD8BE) + (#x8354 . #x8FD7E3) + (#x8355 . #x8FD7FA) + (#x8356 . #x8FD7FB) + (#x8357 . #x8FD7FC) + (#x8358 . #xC1F1) + (#x8370 . #x8FD7FD) + (#x8373 . #xE8BA) + (#x8375 . #xE8BB) + (#x8377 . #xB2D9) + (#x8378 . #x8FD7FE) + (#x837B . #xB2AE) + (#x837C . #xE8B8) + (#x837D . #x8FD8A1) + (#x837F . #x8FD8A2) + (#x8380 . #x8FD8A3) + (#x8382 . #x8FD8A4) + (#x8384 . #x8FD8A5) + (#x8385 . #xE8AE) + (#x8386 . #x8FD8A6) + (#x8387 . #xE8B6) + (#x8389 . #xE8BD) + (#x838A . #xE8B7) + (#x838D . #x8FD8A7) + (#x838E . #xE8B5) + (#x8392 . #x8FD8A8) + (#x8393 . #xE7F6) + (#x8394 . #x8FD8A9) + (#x8395 . #x8FD8AA) + (#x8396 . #xE8B3) + (#x8398 . #x8FD8AB) + (#x8399 . #x8FD8AC) + (#x839A . #xE8AF) + (#x839B . #x8FD8AD) + (#x839C . #x8FD8AE) + (#x839D . #x8FD8AF) + (#x839E . #xB4D0) + (#x839F . #xE8B1) + (#x83A0 . #xE8BC) + (#x83A2 . #xE8B2) + (#x83A6 . #x8FD8B0) + (#x83A7 . #x8FD8B1) + (#x83A8 . #xE8BE) + (#x83A9 . #x8FD8B2) + (#x83AA . #xE8B0) + (#x83AB . #xC7FC) + (#x83AC . #x8FD8B3) + (#x83AD . #x8FD8CC) + (#x83B1 . #xCDE9) + (#x83B5 . #xE8B9) + (#x83BD . #xE8CF) + (#x83BE . #x8FD8B4) + (#x83BF . #x8FD8B5) + (#x83C0 . #x8FD8B6) + (#x83C1 . #xE8C7) + (#x83C5 . #xBFFB) + (#x83C7 . #x8FD8B7) + (#x83C9 . #x8FD8B8) + (#x83CA . #xB5C6) + (#x83CC . #xB6DD) + (#x83CE . #xE8C2) + (#x83CF . #x8FD8B9) + (#x83D0 . #x8FD8BA) + (#x83D1 . #x8FD8BB) + (#x83D3 . #xB2DB) + (#x83D4 . #x8FD8BC) + (#x83D6 . #xBED4) + (#x83D8 . #xE8C5) + (#x83DC . #xBADA) + (#x83DD . #x8FD8BD) + (#x83DF . #xC5D1) + (#x83E0 . #xE8CA) + (#x83E8 . #x8FD8BF) + (#x83E9 . #xCAEE) + (#x83EA . #x8FD8C0) + (#x83EB . #xE8C1) + (#x83EF . #xB2DA) + (#x83F0 . #xB8D6) + (#x83F1 . #xC9A9) + (#x83F2 . #xE8CB) + (#x83F4 . #xE8BF) + (#x83F6 . #x8FD8C1) + (#x83F7 . #xE8C8) + (#x83F8 . #x8FD8C2) + (#x83F9 . #x8FD8C3) + (#x83FB . #xE8D2) + (#x83FC . #x8FD8C4) + (#x83FD . #xE8C3) + (#x8401 . #x8FD8C5) + (#x8403 . #xE8C4) + (#x8404 . #xC6BA) + (#x8406 . #x8FD8C6) + (#x8407 . #xE8C9) + (#x840A . #x8FD8C7) + (#x840B . #xE8C6) + (#x840C . #xCBA8) + (#x840D . #xE8CC) + (#x840E . #xB0E0) + (#x840F . #x8FD8C8) + (#x8411 . #x8FD8C9) + (#x8413 . #xE8C0) + (#x8415 . #x8FD8CA) + (#x8419 . #x8FD8CB) + (#x8420 . #xE8CE) + (#x8422 . #xE8CD) + (#x8429 . #xC7EB) + (#x842A . #xE8D4) + (#x842C . #xE8DF) + (#x842F . #x8FD8CD) + (#x8431 . #xB3FE) + (#x8435 . #xE8E2) + (#x8438 . #xE8D0) + (#x8439 . #x8FD8CE) + (#x843C . #xE8D5) + (#x843D . #xCDEE) + (#x8445 . #x8FD8CF) + (#x8446 . #xE8DE) + (#x8447 . #x8FD8D0) + (#x8448 . #x8FD8D1) + (#x8449 . #xCDD5) + (#x844A . #x8FD8D2) + (#x844D . #x8FD8D3) + (#x844E . #xCEAA) + (#x844F . #x8FD8D4) + (#x8451 . #x8FD8D5) + (#x8452 . #x8FD8D6) + (#x8456 . #x8FD8D7) + (#x8457 . #xC3F8) + (#x8458 . #x8FD8D8) + (#x8459 . #x8FD8D9) + (#x845A . #x8FD8DA) + (#x845B . #xB3EB) + (#x845C . #x8FD8DB) + (#x8460 . #x8FD8DC) + (#x8461 . #xC9F2) + (#x8462 . #xE8E4) + (#x8463 . #xC6A1) + (#x8464 . #x8FD8DD) + (#x8465 . #x8FD8DE) + (#x8466 . #xB0B1) + (#x8467 . #x8FD8DF) + (#x8469 . #xE8DD) + (#x846A . #x8FD8E0) + (#x846B . #xE8D9) + (#x846C . #xC1F2) + (#x846D . #xE8D3) + (#x846E . #xE8DB) + (#x846F . #xE8E0) + (#x8470 . #x8FD8E1) + (#x8471 . #xC7AC) + (#x8473 . #x8FD8E2) + (#x8474 . #x8FD8E3) + (#x8475 . #xB0AA) + (#x8476 . #x8FD8E4) + (#x8477 . #xE8D8) + (#x8478 . #x8FD8E5) + (#x8479 . #xE8E1) + (#x847A . #xC9F8) + (#x847C . #x8FD8E6) + (#x847D . #x8FD8E7) + (#x8481 . #x8FD8E8) + (#x8482 . #xE8DC) + (#x8484 . #xE8D7) + (#x8485 . #x8FD8E9) + (#x848B . #xBED5) + (#x8490 . #xBDAF) + (#x8492 . #x8FD8EA) + (#x8493 . #x8FD8EB) + (#x8494 . #xBCAC) + (#x8495 . #x8FD8EC) + (#x8499 . #xCCD8) + (#x849C . #xC9C7) + (#x849E . #x8FD8ED) + (#x849F . #xE8E7) + (#x84A1 . #xE8F0) + (#x84A6 . #x8FD8EE) + (#x84A8 . #x8FD8EF) + (#x84A9 . #x8FD8F0) + (#x84AA . #x8FD8F1) + (#x84AD . #xE8DA) + (#x84AF . #x8FD8F2) + (#x84B1 . #x8FD8F3) + (#x84B2 . #xB3F7) + (#x84B4 . #x8FD8F4) + (#x84B8 . #xBEF8) + (#x84B9 . #xE8E5) + (#x84BA . #x8FD8F5) + (#x84BB . #xE8EA) + (#x84BC . #xC1F3) + (#x84BD . #x8FD8F6) + (#x84BE . #x8FD8F7) + (#x84BF . #xE8E6) + (#x84C0 . #x8FD8F8) + (#x84C1 . #xE8ED) + (#x84C2 . #x8FD8F9) + (#x84C4 . #xC3DF) + (#x84C6 . #xE8EE) + (#x84C7 . #x8FD8FA) + (#x84C8 . #x8FD8FB) + (#x84C9 . #xCDD6) + (#x84CA . #xE8E3) + (#x84CB . #xB3B8) + (#x84CC . #x8FD8FC) + (#x84CD . #xE8E9) + (#x84CF . #x8FD8FD) + (#x84D0 . #xE8EC) + (#x84D1 . #xCCAC) + (#x84D3 . #x8FD8FE) + (#x84D6 . #xE8EF) + (#x84D9 . #xE8E8) + (#x84DA . #xE8EB) + (#x84DC . #x8FD9A1) + (#x84E7 . #x8FD9A2) + (#x84EA . #x8FD9A3) + (#x84EC . #xCBA9) + (#x84EE . #xCFA1) + (#x84EF . #x8FD9A4) + (#x84F0 . #x8FD9A5) + (#x84F1 . #x8FD9A6) + (#x84F2 . #x8FD9A7) + (#x84F4 . #xE8F3) + (#x84F7 . #x8FD9A8) + (#x84FA . #x8FD9AA) + (#x84FB . #x8FD9AB) + (#x84FC . #xE8FA) + (#x84FD . #x8FD9AC) + (#x84FF . #xE8F2) + (#x8500 . #xBCC3) + (#x8502 . #x8FD9AD) + (#x8503 . #x8FD9AE) + (#x8506 . #xE8D1) + (#x8507 . #x8FD9AF) + (#x850C . #x8FD9B0) + (#x850E . #x8FD9B1) + (#x8510 . #x8FD9B2) + (#x8511 . #xCACE) + (#x8513 . #xCCA2) + (#x8514 . #xE8F9) + (#x8515 . #xE8F8) + (#x8517 . #xE8F4) + (#x8518 . #xE8F5) + (#x851A . #xB1B6) + (#x851C . #x8FD9B3) + (#x851E . #x8FD9B4) + (#x851F . #xE8F7) + (#x8521 . #xE8F1) + (#x8522 . #x8FD9B5) + (#x8523 . #x8FD9B6) + (#x8524 . #x8FD9B7) + (#x8525 . #x8FD9B8) + (#x8526 . #xC4D5) + (#x8527 . #x8FD9B9) + (#x852A . #x8FD9BA) + (#x852B . #x8FD9BB) + (#x852C . #xE8F6) + (#x852D . #xB0FE) + (#x852F . #x8FD9BC) + (#x8532 . #x8FD9A9) + (#x8533 . #x8FD9BD) + (#x8534 . #x8FD9BE) + (#x8535 . #xC2A2) + (#x8536 . #x8FD9BF) + (#x853D . #xCAC3) + (#x853F . #x8FD9C0) + (#x8540 . #xE8FB) + (#x8541 . #xE9A1) + (#x8543 . #xC8D9) + (#x8546 . #x8FD9C1) + (#x8548 . #xE8FE) + (#x8549 . #xBED6) + (#x854A . #xBCC9) + (#x854B . #xE9A3) + (#x854E . #xB6BE) + (#x854F . #x8FD9C2) + (#x8550 . #x8FD9C3) + (#x8551 . #x8FD9C4) + (#x8552 . #x8FD9C5) + (#x8553 . #x8FD9C6) + (#x8555 . #xE9A4) + (#x8556 . #x8FD9C7) + (#x8557 . #xC9F9) + (#x8558 . #xE8FD) + (#x8559 . #x8FD9C8) + (#x855A . #xE8D6) + (#x855C . #x8FD9C9) + (#x855D . #x8FD9CA) + (#x855E . #x8FD9CB) + (#x855F . #x8FD9CC) + (#x8560 . #x8FD9CD) + (#x8561 . #x8FD9CE) + (#x8562 . #x8FD9CF) + (#x8563 . #xE8FC) + (#x8564 . #x8FD9D0) + (#x8568 . #xCFCF) + (#x8569 . #xC6A2) + (#x856A . #xC9F3) + (#x856B . #x8FD9D1) + (#x856D . #xE9AB) + (#x856F . #x8FD9D2) + (#x8577 . #xE9B1) + (#x8579 . #x8FD9D3) + (#x857A . #x8FD9D4) + (#x857B . #x8FD9D5) + (#x857D . #x8FD9D6) + (#x857E . #xE9B2) + (#x857F . #x8FD9D7) + (#x8580 . #xE9A5) + (#x8581 . #x8FD9D8) + (#x8584 . #xC7F6) + (#x8585 . #x8FD9D9) + (#x8586 . #x8FD9DA) + (#x8587 . #xE9AF) + (#x8588 . #xE9A7) + (#x8589 . #x8FD9DB) + (#x858A . #xE9A9) + (#x858B . #x8FD9DC) + (#x858C . #x8FD9DD) + (#x858F . #x8FD9DE) + (#x8590 . #xE9B3) + (#x8591 . #xE9A8) + (#x8593 . #x8FD9DF) + (#x8594 . #xE9AC) + (#x8597 . #xB1F2) + (#x8598 . #x8FD9E0) + (#x8599 . #xC6E5) + (#x859B . #xE9AD) + (#x859C . #xE9B0) + (#x859D . #x8FD9E1) + (#x859F . #x8FD9E2) + (#x85A0 . #x8FD9E3) + (#x85A2 . #x8FD9E4) + (#x85A4 . #xE9A6) + (#x85A5 . #x8FD9E5) + (#x85A6 . #xC1A6) + (#x85A7 . #x8FD9E6) + (#x85A8 . #xE9AA) + (#x85A9 . #xBBA7) + (#x85AA . #xBFC5) + (#x85AB . #xB7B0) + (#x85AC . #xCCF4) + (#x85AD . #x8FD9F4) + (#x85AE . #xCCF9) + (#x85AF . #xBDF2) + (#x85B4 . #x8FD9E7) + (#x85B6 . #x8FD9E8) + (#x85B7 . #x8FD9E9) + (#x85B8 . #x8FD9EA) + (#x85B9 . #xE9B7) + (#x85BA . #xE9B5) + (#x85BC . #x8FD9EB) + (#x85BD . #x8FD9EC) + (#x85BE . #x8FD9ED) + (#x85BF . #x8FD9EE) + (#x85C1 . #xCFCE) + (#x85C2 . #x8FD9EF) + (#x85C7 . #x8FD9F0) + (#x85C9 . #xE9B4) + (#x85CA . #x8FD9F1) + (#x85CB . #x8FD9F2) + (#x85CD . #xCDF5) + (#x85CE . #x8FD9F3) + (#x85CF . #xE9B6) + (#x85D0 . #xE9B8) + (#x85D5 . #xE9B9) + (#x85D8 . #x8FD9F5) + (#x85DA . #x8FD9F6) + (#x85DC . #xE9BC) + (#x85DD . #xE9BA) + (#x85DF . #x8FD9F7) + (#x85E0 . #x8FD9F8) + (#x85E4 . #xC6A3) + (#x85E5 . #xE9BB) + (#x85E6 . #x8FD9F9) + (#x85E8 . #x8FD9FA) + (#x85E9 . #xC8CD) + (#x85EA . #xE9AE) + (#x85ED . #x8FD9FB) + (#x85F3 . #x8FD9FC) + (#x85F6 . #x8FD9FD) + (#x85F7 . #xBDF3) + (#x85F9 . #xE9BD) + (#x85FA . #xE9C2) + (#x85FB . #xC1F4) + (#x85FC . #x8FD9FE) + (#x85FE . #xE9C1) + (#x85FF . #x8FDAA1) + (#x8600 . #x8FDAA2) + (#x8602 . #xE9A2) + (#x8604 . #x8FDAA3) + (#x8605 . #x8FDAA4) + (#x8606 . #xE9C3) + (#x8607 . #xC1C9) + (#x860A . #xE9BE) + (#x860B . #xE9C0) + (#x860D . #x8FDAA5) + (#x860E . #x8FDAA6) + (#x8610 . #x8FDAA7) + (#x8611 . #x8FDAA8) + (#x8612 . #x8FDAA9) + (#x8613 . #xE9BF) + (#x8616 . #xDDB1) + (#x8617 . #xDDA2) + (#x8618 . #x8FDAAA) + (#x8619 . #x8FDAAB) + (#x861A . #xE9C5) + (#x861B . #x8FDAAC) + (#x861E . #x8FDAAD) + (#x8621 . #x8FDAAE) + (#x8622 . #xE9C4) + (#x8627 . #x8FDAAF) + (#x8629 . #x8FDAB0) + (#x862D . #xCDF6) + (#x862F . #xE2BC) + (#x8630 . #xE9C6) + (#x8636 . #x8FDAB1) + (#x8638 . #x8FDAB2) + (#x863A . #x8FDAB3) + (#x863C . #x8FDAB4) + (#x863D . #x8FDAB5) + (#x863F . #xE9C7) + (#x8640 . #x8FDAB6) + (#x8641 . #x8FB8E6) + (#x8642 . #x8FDAB7) + (#x8646 . #x8FDAB8) + (#x864D . #xE9C8) + (#x864E . #xB8D7) + (#x8650 . #xB5D4) + (#x8652 . #x8FDAB9) + (#x8653 . #x8FDABA) + (#x8654 . #xE9CA) + (#x8655 . #xD1DD) + (#x8656 . #x8FDABB) + (#x8657 . #x8FDABC) + (#x8658 . #x8FDABD) + (#x8659 . #x8FDABE) + (#x865A . #xB5F5) + (#x865C . #xCEBA) + (#x865D . #x8FDABF) + (#x865E . #xB6F3) + (#x865F . #xE9CB) + (#x8660 . #x8FDAC0) + (#x8661 . #x8FDAC1) + (#x8662 . #x8FDAC2) + (#x8663 . #x8FDAC3) + (#x8664 . #x8FDAC4) + (#x8667 . #xE9CC) + (#x8669 . #x8FDAC5) + (#x866B . #xC3EE) + (#x866C . #x8FDAC6) + (#x866F . #x8FDAC7) + (#x8671 . #xE9CD) + (#x8675 . #x8FDAC8) + (#x8676 . #x8FDAC9) + (#x8677 . #x8FDACA) + (#x8679 . #xC6FA) + (#x867A . #x8FDACB) + (#x867B . #xB0BA) + (#x8688 . #x8FDAED) + (#x868A . #xB2E3) + (#x868B . #xE9D2) + (#x868C . #xE9D3) + (#x868D . #x8FDACC) + (#x8691 . #x8FDACD) + (#x8693 . #xE9CE) + (#x8695 . #xBBBD) + (#x8696 . #x8FDACE) + (#x8698 . #x8FDACF) + (#x869A . #x8FDAD0) + (#x869C . #x8FDAD1) + (#x86A1 . #x8FDAD2) + (#x86A3 . #xE9CF) + (#x86A4 . #xC7C2) + (#x86A6 . #x8FDAD3) + (#x86A7 . #x8FDAD4) + (#x86A8 . #x8FDAD5) + (#x86A9 . #xE9D0) + (#x86AA . #xE9D1) + (#x86AB . #xE9DB) + (#x86AD . #x8FDAD6) + (#x86AF . #xE9D5) + (#x86B0 . #xE9D8) + (#x86B1 . #x8FDAD7) + (#x86B3 . #x8FDAD8) + (#x86B4 . #x8FDAD9) + (#x86B5 . #x8FDADA) + (#x86B6 . #xE9D4) + (#x86B7 . #x8FDADB) + (#x86B8 . #x8FDADC) + (#x86B9 . #x8FDADD) + (#x86BF . #x8FDADE) + (#x86C0 . #x8FDADF) + (#x86C1 . #x8FDAE0) + (#x86C3 . #x8FDAE1) + (#x86C4 . #xE9D6) + (#x86C5 . #x8FDAE2) + (#x86C6 . #xE9D7) + (#x86C7 . #xBCD8) + (#x86C9 . #xE9D9) + (#x86CB . #xC3C1) + (#x86CD . #xB7D6) + (#x86CE . #xB3C2) + (#x86D1 . #x8FDAE3) + (#x86D2 . #x8FDAE4) + (#x86D4 . #xE9DC) + (#x86D5 . #x8FDAE5) + (#x86D7 . #x8FDAE6) + (#x86D9 . #xB3BF) + (#x86DA . #x8FDAE7) + (#x86DB . #xE9E1) + (#x86DC . #x8FDAE8) + (#x86DE . #xE9DD) + (#x86DF . #xE9E0) + (#x86E0 . #x8FDAE9) + (#x86E3 . #x8FDAEA) + (#x86E4 . #xC8BA) + (#x86E5 . #x8FDAEB) + (#x86E7 . #x8FDAEC) + (#x86E9 . #xE9DE) + (#x86EC . #xE9DF) + (#x86ED . #xC9C8) + (#x86EE . #xC8DA) + (#x86EF . #xE9E2) + (#x86F8 . #xC2FD) + (#x86F9 . #xE9EC) + (#x86FA . #x8FDAEE) + (#x86FB . #xE9E8) + (#x86FC . #x8FDAEF) + (#x86FD . #x8FDAF0) + (#x86FE . #xB2EB) + (#x8700 . #xE9E6) + (#x8702 . #xCBAA) + (#x8703 . #xE9E7) + (#x8704 . #x8FDAF1) + (#x8705 . #x8FDAF2) + (#x8706 . #xE9E4) + (#x8707 . #x8FDAF3) + (#x8708 . #xE9E5) + (#x8709 . #xE9EA) + (#x870A . #xE9ED) + (#x870B . #x8FDAF4) + (#x870D . #xE9EB) + (#x870E . #x8FDAF5) + (#x870F . #x8FDAF6) + (#x8710 . #x8FDAF7) + (#x8711 . #xE9E9) + (#x8712 . #xE9E3) + (#x8713 . #x8FDAF8) + (#x8714 . #x8FDAF9) + (#x8718 . #xC3D8) + (#x8719 . #x8FDAFA) + (#x871A . #xE9F4) + (#x871C . #xCCAA) + (#x871E . #x8FDAFB) + (#x871F . #x8FDAFC) + (#x8721 . #x8FDAFD) + (#x8723 . #x8FDAFE) + (#x8725 . #xE9F2) + (#x8728 . #x8FDBA1) + (#x8729 . #xE9F3) + (#x872E . #x8FDBA2) + (#x872F . #x8FDBA3) + (#x8731 . #x8FDBA4) + (#x8732 . #x8FDBA5) + (#x8734 . #xE9EE) + (#x8737 . #xE9F0) + (#x8739 . #x8FDBA6) + (#x873A . #x8FDBA7) + (#x873B . #xE9F1) + (#x873C . #x8FDBA8) + (#x873D . #x8FDBA9) + (#x873E . #x8FDBAA) + (#x873F . #xE9EF) + (#x8740 . #x8FDBAB) + (#x8743 . #x8FDBAC) + (#x8745 . #x8FDBAD) + (#x8749 . #xC0E6) + (#x874B . #xCFB9) + (#x874C . #xE9F8) + (#x874D . #x8FDBAE) + (#x874E . #xE9F9) + (#x8753 . #xEAA1) + (#x8755 . #xBFAA) + (#x8757 . #xE9FB) + (#x8758 . #x8FDBAF) + (#x8759 . #xE9FE) + (#x875D . #x8FDBB0) + (#x875F . #xE9F6) + (#x8760 . #xE9F5) + (#x8761 . #x8FDBB1) + (#x8763 . #xEAA2) + (#x8764 . #x8FDBB2) + (#x8765 . #x8FDBB3) + (#x8766 . #xB2DC) + (#x8768 . #xE9FC) + (#x876A . #xEAA3) + (#x876E . #xE9FD) + (#x876F . #x8FDBB4) + (#x8771 . #x8FDBB5) + (#x8772 . #x8FDBB6) + (#x8774 . #xE9FA) + (#x8776 . #xC4B3) + (#x8778 . #xE9F7) + (#x877B . #x8FDBB7) + (#x877F . #xC7E8) + (#x8782 . #xEAA7) + (#x8783 . #x8FDBB8) + (#x8784 . #x8FDBB9) + (#x8785 . #x8FDBBA) + (#x8786 . #x8FDBBB) + (#x8787 . #x8FDBBC) + (#x8788 . #x8FDBBD) + (#x8789 . #x8FDBBE) + (#x878B . #x8FDBBF) + (#x878C . #x8FDBC0) + (#x878D . #xCDBB) + (#x8790 . #x8FDBC1) + (#x8793 . #x8FDBC2) + (#x8795 . #x8FDBC3) + (#x8797 . #x8FDBC4) + (#x8798 . #x8FDBC5) + (#x8799 . #x8FDBC6) + (#x879E . #x8FDBC7) + (#x879F . #xEAA6) + (#x87A0 . #x8FDBC8) + (#x87A2 . #xEAA5) + (#x87A3 . #x8FDBC9) + (#x87A7 . #x8FDBCA) + (#x87AB . #xEAAE) + (#x87AC . #x8FDBCB) + (#x87AD . #x8FDBCC) + (#x87AE . #x8FDBCD) + (#x87AF . #xEAA8) + (#x87B1 . #x8FDBCE) + (#x87B3 . #xEAB0) + (#x87B5 . #x8FDBCF) + (#x87BA . #xCDE6) + (#x87BB . #xEAB3) + (#x87BD . #xEAAA) + (#x87BE . #x8FDBD0) + (#x87BF . #x8FDBD1) + (#x87C0 . #xEAAB) + (#x87C1 . #x8FDBD2) + (#x87C4 . #xEAAF) + (#x87C6 . #xEAB2) + (#x87C7 . #xEAB1) + (#x87C8 . #x8FDBD3) + (#x87C9 . #x8FDBD4) + (#x87CA . #x8FDBD5) + (#x87CB . #xEAA9) + (#x87CE . #x8FDBD6) + (#x87D0 . #xEAAC) + (#x87D2 . #xEABD) + (#x87D5 . #x8FDBD7) + (#x87D6 . #x8FDBD8) + (#x87D9 . #x8FDBD9) + (#x87DA . #x8FDBDA) + (#x87DC . #x8FDBDB) + (#x87DF . #x8FDBDC) + (#x87E0 . #xEAB6) + (#x87E2 . #x8FDBDD) + (#x87E3 . #x8FDBDE) + (#x87E4 . #x8FDBDF) + (#x87EA . #x8FDBE0) + (#x87EB . #x8FDBE1) + (#x87ED . #x8FDBE2) + (#x87EF . #xEAB4) + (#x87F1 . #x8FDBE3) + (#x87F2 . #xEAB5) + (#x87F3 . #x8FDBE4) + (#x87F6 . #xEABA) + (#x87F7 . #xEABB) + (#x87F8 . #x8FDBE5) + (#x87F9 . #xB3AA) + (#x87FA . #x8FDBE6) + (#x87FB . #xB5C2) + (#x87FE . #xEAB9) + (#x87FF . #x8FDBE7) + (#x8801 . #x8FDBE8) + (#x8803 . #x8FDBE9) + (#x8805 . #xEAA4) + (#x8806 . #x8FDBEA) + (#x8809 . #x8FDBEB) + (#x880A . #x8FDBEC) + (#x880B . #x8FDBED) + (#x880D . #xEAB8) + (#x880E . #xEABC) + (#x880F . #xEAB7) + (#x8810 . #x8FDBEE) + (#x8811 . #xEABE) + (#x8812 . #x8FDBF0) + (#x8813 . #x8FDBF1) + (#x8814 . #x8FDBF2) + (#x8815 . #xEAC0) + (#x8816 . #xEABF) + (#x8818 . #x8FDBF3) + (#x8819 . #x8FDBEF) + (#x881A . #x8FDBF4) + (#x881B . #x8FDBF5) + (#x881C . #x8FDBF6) + (#x881E . #x8FDBF7) + (#x881F . #x8FDBF8) + (#x8821 . #xEAC2) + (#x8822 . #xEAC1) + (#x8823 . #xE9DA) + (#x8827 . #xEAC6) + (#x8828 . #x8FDBF9) + (#x882D . #x8FDBFA) + (#x882E . #x8FDBFB) + (#x8830 . #x8FDBFC) + (#x8831 . #xEAC3) + (#x8832 . #x8FDBFD) + (#x8835 . #x8FDBFE) + (#x8836 . #xEAC4) + (#x8839 . #xEAC5) + (#x883A . #x8FDCA1) + (#x883B . #xEAC7) + (#x883C . #x8FDCA2) + (#x8840 . #xB7EC) + (#x8841 . #x8FDCA3) + (#x8842 . #xEAC9) + (#x8843 . #x8FDCA4) + (#x8844 . #xEAC8) + (#x8845 . #x8FDCA5) + (#x8846 . #xBDB0) + (#x8848 . #x8FDCA6) + (#x8849 . #x8FDCA7) + (#x884A . #x8FDCA8) + (#x884B . #x8FDCA9) + (#x884C . #xB9D4) + (#x884D . #xDEA7) + (#x884E . #x8FDCAA) + (#x8851 . #x8FDCAB) + (#x8852 . #xEACA) + (#x8853 . #xBDD1) + (#x8855 . #x8FDCAC) + (#x8856 . #x8FDCAD) + (#x8857 . #xB3B9) + (#x8858 . #x8FDCAE) + (#x8859 . #xEACB) + (#x885A . #x8FDCAF) + (#x885B . #xB1D2) + (#x885C . #x8FDCB0) + (#x885D . #xBED7) + (#x885E . #xEACC) + (#x885F . #x8FDCB1) + (#x8860 . #x8FDCB2) + (#x8861 . #xB9D5) + (#x8862 . #xEACD) + (#x8863 . #xB0E1) + (#x8864 . #x8FDCB3) + (#x8868 . #xC9BD) + (#x8869 . #x8FDCB4) + (#x886B . #xEACE) + (#x8870 . #xBFEA) + (#x8871 . #x8FDCB5) + (#x8872 . #xEAD5) + (#x8875 . #xEAD2) + (#x8877 . #xC3EF) + (#x8879 . #x8FDCB6) + (#x887B . #x8FDCB7) + (#x887D . #xEAD3) + (#x887E . #xEAD0) + (#x887F . #xB6DE) + (#x8880 . #x8FDCB8) + (#x8881 . #xEACF) + (#x8882 . #xEAD6) + (#x8888 . #xB7B6) + (#x888B . #xC2DE) + (#x888D . #xEADC) + (#x8892 . #xEAD8) + (#x8896 . #xC2B5) + (#x8897 . #xEAD7) + (#x8898 . #x8FDCB9) + (#x8899 . #xEADA) + (#x889A . #x8FDCBA) + (#x889B . #x8FDCBB) + (#x889C . #x8FDCBC) + (#x889E . #xEAD1) + (#x889F . #x8FDCBD) + (#x88A0 . #x8FDCBE) + (#x88A2 . #xEADB) + (#x88A4 . #xEADD) + (#x88A8 . #x8FDCBF) + (#x88AA . #x8FDCC0) + (#x88AB . #xC8EF) + (#x88AE . #xEAD9) + (#x88B0 . #xEADE) + (#x88B1 . #xEAE0) + (#x88B4 . #xB8D3) + (#x88B5 . #xEAD4) + (#x88B7 . #xB0C1) + (#x88BA . #x8FDCC1) + (#x88BD . #x8FDCC2) + (#x88BE . #x8FDCC3) + (#x88BF . #xEADF) + (#x88C0 . #x8FDCC4) + (#x88C1 . #xBADB) + (#x88C2 . #xCEF6) + (#x88C3 . #xEAE1) + (#x88C4 . #xEAE2) + (#x88C5 . #xC1F5) + (#x88CA . #x8FDCC5) + (#x88CB . #x8FDCC6) + (#x88CC . #x8FDCC7) + (#x88CD . #x8FDCC8) + (#x88CE . #x8FDCC9) + (#x88CF . #xCEA2) + (#x88D1 . #x8FDCCA) + (#x88D2 . #x8FDCCB) + (#x88D3 . #x8FDCCC) + (#x88D4 . #xEAE3) + (#x88D5 . #xCDB5) + (#x88D8 . #xEAE4) + (#x88D9 . #xEAE5) + (#x88DB . #x8FDCCD) + (#x88DC . #xCAE4) + (#x88DD . #xEAE6) + (#x88DE . #x8FDCCE) + (#x88DF . #xBAC0) + (#x88E1 . #xCEA3) + (#x88E7 . #x8FDCCF) + (#x88E8 . #xEAEB) + (#x88EF . #x8FDCD0) + (#x88F0 . #x8FDCD1) + (#x88F1 . #x8FDCD2) + (#x88F2 . #xEAEC) + (#x88F3 . #xBED8) + (#x88F4 . #xEAEA) + (#x88F5 . #x8FDCD3) + (#x88F7 . #x8FDCD4) + (#x88F8 . #xCDE7) + (#x88F9 . #xEAE7) + (#x88FC . #xEAE9) + (#x88FD . #xC0BD) + (#x88FE . #xBFFE) + (#x8901 . #x8FDCD5) + (#x8902 . #xEAE8) + (#x8904 . #xEAED) + (#x8906 . #x8FDCD6) + (#x8907 . #xCAA3) + (#x890A . #xEAEF) + (#x890C . #xEAEE) + (#x890D . #x8FDCD7) + (#x890E . #x8FDCD8) + (#x890F . #x8FDCD9) + (#x8910 . #xB3EC) + (#x8912 . #xCBAB) + (#x8913 . #xEAF0) + (#x8915 . #x8FDCDA) + (#x8916 . #x8FDCDB) + (#x8918 . #x8FDCDC) + (#x8919 . #x8FDCDD) + (#x891A . #x8FDCDE) + (#x891C . #x8FDCDF) + (#x891D . #xEAFC) + (#x891E . #xEAF2) + (#x8920 . #x8FDCE0) + (#x8925 . #xEAF3) + (#x8926 . #x8FDCE1) + (#x8927 . #x8FDCE2) + (#x8928 . #x8FDCE3) + (#x892A . #xEAF4) + (#x892B . #xEAF5) + (#x8930 . #x8FDCE4) + (#x8931 . #x8FDCE5) + (#x8932 . #x8FDCE6) + (#x8935 . #x8FDCE7) + (#x8936 . #xEAF9) + (#x8938 . #xEAFA) + (#x8939 . #x8FDCE8) + (#x893A . #x8FDCE9) + (#x893B . #xEAF8) + (#x893E . #x8FDCEA) + (#x8940 . #x8FDCEB) + (#x8941 . #xEAF6) + (#x8942 . #x8FDCEC) + (#x8943 . #xEAF1) + (#x8944 . #xEAF7) + (#x8945 . #x8FDCED) + (#x8946 . #x8FDCEE) + (#x8949 . #x8FDCEF) + (#x894C . #xEAFB) + (#x894D . #xF0B7) + (#x894F . #x8FDCF0) + (#x8952 . #x8FDCF1) + (#x8956 . #xB2A8) + (#x8957 . #x8FDCF2) + (#x895A . #x8FDCF3) + (#x895B . #x8FDCF4) + (#x895C . #x8FDCF5) + (#x895E . #xEAFE) + (#x895F . #xB6DF) + (#x8960 . #xEAFD) + (#x8961 . #x8FDCF6) + (#x8962 . #x8FDCF7) + (#x8963 . #x8FDCF8) + (#x8964 . #xEBA2) + (#x8966 . #xEBA1) + (#x896A . #xEBA4) + (#x896B . #x8FDCF9) + (#x896D . #xEBA3) + (#x896E . #x8FDCFA) + (#x896F . #xEBA5) + (#x8970 . #x8FDCFB) + (#x8972 . #xBDB1) + (#x8973 . #x8FDCFC) + (#x8974 . #xEBA6) + (#x8975 . #x8FDCFD) + (#x8977 . #xEBA7) + (#x897A . #x8FDCFE) + (#x897B . #x8FDDA1) + (#x897C . #x8FDDA2) + (#x897D . #x8FDDA3) + (#x897E . #xEBA8) + (#x897F . #xC0BE) + (#x8981 . #xCDD7) + (#x8983 . #xEBA9) + (#x8986 . #xCAA4) + (#x8987 . #xC7C6) + (#x8988 . #xEBAA) + (#x8989 . #x8FDDA4) + (#x898A . #xEBAB) + (#x898B . #xB8AB) + (#x898D . #x8FDDA5) + (#x898F . #xB5AC) + (#x8990 . #x8FDDA6) + (#x8993 . #xEBAC) + (#x8994 . #x8FDDA7) + (#x8995 . #x8FDDA8) + (#x8996 . #xBBEB) + (#x8997 . #xC7C1) + (#x8998 . #xEBAD) + (#x899A . #xB3D0) + (#x899B . #x8FDDA9) + (#x899C . #x8FDDAA) + (#x899F . #x8FDDAB) + (#x89A0 . #x8FDDAC) + (#x89A1 . #xEBAE) + (#x89A5 . #x8FDDAD) + (#x89A6 . #xEBB0) + (#x89A7 . #xCDF7) + (#x89A9 . #xEBAF) + (#x89AA . #xBFC6) + (#x89AC . #xEBB1) + (#x89AF . #xEBB2) + (#x89B0 . #x8FDDAE) + (#x89B2 . #xEBB3) + (#x89B3 . #xB4D1) + (#x89B4 . #x8FDDAF) + (#x89B5 . #x8FDDB0) + (#x89B6 . #x8FDDB1) + (#x89B7 . #x8FDDB2) + (#x89BA . #xEBB4) + (#x89BC . #x8FDDB3) + (#x89BD . #xEBB5) + (#x89BF . #xEBB6) + (#x89C0 . #xEBB7) + (#x89D2 . #xB3D1) + (#x89D4 . #x8FDDB4) + (#x89D5 . #x8FDDB5) + (#x89D6 . #x8FDDB6) + (#x89D7 . #x8FDDB7) + (#x89D8 . #x8FDDB8) + (#x89DA . #xEBB8) + (#x89DC . #xEBB9) + (#x89DD . #xEBBA) + (#x89E3 . #xB2F2) + (#x89E5 . #x8FDDB9) + (#x89E6 . #xBFA8) + (#x89E7 . #xEBBB) + (#x89E9 . #x8FDDBA) + (#x89EB . #x8FDDBB) + (#x89ED . #x8FDDBC) + (#x89F1 . #x8FDDBD) + (#x89F3 . #x8FDDBE) + (#x89F4 . #xEBBC) + (#x89F6 . #x8FDDBF) + (#x89F8 . #xEBBD) + (#x89F9 . #x8FDDC0) + (#x89FD . #x8FDDC1) + (#x89FF . #x8FDDC2) + (#x8A00 . #xB8C0) + (#x8A02 . #xC4FB) + (#x8A03 . #xEBBE) + (#x8A04 . #x8FDDC3) + (#x8A05 . #x8FDDC4) + (#x8A07 . #x8FDDC5) + (#x8A08 . #xB7D7) + (#x8A0A . #xBFD6) + (#x8A0C . #xEBC1) + (#x8A0E . #xC6A4) + (#x8A0F . #x8FDDC6) + (#x8A10 . #xEBC0) + (#x8A11 . #x8FDDC7) + (#x8A12 . #x8FDDC8) + (#x8A13 . #xB7B1) + (#x8A14 . #x8FDDC9) + (#x8A15 . #x8FDDCA) + (#x8A16 . #xEBBF) + (#x8A17 . #xC2F7) + (#x8A18 . #xB5AD) + (#x8A1B . #xEBC2) + (#x8A1D . #xEBC3) + (#x8A1E . #x8FDDCB) + (#x8A1F . #xBED9) + (#x8A20 . #x8FDDCC) + (#x8A22 . #x8FDDCD) + (#x8A23 . #xB7ED) + (#x8A24 . #x8FDDCE) + (#x8A25 . #xEBC4) + (#x8A26 . #x8FDDCF) + (#x8A2A . #xCBAC) + (#x8A2B . #x8FDDD0) + (#x8A2C . #x8FDDD1) + (#x8A2D . #xC0DF) + (#x8A2F . #x8FDDD2) + (#x8A31 . #xB5F6) + (#x8A33 . #xCCF5) + (#x8A34 . #xC1CA) + (#x8A35 . #x8FDDD3) + (#x8A36 . #xEBC5) + (#x8A37 . #x8FDDD4) + (#x8A3A . #xBFC7) + (#x8A3B . #xC3F0) + (#x8A3C . #xBEDA) + (#x8A3D . #x8FDDD5) + (#x8A3E . #x8FDDD6) + (#x8A40 . #x8FDDD7) + (#x8A41 . #xEBC6) + (#x8A43 . #x8FDDD8) + (#x8A45 . #x8FDDD9) + (#x8A46 . #xEBC9) + (#x8A47 . #x8FDDDA) + (#x8A48 . #xEBCA) + (#x8A49 . #x8FDDDB) + (#x8A4D . #x8FDDDC) + (#x8A4E . #x8FDDDD) + (#x8A50 . #xBABE) + (#x8A51 . #xC2C2) + (#x8A52 . #xEBC8) + (#x8A53 . #x8FDDDE) + (#x8A54 . #xBEDB) + (#x8A55 . #xC9BE) + (#x8A56 . #x8FDDDF) + (#x8A57 . #x8FDDE0) + (#x8A58 . #x8FDDE1) + (#x8A5B . #xEBC7) + (#x8A5C . #x8FDDE2) + (#x8A5D . #x8FDDE3) + (#x8A5E . #xBBEC) + (#x8A60 . #xB1D3) + (#x8A61 . #x8FDDE4) + (#x8A62 . #xEBCE) + (#x8A63 . #xB7D8) + (#x8A65 . #x8FDDE5) + (#x8A66 . #xBBEE) + (#x8A67 . #x8FDDE6) + (#x8A69 . #xBBED) + (#x8A6B . #xCFCD) + (#x8A6C . #xEBCD) + (#x8A6D . #xEBCC) + (#x8A6E . #xC1A7) + (#x8A70 . #xB5CD) + (#x8A71 . #xCFC3) + (#x8A72 . #xB3BA) + (#x8A73 . #xBEDC) + (#x8A75 . #x8FDDE7) + (#x8A76 . #x8FDDE8) + (#x8A77 . #x8FDDE9) + (#x8A79 . #x8FDDEA) + (#x8A7A . #x8FDDEB) + (#x8A7B . #x8FDDEC) + (#x8A7C . #xEBCB) + (#x8A7E . #x8FDDED) + (#x8A7F . #x8FDDEE) + (#x8A80 . #x8FDDEF) + (#x8A82 . #xEBD0) + (#x8A83 . #x8FDDF0) + (#x8A84 . #xEBD1) + (#x8A85 . #xEBCF) + (#x8A86 . #x8FDDF1) + (#x8A87 . #xB8D8) + (#x8A89 . #xCDC0) + (#x8A8B . #x8FDDF2) + (#x8A8C . #xBBEF) + (#x8A8D . #xC7A7) + (#x8A8F . #x8FDDF3) + (#x8A90 . #x8FDDF4) + (#x8A91 . #xEBD4) + (#x8A92 . #x8FDDF5) + (#x8A93 . #xC0C0) + (#x8A95 . #xC3C2) + (#x8A96 . #x8FDDF6) + (#x8A97 . #x8FDDF7) + (#x8A98 . #xCDB6) + (#x8A99 . #x8FDDF8) + (#x8A9A . #xEBD7) + (#x8A9E . #xB8EC) + (#x8A9F . #x8FDDF9) + (#x8AA0 . #xC0BF) + (#x8AA1 . #xEBD3) + (#x8AA3 . #xEBD8) + (#x8AA4 . #xB8ED) + (#x8AA5 . #xEBD5) + (#x8AA6 . #xEBD6) + (#x8AA7 . #x8FDDFA) + (#x8AA8 . #xEBD2) + (#x8AA9 . #x8FDDFB) + (#x8AAC . #xC0E2) + (#x8AAD . #xC6C9) + (#x8AAE . #x8FDDFC) + (#x8AAF . #x8FDDFD) + (#x8AB0 . #xC3AF) + (#x8AB2 . #xB2DD) + (#x8AB3 . #x8FDDFE) + (#x8AB6 . #x8FDEA1) + (#x8AB7 . #x8FDEA2) + (#x8AB9 . #xC8F0) + (#x8ABB . #x8FDEA3) + (#x8ABC . #xB5C3) + (#x8ABE . #x8FDEA4) + (#x8ABF . #xC4B4) + (#x8AC2 . #xEBDB) + (#x8AC3 . #x8FDEA5) + (#x8AC4 . #xEBD9) + (#x8AC6 . #x8FDEA6) + (#x8AC7 . #xC3CC) + (#x8AC8 . #x8FDEA7) + (#x8AC9 . #x8FDEA8) + (#x8ACA . #x8FDEA9) + (#x8ACB . #xC0C1) + (#x8ACC . #xB4D2) + (#x8ACD . #xEBDA) + (#x8ACF . #xBFDB) + (#x8AD1 . #x8FDEAA) + (#x8AD2 . #xCECA) + (#x8AD3 . #x8FDEAB) + (#x8AD4 . #x8FDEAC) + (#x8AD5 . #x8FDEAD) + (#x8AD6 . #xCFC0) + (#x8AD7 . #x8FDEAE) + (#x8ADA . #xEBDC) + (#x8ADB . #xEBE7) + (#x8ADC . #xC4B5) + (#x8ADD . #x8FDEAF) + (#x8ADE . #xEBE6) + (#x8ADF . #x8FDEB0) + (#x8AE0 . #xEBE3) + (#x8AE1 . #xEBEB) + (#x8AE2 . #xEBE4) + (#x8AE4 . #xEBE0) + (#x8AE6 . #xC4FC) + (#x8AE7 . #xEBDF) + (#x8AEB . #xEBDD) + (#x8AEC . #x8FDEB1) + (#x8AED . #xCDA1) + (#x8AEE . #xBBF0) + (#x8AF0 . #x8FDEB2) + (#x8AF1 . #xEBE1) + (#x8AF3 . #xEBDE) + (#x8AF4 . #x8FDEB3) + (#x8AF5 . #x8FDEB4) + (#x8AF6 . #x8FDEB5) + (#x8AF7 . #xEBE5) + (#x8AF8 . #xBDF4) + (#x8AFA . #xB8C1) + (#x8AFC . #x8FDEB6) + (#x8AFE . #xC2FA) + (#x8AFF . #x8FDEB7) + (#x8B00 . #xCBC5) + (#x8B01 . #xB1DA) + (#x8B02 . #xB0E2) + (#x8B04 . #xC6A5) + (#x8B05 . #x8FDEB8) + (#x8B06 . #x8FDEB9) + (#x8B07 . #xEBE9) + (#x8B0A . #x8FDEBF) + (#x8B0B . #x8FDEBA) + (#x8B0C . #xEBE8) + (#x8B0E . #xC6E6) + (#x8B10 . #xEBED) + (#x8B11 . #x8FDEBB) + (#x8B14 . #xEBE2) + (#x8B16 . #xEBEC) + (#x8B17 . #xEBEE) + (#x8B19 . #xB8AC) + (#x8B1A . #xEBEA) + (#x8B1B . #xB9D6) + (#x8B1C . #x8FDEBC) + (#x8B1D . #xBCD5) + (#x8B1E . #x8FDEBD) + (#x8B1F . #x8FDEBE) + (#x8B20 . #xEBEF) + (#x8B21 . #xCDD8) + (#x8B26 . #xEBF2) + (#x8B28 . #xEBF5) + (#x8B2B . #xEBF3) + (#x8B2C . #xC9B5) + (#x8B2D . #x8FDEC0) + (#x8B30 . #x8FDEC1) + (#x8B33 . #xEBF0) + (#x8B37 . #x8FDEC2) + (#x8B39 . #xB6E0) + (#x8B3C . #x8FDEC3) + (#x8B3E . #xEBF4) + (#x8B41 . #xEBF6) + (#x8B42 . #x8FDEC4) + (#x8B43 . #x8FDEC5) + (#x8B44 . #x8FDEC6) + (#x8B45 . #x8FDEC7) + (#x8B46 . #x8FDEC8) + (#x8B48 . #x8FDEC9) + (#x8B49 . #xEBFA) + (#x8B4C . #xEBF7) + (#x8B4D . #x8FDECE) + (#x8B4E . #xEBF9) + (#x8B4F . #xEBF8) + (#x8B52 . #x8FDECA) + (#x8B53 . #x8FDECB) + (#x8B54 . #x8FDECC) + (#x8B56 . #xEBFB) + (#x8B58 . #xBCB1) + (#x8B59 . #x8FDECD) + (#x8B5A . #xEBFD) + (#x8B5B . #xEBFC) + (#x8B5C . #xC9E8) + (#x8B5E . #x8FDECF) + (#x8B5F . #xECA1) + (#x8B63 . #x8FDED0) + (#x8B66 . #xB7D9) + (#x8B6B . #xEBFE) + (#x8B6C . #xECA2) + (#x8B6D . #x8FDED1) + (#x8B6F . #xECA3) + (#x8B70 . #xB5C4) + (#x8B71 . #xE6C1) + (#x8B72 . #xBEF9) + (#x8B74 . #xECA4) + (#x8B76 . #x8FDED2) + (#x8B77 . #xB8EE) + (#x8B78 . #x8FDED3) + (#x8B79 . #x8FDED4) + (#x8B7C . #x8FDED5) + (#x8B7D . #xECA5) + (#x8B7E . #x8FDED6) + (#x8B80 . #xECA6) + (#x8B81 . #x8FDED7) + (#x8B83 . #xBBBE) + (#x8B84 . #x8FDED8) + (#x8B85 . #x8FDED9) + (#x8B8A . #xDACE) + (#x8B8B . #x8FDEDA) + (#x8B8C . #xECA7) + (#x8B8D . #x8FDEDB) + (#x8B8E . #xECA8) + (#x8B8F . #x8FDEDC) + (#x8B90 . #xBDB2) + (#x8B92 . #xECA9) + (#x8B93 . #xECAA) + (#x8B94 . #x8FDEDD) + (#x8B95 . #x8FDEDE) + (#x8B96 . #xECAB) + (#x8B99 . #xECAC) + (#x8B9A . #xECAD) + (#x8B9C . #x8FDEDF) + (#x8B9E . #x8FDEE0) + (#x8B9F . #x8FDEE1) + (#x8C37 . #xC3AB) + (#x8C38 . #x8FDEE2) + (#x8C39 . #x8FDEE3) + (#x8C3A . #xECAE) + (#x8C3D . #x8FDEE4) + (#x8C3E . #x8FDEE5) + (#x8C3F . #xECB0) + (#x8C41 . #xECAF) + (#x8C45 . #x8FDEE6) + (#x8C46 . #xC6A6) + (#x8C47 . #x8FDEE7) + (#x8C48 . #xECB1) + (#x8C49 . #x8FDEE8) + (#x8C4A . #xCBAD) + (#x8C4B . #x8FDEE9) + (#x8C4C . #xECB2) + (#x8C4E . #xECB3) + (#x8C4F . #x8FDEEA) + (#x8C50 . #xECB4) + (#x8C51 . #x8FDEEB) + (#x8C53 . #x8FDEEC) + (#x8C54 . #x8FDEED) + (#x8C55 . #xECB5) + (#x8C57 . #x8FDEEE) + (#x8C58 . #x8FDEEF) + (#x8C59 . #x8FDEF2) + (#x8C5A . #xC6DA) + (#x8C5B . #x8FDEF0) + (#x8C5D . #x8FDEF1) + (#x8C61 . #xBEDD) + (#x8C62 . #xECB6) + (#x8C63 . #x8FDEF3) + (#x8C64 . #x8FDEF4) + (#x8C66 . #x8FDEF5) + (#x8C68 . #x8FDEF6) + (#x8C69 . #x8FDEF7) + (#x8C6A . #xB9EB) + (#x8C6B . #xD0AE) + (#x8C6C . #xECB7) + (#x8C6D . #x8FDEF8) + (#x8C73 . #x8FDEF9) + (#x8C75 . #x8FDEFA) + (#x8C76 . #x8FDEFB) + (#x8C78 . #xECB8) + (#x8C79 . #xC9BF) + (#x8C7A . #xECB9) + (#x8C7B . #x8FDEFC) + (#x8C7C . #xECC1) + (#x8C7E . #x8FDEFD) + (#x8C82 . #xECBA) + (#x8C85 . #xECBC) + (#x8C86 . #x8FDEFE) + (#x8C87 . #x8FDFA1) + (#x8C89 . #xECBB) + (#x8C8A . #xECBD) + (#x8C8B . #x8FDFA2) + (#x8C8C . #xCBC6) + (#x8C8D . #xECBE) + (#x8C8E . #xECBF) + (#x8C90 . #x8FDFA3) + (#x8C92 . #x8FDFA4) + (#x8C93 . #x8FDFA5) + (#x8C94 . #xECC0) + (#x8C98 . #xECC2) + (#x8C99 . #x8FDFA6) + (#x8C9B . #x8FDFA7) + (#x8C9C . #x8FDFA8) + (#x8C9D . #xB3AD) + (#x8C9E . #xC4E7) + (#x8CA0 . #xC9E9) + (#x8CA1 . #xBAE2) + (#x8CA2 . #xB9D7) + (#x8CA4 . #x8FDFA9) + (#x8CA7 . #xC9CF) + (#x8CA8 . #xB2DF) + (#x8CA9 . #xC8CE) + (#x8CAA . #xECC5) + (#x8CAB . #xB4D3) + (#x8CAC . #xC0D5) + (#x8CAD . #xECC4) + (#x8CAE . #xECC9) + (#x8CAF . #xC3F9) + (#x8CB0 . #xCCE3) + (#x8CB2 . #xECC7) + (#x8CB3 . #xECC8) + (#x8CB4 . #xB5AE) + (#x8CB6 . #xECCA) + (#x8CB7 . #xC7E3) + (#x8CB8 . #xC2DF) + (#x8CB9 . #x8FDFAA) + (#x8CBA . #x8FDFAB) + (#x8CBB . #xC8F1) + (#x8CBC . #xC5BD) + (#x8CBD . #xECC6) + (#x8CBF . #xCBC7) + (#x8CC0 . #xB2EC) + (#x8CC1 . #xECCC) + (#x8CC2 . #xCFA8) + (#x8CC3 . #xC4C2) + (#x8CC4 . #xCFC5) + (#x8CC5 . #x8FDFAC) + (#x8CC6 . #x8FDFAD) + (#x8CC7 . #xBBF1) + (#x8CC8 . #xECCB) + (#x8CC9 . #x8FDFAE) + (#x8CCA . #xC2B1) + (#x8CCB . #x8FDFAF) + (#x8CCD . #xECDC) + (#x8CCE . #xC1A8) + (#x8CCF . #x8FDFB0) + (#x8CD1 . #xC6F8) + (#x8CD3 . #xC9D0) + (#x8CD5 . #x8FDFB2) + (#x8CD6 . #x8FDFB1) + (#x8CD9 . #x8FDFB3) + (#x8CDA . #xECCF) + (#x8CDB . #xBBBF) + (#x8CDC . #xBBF2) + (#x8CDD . #x8FDFB4) + (#x8CDE . #xBEDE) + (#x8CE0 . #xC7E5) + (#x8CE1 . #x8FDFB5) + (#x8CE2 . #xB8AD) + (#x8CE3 . #xECCE) + (#x8CE4 . #xECCD) + (#x8CE6 . #xC9EA) + (#x8CE8 . #x8FDFB6) + (#x8CEA . #xBCC1) + (#x8CEC . #x8FDFB7) + (#x8CED . #xC5D2) + (#x8CEF . #x8FDFB8) + (#x8CF0 . #x8FDFB9) + (#x8CF2 . #x8FDFBA) + (#x8CF5 . #x8FDFBB) + (#x8CF7 . #x8FDFBC) + (#x8CF8 . #x8FDFBD) + (#x8CFA . #xECD1) + (#x8CFB . #xECD2) + (#x8CFC . #xB9D8) + (#x8CFD . #xECD0) + (#x8CFE . #x8FDFBE) + (#x8CFF . #x8FDFBF) + (#x8D01 . #x8FDFC0) + (#x8D03 . #x8FDFC1) + (#x8D04 . #xECD3) + (#x8D05 . #xECD4) + (#x8D07 . #xECD6) + (#x8D08 . #xC2A3) + (#x8D09 . #x8FDFC2) + (#x8D0A . #xECD5) + (#x8D0B . #xB4E6) + (#x8D0D . #xECD8) + (#x8D0F . #xECD7) + (#x8D10 . #xECD9) + (#x8D12 . #x8FDFC3) + (#x8D13 . #xECDB) + (#x8D14 . #xECDD) + (#x8D16 . #xECDE) + (#x8D17 . #x8FDFC4) + (#x8D1B . #x8FDFC5) + (#x8D64 . #xC0D6) + (#x8D65 . #x8FDFC6) + (#x8D66 . #xBCCF) + (#x8D67 . #xECDF) + (#x8D69 . #x8FDFC7) + (#x8D6B . #xB3D2) + (#x8D6C . #x8FDFC8) + (#x8D6D . #xECE0) + (#x8D6E . #x8FDFC9) + (#x8D70 . #xC1F6) + (#x8D71 . #xECE1) + (#x8D73 . #xECE2) + (#x8D74 . #xC9EB) + (#x8D77 . #xB5AF) + (#x8D7F . #x8FDFCA) + (#x8D81 . #xECE3) + (#x8D82 . #x8FDFCB) + (#x8D84 . #x8FDFCC) + (#x8D85 . #xC4B6) + (#x8D88 . #x8FDFCD) + (#x8D8A . #xB1DB) + (#x8D8D . #x8FDFCE) + (#x8D90 . #x8FDFCF) + (#x8D91 . #x8FDFD0) + (#x8D95 . #x8FDFD1) + (#x8D99 . #xECE4) + (#x8D9E . #x8FDFD2) + (#x8D9F . #x8FDFD3) + (#x8DA0 . #x8FDFD4) + (#x8DA3 . #xBCF1) + (#x8DA6 . #x8FDFD5) + (#x8DA8 . #xBFF6) + (#x8DAB . #x8FDFD6) + (#x8DAC . #x8FDFD7) + (#x8DAF . #x8FDFD8) + (#x8DB2 . #x8FDFD9) + (#x8DB3 . #xC2AD) + (#x8DB5 . #x8FDFDA) + (#x8DB7 . #x8FDFDB) + (#x8DB9 . #x8FDFDC) + (#x8DBA . #xECE7) + (#x8DBB . #x8FDFDD) + (#x8DBC . #x8FDFEF) + (#x8DBE . #xECE6) + (#x8DC0 . #x8FDFDE) + (#x8DC2 . #xECE5) + (#x8DC5 . #x8FDFDF) + (#x8DC6 . #x8FDFE0) + (#x8DC7 . #x8FDFE1) + (#x8DC8 . #x8FDFE2) + (#x8DCA . #x8FDFE3) + (#x8DCB . #xECED) + (#x8DCC . #xECEB) + (#x8DCE . #x8FDFE4) + (#x8DCF . #xECE8) + (#x8DD1 . #x8FDFE5) + (#x8DD4 . #x8FDFE6) + (#x8DD5 . #x8FDFE7) + (#x8DD6 . #xECEA) + (#x8DD7 . #x8FDFE8) + (#x8DD9 . #x8FDFE9) + (#x8DDA . #xECE9) + (#x8DDB . #xECEC) + (#x8DDD . #xB5F7) + (#x8DDF . #xECF0) + (#x8DE1 . #xC0D7) + (#x8DE3 . #xECF1) + (#x8DE4 . #x8FDFEA) + (#x8DE5 . #x8FDFEB) + (#x8DE7 . #x8FDFEC) + (#x8DE8 . #xB8D9) + (#x8DEA . #xECEE) + (#x8DEB . #xECEF) + (#x8DEC . #x8FDFED) + (#x8DEF . #xCFA9) + (#x8DF0 . #x8FDFEE) + (#x8DF1 . #x8FDFF0) + (#x8DF2 . #x8FDFF1) + (#x8DF3 . #xC4B7) + (#x8DF4 . #x8FDFF2) + (#x8DF5 . #xC1A9) + (#x8DFC . #xECF2) + (#x8DFD . #x8FDFF3) + (#x8DFF . #xECF5) + (#x8E01 . #x8FDFF4) + (#x8E04 . #x8FDFF5) + (#x8E05 . #x8FDFF6) + (#x8E06 . #x8FDFF7) + (#x8E08 . #xECF3) + (#x8E09 . #xECF4) + (#x8E0A . #xCDD9) + (#x8E0B . #x8FDFF8) + (#x8E0F . #xC6A7) + (#x8E10 . #xECF8) + (#x8E11 . #x8FDFF9) + (#x8E14 . #x8FDFFA) + (#x8E16 . #x8FDFFB) + (#x8E1D . #xECF6) + (#x8E1E . #xECF7) + (#x8E1F . #xECF9) + (#x8E20 . #x8FDFFC) + (#x8E21 . #x8FDFFD) + (#x8E22 . #x8FDFFE) + (#x8E23 . #x8FE0A1) + (#x8E26 . #x8FE0A2) + (#x8E27 . #x8FE0A3) + (#x8E2A . #xEDA9) + (#x8E30 . #xECFC) + (#x8E31 . #x8FE0A4) + (#x8E33 . #x8FE0A5) + (#x8E34 . #xECFD) + (#x8E35 . #xECFB) + (#x8E36 . #x8FE0A6) + (#x8E37 . #x8FE0A7) + (#x8E38 . #x8FE0A8) + (#x8E39 . #x8FE0A9) + (#x8E3D . #x8FE0AA) + (#x8E40 . #x8FE0AB) + (#x8E41 . #x8FE0AC) + (#x8E42 . #xECFA) + (#x8E44 . #xC4FD) + (#x8E47 . #xEDA1) + (#x8E48 . #xEDA5) + (#x8E49 . #xEDA2) + (#x8E4A . #xECFE) + (#x8E4B . #x8FE0AD) + (#x8E4C . #xEDA3) + (#x8E4D . #x8FE0AE) + (#x8E4E . #x8FE0AF) + (#x8E4F . #x8FE0B0) + (#x8E50 . #xEDA4) + (#x8E54 . #x8FE0B1) + (#x8E55 . #xEDAB) + (#x8E59 . #xEDA6) + (#x8E5B . #x8FE0B2) + (#x8E5C . #x8FE0B3) + (#x8E5D . #x8FE0B4) + (#x8E5E . #x8FE0B5) + (#x8E5F . #xC0D8) + (#x8E60 . #xEDA8) + (#x8E61 . #x8FE0B6) + (#x8E62 . #x8FE0B7) + (#x8E63 . #xEDAA) + (#x8E64 . #xEDA7) + (#x8E69 . #x8FE0B8) + (#x8E6C . #x8FE0B9) + (#x8E6D . #x8FE0BA) + (#x8E6F . #x8FE0BB) + (#x8E70 . #x8FE0BC) + (#x8E71 . #x8FE0BD) + (#x8E72 . #xEDAD) + (#x8E74 . #xBDB3) + (#x8E76 . #xEDAC) + (#x8E79 . #x8FE0BE) + (#x8E7A . #x8FE0BF) + (#x8E7B . #x8FE0C0) + (#x8E7C . #xEDAE) + (#x8E81 . #xEDAF) + (#x8E82 . #x8FE0C1) + (#x8E83 . #x8FE0C2) + (#x8E84 . #xEDB2) + (#x8E85 . #xEDB1) + (#x8E87 . #xEDB0) + (#x8E89 . #x8FE0C3) + (#x8E8A . #xEDB4) + (#x8E8B . #xEDB3) + (#x8E8D . #xCCF6) + (#x8E90 . #x8FE0C4) + (#x8E91 . #xEDB6) + (#x8E92 . #x8FE0C5) + (#x8E93 . #xEDB5) + (#x8E94 . #xEDB7) + (#x8E95 . #x8FE0C6) + (#x8E99 . #xEDB8) + (#x8E9A . #x8FE0C7) + (#x8E9B . #x8FE0C8) + (#x8E9D . #x8FE0C9) + (#x8E9E . #x8FE0CA) + (#x8EA1 . #xEDBA) + (#x8EA2 . #x8FE0CB) + (#x8EA7 . #x8FE0CC) + (#x8EA9 . #x8FE0CD) + (#x8EAA . #xEDB9) + (#x8EAB . #xBFC8) + (#x8EAC . #xEDBB) + (#x8EAD . #x8FE0CE) + (#x8EAE . #x8FE0CF) + (#x8EAF . #xB6ED) + (#x8EB0 . #xEDBC) + (#x8EB1 . #xEDBE) + (#x8EB3 . #x8FE0D0) + (#x8EB5 . #x8FE0D1) + (#x8EBA . #x8FE0D2) + (#x8EBB . #x8FE0D3) + (#x8EBE . #xEDBF) + (#x8EC0 . #x8FE0D4) + (#x8EC1 . #x8FE0D5) + (#x8EC3 . #x8FE0D6) + (#x8EC4 . #x8FE0D7) + (#x8EC5 . #xEDC0) + (#x8EC6 . #xEDBD) + (#x8EC7 . #x8FE0D8) + (#x8EC8 . #xEDC1) + (#x8ECA . #xBCD6) + (#x8ECB . #xEDC2) + (#x8ECC . #xB5B0) + (#x8ECD . #xB7B3) + (#x8ECF . #x8FE0D9) + (#x8ED1 . #x8FE0DA) + (#x8ED2 . #xB8AE) + (#x8ED4 . #x8FE0DB) + (#x8EDB . #xEDC3) + (#x8EDC . #x8FE0DC) + (#x8EDF . #xC6F0) + (#x8EE2 . #xC5BE) + (#x8EE3 . #xEDC4) + (#x8EE8 . #x8FE0DD) + (#x8EEB . #xEDC7) + (#x8EED . #x8FE0E4) + (#x8EEE . #x8FE0DE) + (#x8EF0 . #x8FE0DF) + (#x8EF1 . #x8FE0E0) + (#x8EF7 . #x8FE0E1) + (#x8EF8 . #xBCB4) + (#x8EF9 . #x8FE0E2) + (#x8EFA . #x8FE0E3) + (#x8EFB . #xEDC6) + (#x8EFC . #xEDC5) + (#x8EFD . #xB7DA) + (#x8EFE . #xEDC8) + (#x8F00 . #x8FE0E5) + (#x8F02 . #x8FE0E6) + (#x8F03 . #xB3D3) + (#x8F05 . #xEDCA) + (#x8F07 . #x8FE0E7) + (#x8F08 . #x8FE0E8) + (#x8F09 . #xBADC) + (#x8F0A . #xEDC9) + (#x8F0C . #xEDD2) + (#x8F0F . #x8FE0E9) + (#x8F10 . #x8FE0EA) + (#x8F12 . #xEDCC) + (#x8F13 . #xEDCE) + (#x8F14 . #xCAE5) + (#x8F15 . #xEDCB) + (#x8F16 . #x8FE0EB) + (#x8F17 . #x8FE0EC) + (#x8F18 . #x8FE0ED) + (#x8F19 . #xEDCD) + (#x8F1B . #xEDD1) + (#x8F1C . #xEDCF) + (#x8F1D . #xB5B1) + (#x8F1E . #x8FE0EE) + (#x8F1F . #xEDD0) + (#x8F20 . #x8FE0EF) + (#x8F21 . #x8FE0F0) + (#x8F23 . #x8FE0F1) + (#x8F25 . #x8FE0F2) + (#x8F26 . #xEDD3) + (#x8F27 . #x8FE0F3) + (#x8F28 . #x8FE0F4) + (#x8F29 . #xC7DA) + (#x8F2A . #xCED8) + (#x8F2C . #x8FE0F5) + (#x8F2D . #x8FE0F6) + (#x8F2E . #x8FE0F7) + (#x8F2F . #xBDB4) + (#x8F33 . #xEDD4) + (#x8F34 . #x8FE0F8) + (#x8F35 . #x8FE0F9) + (#x8F36 . #x8FE0FA) + (#x8F37 . #x8FE0FB) + (#x8F38 . #xCDA2) + (#x8F39 . #xEDD6) + (#x8F3A . #x8FE0FC) + (#x8F3B . #xEDD5) + (#x8F3E . #xEDD9) + (#x8F3F . #xCDC1) + (#x8F40 . #x8FE0FD) + (#x8F41 . #x8FE0FE) + (#x8F42 . #xEDD8) + (#x8F43 . #x8FE1A1) + (#x8F44 . #xB3ED) + (#x8F45 . #xEDD7) + (#x8F46 . #xEDDC) + (#x8F47 . #x8FE1A2) + (#x8F49 . #xEDDB) + (#x8F4C . #xEDDA) + (#x8F4D . #xC5B2) + (#x8F4E . #xEDDD) + (#x8F4F . #x8FE1A3) + (#x8F51 . #x8FE1A4) + (#x8F52 . #x8FE1A5) + (#x8F53 . #x8FE1A6) + (#x8F54 . #x8FE1A7) + (#x8F55 . #x8FE1A8) + (#x8F57 . #xEDDE) + (#x8F58 . #x8FE1A9) + (#x8F5C . #xEDDF) + (#x8F5D . #x8FE1AA) + (#x8F5E . #x8FE1AB) + (#x8F5F . #xB9EC) + (#x8F61 . #xB7A5) + (#x8F62 . #xEDE0) + (#x8F63 . #xEDE1) + (#x8F64 . #xEDE2) + (#x8F65 . #x8FE1AC) + (#x8F9B . #xBFC9) + (#x8F9C . #xEDE3) + (#x8F9D . #x8FE1AD) + (#x8F9E . #xBCAD) + (#x8F9F . #xEDE4) + (#x8FA0 . #x8FE1AE) + (#x8FA1 . #x8FE1AF) + (#x8FA3 . #xEDE5) + (#x8FA4 . #x8FE1B0) + (#x8FA5 . #x8FE1B1) + (#x8FA6 . #x8FE1B2) + (#x8FA7 . #xD2A1) + (#x8FA8 . #xD1FE) + (#x8FAD . #xEDE6) + (#x8FAE . #xE5F0) + (#x8FAF . #xEDE7) + (#x8FB0 . #xC3A4) + (#x8FB1 . #xBFAB) + (#x8FB2 . #xC7C0) + (#x8FB5 . #x8FE1B3) + (#x8FB6 . #x8FE1B4) + (#x8FB7 . #xEDE8) + (#x8FB8 . #x8FE1B5) + (#x8FBA . #xCAD5) + (#x8FBB . #xC4D4) + (#x8FBC . #xB9FE) + (#x8FBE . #x8FE1B6) + (#x8FBF . #xC3A9) + (#x8FC0 . #x8FE1B7) + (#x8FC1 . #x8FE1B8) + (#x8FC2 . #xB1AA) + (#x8FC4 . #xCBF8) + (#x8FC5 . #xBFD7) + (#x8FC6 . #x8FE1B9) + (#x8FCA . #x8FE1BA) + (#x8FCB . #x8FE1BB) + (#x8FCD . #x8FE1BC) + (#x8FCE . #xB7DE) + (#x8FD0 . #x8FE1BD) + (#x8FD1 . #xB6E1) + (#x8FD2 . #x8FE1BE) + (#x8FD3 . #x8FE1BF) + (#x8FD4 . #xCAD6) + (#x8FD5 . #x8FE1C0) + (#x8FDA . #xEDE9) + (#x8FE0 . #x8FE1C1) + (#x8FE2 . #xEDEB) + (#x8FE3 . #x8FE1C2) + (#x8FE4 . #x8FE1C3) + (#x8FE5 . #xEDEA) + (#x8FE6 . #xB2E0) + (#x8FE8 . #x8FE1C4) + (#x8FE9 . #xC6F6) + (#x8FEA . #xEDEC) + (#x8FEB . #xC7F7) + (#x8FED . #xC5B3) + (#x8FEE . #x8FE1C5) + (#x8FEF . #xEDED) + (#x8FF0 . #xBDD2) + (#x8FF1 . #x8FE1C6) + (#x8FF4 . #xEDEF) + (#x8FF5 . #x8FE1C7) + (#x8FF6 . #x8FE1C8) + (#x8FF7 . #xCCC2) + (#x8FF8 . #xEDFE) + (#x8FF9 . #xEDF1) + (#x8FFA . #xEDF2) + (#x8FFB . #x8FE1C9) + (#x8FFD . #xC4C9) + (#x8FFE . #x8FE1CA) + (#x9000 . #xC2E0) + (#x9001 . #xC1F7) + (#x9002 . #x8FE1CB) + (#x9003 . #xC6A8) + (#x9004 . #x8FE1CC) + (#x9005 . #xEDF0) + (#x9006 . #xB5D5) + (#x9008 . #x8FE1CD) + (#x900B . #xEDF9) + (#x900C . #x8FE1CE) + (#x900D . #xEDF6) + (#x900E . #xEEA5) + (#x900F . #xC6A9) + (#x9010 . #xC3E0) + (#x9011 . #xEDF3) + (#x9013 . #xC4FE) + (#x9014 . #xC5D3) + (#x9015 . #xEDF4) + (#x9016 . #xEDF8) + (#x9017 . #xBFE0) + (#x9018 . #x8FE1CF) + (#x9019 . #xC7E7) + (#x901A . #xC4CC) + (#x901B . #x8FE1D0) + (#x901D . #xC0C2) + (#x901E . #xEDF7) + (#x901F . #xC2AE) + (#x9020 . #xC2A4) + (#x9021 . #xEDF5) + (#x9022 . #xB0A9) + (#x9023 . #xCFA2) + (#x9027 . #xEDFA) + (#x9028 . #x8FE1D1) + (#x9029 . #x8FE1D2) + (#x902A . #x8FE1D4) + (#x902C . #x8FE1D5) + (#x902D . #x8FE1D6) + (#x902E . #xC2E1) + (#x902F . #x8FE1D3) + (#x9031 . #xBDB5) + (#x9032 . #xBFCA) + (#x9033 . #x8FE1D7) + (#x9034 . #x8FE1D8) + (#x9035 . #xEDFC) + (#x9036 . #xEDFB) + (#x9037 . #x8FE1D9) + (#x9038 . #xB0EF) + (#x9039 . #xEDFD) + (#x903C . #xC9AF) + (#x903E . #xEEA7) + (#x903F . #x8FE1DA) + (#x9041 . #xC6DB) + (#x9042 . #xBFEB) + (#x9043 . #x8FE1DB) + (#x9044 . #x8FE1DC) + (#x9045 . #xC3D9) + (#x9047 . #xB6F8) + (#x9049 . #xEEA6) + (#x904A . #xCDB7) + (#x904B . #xB1BF) + (#x904C . #x8FE1DD) + (#x904D . #xCAD7) + (#x904E . #xB2E1) + (#x904F . #xEEA1) + (#x9050 . #xEEA2) + (#x9051 . #xEEA3) + (#x9052 . #xEEA4) + (#x9053 . #xC6BB) + (#x9054 . #xC3A3) + (#x9055 . #xB0E3) + (#x9056 . #xEEA8) + (#x9058 . #xEEA9) + (#x9059 . #xF4A3) + (#x905B . #x8FE1DE) + (#x905C . #xC2BD) + (#x905D . #x8FE1DF) + (#x905E . #xEEAA) + (#x9060 . #xB1F3) + (#x9061 . #xC1CC) + (#x9062 . #x8FE1E0) + (#x9063 . #xB8AF) + (#x9065 . #xCDDA) + (#x9066 . #x8FE1E1) + (#x9067 . #x8FE1E2) + (#x9068 . #xEEAB) + (#x9069 . #xC5AC) + (#x906C . #x8FE1E3) + (#x906D . #xC1F8) + (#x906E . #xBCD7) + (#x906F . #xEEAC) + (#x9070 . #x8FE1E4) + (#x9072 . #xEEAF) + (#x9074 . #x8FE1E5) + (#x9075 . #xBDE5) + (#x9076 . #xEEAD) + (#x9077 . #xC1AB) + (#x9078 . #xC1AA) + (#x9079 . #x8FE1E6) + (#x907A . #xB0E4) + (#x907C . #xCECB) + (#x907D . #xEEB1) + (#x907F . #xC8F2) + (#x9080 . #xEEB3) + (#x9081 . #xEEB2) + (#x9082 . #xEEB0) + (#x9083 . #xE3E4) + (#x9084 . #xB4D4) + (#x9085 . #x8FE1E7) + (#x9087 . #xEDEE) + (#x9088 . #x8FE1E8) + (#x9089 . #xEEB5) + (#x908A . #xEEB4) + (#x908B . #x8FE1E9) + (#x908C . #x8FE1EA) + (#x908E . #x8FE1EB) + (#x908F . #xEEB6) + (#x9090 . #x8FE1EC) + (#x9091 . #xCDB8) + (#x9095 . #x8FE1ED) + (#x9097 . #x8FE1EE) + (#x9098 . #x8FE1EF) + (#x9099 . #x8FE1F0) + (#x909B . #x8FE1F1) + (#x90A0 . #x8FE1F2) + (#x90A1 . #x8FE1F3) + (#x90A2 . #x8FE1F4) + (#x90A3 . #xC6E1) + (#x90A5 . #x8FE1F5) + (#x90A6 . #xCBAE) + (#x90A8 . #xEEB7) + (#x90AA . #xBCD9) + (#x90AF . #xEEB8) + (#x90B0 . #x8FE1F6) + (#x90B1 . #xEEB9) + (#x90B2 . #x8FE1F7) + (#x90B3 . #x8FE1F8) + (#x90B4 . #x8FE1F9) + (#x90B5 . #xEEBA) + (#x90B6 . #x8FE1FA) + (#x90B8 . #xC5A1) + (#x90BD . #x8FE1FB) + (#x90BE . #x8FE1FD) + (#x90C1 . #xB0EA) + (#x90C3 . #x8FE1FE) + (#x90C4 . #x8FE2A1) + (#x90C5 . #x8FE2A2) + (#x90C7 . #x8FE2A3) + (#x90C8 . #x8FE2A4) + (#x90CA . #xB9D9) + (#x90CC . #x8FE1FC) + (#x90CE . #xCFBA) + (#x90D2 . #x8FE2AD) + (#x90D5 . #x8FE2A5) + (#x90D7 . #x8FE2A6) + (#x90D8 . #x8FE2A7) + (#x90D9 . #x8FE2A8) + (#x90DB . #xEEBE) + (#x90DC . #x8FE2A9) + (#x90DD . #x8FE2AA) + (#x90DF . #x8FE2AB) + (#x90E1 . #xB7B4) + (#x90E2 . #xEEBB) + (#x90E4 . #xEEBC) + (#x90E5 . #x8FE2AC) + (#x90E8 . #xC9F4) + (#x90EB . #x8FE2AF) + (#x90ED . #xB3D4) + (#x90EF . #x8FE2B0) + (#x90F0 . #x8FE2B1) + (#x90F4 . #x8FE2B2) + (#x90F5 . #xCDB9) + (#x90F6 . #x8FE2AE) + (#x90F7 . #xB6BF) + (#x90FD . #xC5D4) + (#x90FE . #x8FE2B3) + (#x90FF . #x8FE2B4) + (#x9100 . #x8FE2B5) + (#x9102 . #xEEBF) + (#x9104 . #x8FE2B6) + (#x9105 . #x8FE2B7) + (#x9106 . #x8FE2B8) + (#x9108 . #x8FE2B9) + (#x910D . #x8FE2BA) + (#x9110 . #x8FE2BB) + (#x9112 . #xEEC0) + (#x9114 . #x8FE2BC) + (#x9116 . #x8FE2BD) + (#x9117 . #x8FE2BE) + (#x9118 . #x8FE2BF) + (#x9119 . #xEEC1) + (#x911A . #x8FE2C0) + (#x911C . #x8FE2C1) + (#x911E . #x8FE2C2) + (#x9120 . #x8FE2C3) + (#x9122 . #x8FE2C5) + (#x9123 . #x8FE2C6) + (#x9125 . #x8FE2C4) + (#x9127 . #x8FE2C7) + (#x9129 . #x8FE2C8) + (#x912D . #xC5A2) + (#x912E . #x8FE2C9) + (#x912F . #x8FE2CA) + (#x9130 . #xEEC3) + (#x9131 . #x8FE2CB) + (#x9132 . #xEEC2) + (#x9134 . #x8FE2CC) + (#x9136 . #x8FE2CD) + (#x9137 . #x8FE2CE) + (#x9139 . #x8FE2CF) + (#x913A . #x8FE2D0) + (#x913C . #x8FE2D1) + (#x913D . #x8FE2D2) + (#x9143 . #x8FE2D3) + (#x9147 . #x8FE2D4) + (#x9148 . #x8FE2D5) + (#x9149 . #xC6D3) + (#x914A . #xEEC4) + (#x914B . #xBDB6) + (#x914C . #xBCE0) + (#x914D . #xC7DB) + (#x914E . #xC3F1) + (#x914F . #x8FE2D6) + (#x9152 . #xBCF2) + (#x9153 . #x8FE2D7) + (#x9154 . #xBFEC) + (#x9156 . #xEEC5) + (#x9157 . #x8FE2D8) + (#x9158 . #xEEC6) + (#x9159 . #x8FE2D9) + (#x915A . #x8FE2DA) + (#x915B . #x8FE2DB) + (#x9161 . #x8FE2DC) + (#x9162 . #xBFDD) + (#x9163 . #xEEC7) + (#x9164 . #x8FE2DD) + (#x9165 . #xEEC8) + (#x9167 . #x8FE2DE) + (#x9169 . #xEEC9) + (#x916A . #xCDEF) + (#x916C . #xBDB7) + (#x916D . #x8FE2DF) + (#x9172 . #xEECB) + (#x9173 . #xEECA) + (#x9174 . #x8FE2E0) + (#x9175 . #xB9DA) + (#x9177 . #xB9F3) + (#x9178 . #xBBC0) + (#x9179 . #x8FE2E1) + (#x917A . #x8FE2E2) + (#x917B . #x8FE2E3) + (#x9181 . #x8FE2E4) + (#x9182 . #xEECE) + (#x9183 . #x8FE2E5) + (#x9185 . #x8FE2E6) + (#x9186 . #x8FE2E7) + (#x9187 . #xBDE6) + (#x9189 . #xEECD) + (#x918A . #x8FE2E8) + (#x918B . #xEECC) + (#x918D . #xC2E9) + (#x918E . #x8FE2E9) + (#x9190 . #xB8EF) + (#x9191 . #x8FE2EA) + (#x9192 . #xC0C3) + (#x9193 . #x8FE2EB) + (#x9194 . #x8FE2EC) + (#x9195 . #x8FE2ED) + (#x9197 . #xC8B0) + (#x9198 . #x8FE2EE) + (#x919C . #xBDB9) + (#x919E . #x8FE2EF) + (#x91A1 . #x8FE2F0) + (#x91A2 . #xEECF) + (#x91A4 . #xBEDF) + (#x91A6 . #x8FE2F1) + (#x91A8 . #x8FE2F2) + (#x91AA . #xEED2) + (#x91AB . #xEED0) + (#x91AC . #x8FE2F3) + (#x91AD . #x8FE2F4) + (#x91AE . #x8FE2F5) + (#x91AF . #xEED1) + (#x91B0 . #x8FE2F6) + (#x91B1 . #x8FE2F7) + (#x91B2 . #x8FE2F8) + (#x91B3 . #x8FE2F9) + (#x91B4 . #xEED4) + (#x91B5 . #xEED3) + (#x91B6 . #x8FE2FA) + (#x91B8 . #xBEFA) + (#x91BA . #xEED5) + (#x91BB . #x8FE2FB) + (#x91BC . #x8FE2FC) + (#x91BD . #x8FE2FD) + (#x91BF . #x8FE2FE) + (#x91C0 . #xEED6) + (#x91C1 . #xEED7) + (#x91C2 . #x8FE3A1) + (#x91C3 . #x8FE3A2) + (#x91C5 . #x8FE3A3) + (#x91C6 . #xC8D0) + (#x91C7 . #xBAD3) + (#x91C8 . #xBCE1) + (#x91C9 . #xEED8) + (#x91CB . #xEED9) + (#x91CC . #xCEA4) + (#x91CD . #xBDC5) + (#x91CE . #xCCEE) + (#x91CF . #xCECC) + (#x91D0 . #xEEDA) + (#x91D1 . #xB6E2) + (#x91D3 . #x8FE3A4) + (#x91D4 . #x8FE3A5) + (#x91D6 . #xEEDB) + (#x91D7 . #x8FE3A6) + (#x91D8 . #xC5A3) + (#x91D9 . #x8FE3A7) + (#x91DA . #x8FE3A8) + (#x91DB . #xEEDE) + (#x91DC . #xB3F8) + (#x91DD . #xBFCB) + (#x91DE . #x8FE3A9) + (#x91DF . #xEEDC) + (#x91E1 . #xEEDD) + (#x91E3 . #xC4E0) + (#x91E4 . #x8FE3AA) + (#x91E5 . #x8FE3AB) + (#x91E6 . #xCBD5) + (#x91E7 . #xB6FC) + (#x91E9 . #x8FE3AC) + (#x91EA . #x8FE3AD) + (#x91EC . #x8FE3AE) + (#x91ED . #x8FE3AF) + (#x91EE . #x8FE3B0) + (#x91EF . #x8FE3B1) + (#x91F0 . #x8FE3B2) + (#x91F1 . #x8FE3B3) + (#x91F5 . #xEEE0) + (#x91F6 . #xEEE1) + (#x91F7 . #x8FE3B4) + (#x91F9 . #x8FE3B5) + (#x91FB . #x8FE3B6) + (#x91FC . #xEEDF) + (#x91FD . #x8FE3B7) + (#x91FF . #xEEE3) + (#x9200 . #x8FE3B8) + (#x9201 . #x8FE3B9) + (#x9204 . #x8FE3BA) + (#x9205 . #x8FE3BB) + (#x9206 . #x8FE3BC) + (#x9207 . #x8FE3BD) + (#x9209 . #x8FE3BE) + (#x920A . #x8FE3BF) + (#x920C . #x8FE3C0) + (#x920D . #xC6DF) + (#x920E . #xB3C3) + (#x9210 . #x8FE3C1) + (#x9211 . #xEEE7) + (#x9212 . #x8FE3C2) + (#x9213 . #x8FE3C3) + (#x9214 . #xEEE4) + (#x9215 . #xEEE6) + (#x9216 . #x8FE3C4) + (#x9218 . #x8FE3C5) + (#x921C . #x8FE3C6) + (#x921D . #x8FE3C7) + (#x921E . #xEEE2) + (#x9223 . #x8FE3C8) + (#x9224 . #x8FE3C9) + (#x9225 . #x8FE3CA) + (#x9226 . #x8FE3CB) + (#x9228 . #x8FE3CC) + (#x9229 . #xEFCF) + (#x922C . #xEEE5) + (#x922E . #x8FE3CD) + (#x922F . #x8FE3CE) + (#x9230 . #x8FE3CF) + (#x9233 . #x8FE3D0) + (#x9234 . #xCEEB) + (#x9235 . #x8FE3D1) + (#x9236 . #x8FE3D2) + (#x9237 . #xB8DA) + (#x9238 . #x8FE3D3) + (#x9239 . #x8FE3D4) + (#x923A . #x8FE3D5) + (#x923C . #x8FE3D6) + (#x923E . #x8FE3D7) + (#x923F . #xEEEF) + (#x9240 . #x8FE3D8) + (#x9242 . #x8FE3D9) + (#x9243 . #x8FE3DA) + (#x9244 . #xC5B4) + (#x9245 . #xEEEA) + (#x9246 . #x8FE3DB) + (#x9247 . #x8FE3DC) + (#x9248 . #xEEED) + (#x9249 . #xEEEB) + (#x924A . #x8FE3DD) + (#x924B . #xEEF0) + (#x924D . #x8FE3DE) + (#x924E . #x8FE3DF) + (#x924F . #x8FE3E0) + (#x9250 . #xEEF1) + (#x9251 . #x8FE3E1) + (#x9257 . #xEEE9) + (#x9258 . #x8FE3E2) + (#x9259 . #x8FE3E3) + (#x925A . #xEEF6) + (#x925B . #xB1F4) + (#x925C . #x8FE3E4) + (#x925D . #x8FE3E5) + (#x925E . #xEEE8) + (#x9260 . #x8FE3E6) + (#x9261 . #x8FE3E7) + (#x9262 . #xC8AD) + (#x9264 . #xEEEC) + (#x9265 . #x8FE3E8) + (#x9266 . #xBEE0) + (#x9267 . #x8FE3E9) + (#x9268 . #x8FE3EA) + (#x9269 . #x8FE3EB) + (#x926E . #x8FE3EC) + (#x926F . #x8FE3ED) + (#x9270 . #x8FE3EE) + (#x9271 . #xB9DB) + (#x9275 . #x8FE3EF) + (#x9276 . #x8FE3F0) + (#x9277 . #x8FE3F1) + (#x9278 . #x8FE3F2) + (#x9279 . #x8FE3F3) + (#x927B . #x8FE3F4) + (#x927C . #x8FE3F5) + (#x927D . #x8FE3F6) + (#x927E . #xCBC8) + (#x927F . #x8FE3F7) + (#x9280 . #xB6E4) + (#x9283 . #xBDC6) + (#x9285 . #xC6BC) + (#x9288 . #x8FE3F8) + (#x9289 . #x8FE3F9) + (#x928A . #x8FE3FA) + (#x928D . #x8FE3FB) + (#x928E . #x8FE3FC) + (#x9291 . #xC1AD) + (#x9292 . #x8FE3FD) + (#x9293 . #xEEF4) + (#x9295 . #xEEEE) + (#x9296 . #xEEF3) + (#x9297 . #x8FE3FE) + (#x9298 . #xCCC3) + (#x9299 . #x8FE4A1) + (#x929A . #xC4B8) + (#x929B . #xEEF5) + (#x929C . #xEEF2) + (#x929F . #x8FE4A2) + (#x92A0 . #x8FE4A3) + (#x92A4 . #x8FE4A4) + (#x92A5 . #x8FE4A5) + (#x92A7 . #x8FE4A6) + (#x92A8 . #x8FE4A7) + (#x92AB . #x8FE4A8) + (#x92AD . #xC1AC) + (#x92AF . #x8FE4A9) + (#x92B2 . #x8FE4AA) + (#x92B6 . #x8FE4AB) + (#x92B7 . #xEEF9) + (#x92B8 . #x8FE4AC) + (#x92B9 . #xEEF8) + (#x92BA . #x8FE4AD) + (#x92BB . #x8FE4AE) + (#x92BC . #x8FE4AF) + (#x92BD . #x8FE4B0) + (#x92BF . #x8FE4B1) + (#x92C0 . #x8FE4B2) + (#x92C1 . #x8FE4B3) + (#x92C2 . #x8FE4B4) + (#x92C3 . #x8FE4B5) + (#x92C5 . #x8FE4B6) + (#x92C6 . #x8FE4B7) + (#x92C7 . #x8FE4B8) + (#x92C8 . #x8FE4B9) + (#x92CB . #x8FE4BA) + (#x92CC . #x8FE4BB) + (#x92CD . #x8FE4BC) + (#x92CE . #x8FE4BD) + (#x92CF . #xEEF7) + (#x92D0 . #x8FE4BE) + (#x92D2 . #xCBAF) + (#x92D3 . #x8FE4BF) + (#x92D5 . #x8FE4C0) + (#x92D7 . #x8FE4C1) + (#x92D8 . #x8FE4C2) + (#x92D9 . #x8FE4C3) + (#x92DC . #x8FE4C4) + (#x92DD . #x8FE4C5) + (#x92DF . #x8FE4C6) + (#x92E0 . #x8FE4C7) + (#x92E1 . #x8FE4C8) + (#x92E3 . #x8FE4C9) + (#x92E4 . #xBDFB) + (#x92E5 . #x8FE4CA) + (#x92E7 . #x8FE4CB) + (#x92E8 . #x8FE4CC) + (#x92E9 . #xEEFA) + (#x92EA . #xCADF) + (#x92EC . #x8FE4CD) + (#x92ED . #xB1D4) + (#x92EE . #x8FE4CE) + (#x92F0 . #x8FE4CF) + (#x92F2 . #xC9C6) + (#x92F3 . #xC3F2) + (#x92F8 . #xB5F8) + (#x92F9 . #x8FE4D0) + (#x92FA . #xEEFC) + (#x92FB . #x8FE4D1) + (#x92FC . #xB9DD) + (#x92FF . #x8FE4D2) + (#x9300 . #x8FE4D3) + (#x9302 . #x8FE4D4) + (#x9306 . #xBBAC) + (#x9308 . #x8FE4D5) + (#x930D . #x8FE4D6) + (#x930F . #xEEFB) + (#x9310 . #xBFED) + (#x9311 . #x8FE4D7) + (#x9314 . #x8FE4D8) + (#x9315 . #x8FE4D9) + (#x9318 . #xBFEE) + (#x9319 . #xEFA1) + (#x931A . #xEFA3) + (#x931C . #x8FE4DA) + (#x931D . #x8FE4DB) + (#x931E . #x8FE4DC) + (#x931F . #x8FE4DD) + (#x9320 . #xBEFB) + (#x9321 . #x8FE4DE) + (#x9322 . #xEFA2) + (#x9323 . #xEFA4) + (#x9324 . #x8FE4DF) + (#x9325 . #x8FE4E0) + (#x9326 . #xB6D3) + (#x9327 . #x8FE4E1) + (#x9328 . #xC9C5) + (#x9329 . #x8FE4E2) + (#x932A . #x8FE4E3) + (#x932B . #xBCE2) + (#x932C . #xCFA3) + (#x932E . #xEEFE) + (#x932F . #xBAF8) + (#x9332 . #xCFBF) + (#x9333 . #x8FE4E4) + (#x9334 . #x8FE4E5) + (#x9335 . #xEFA6) + (#x9336 . #x8FE4E6) + (#x9337 . #x8FE4E7) + (#x933A . #xEFA5) + (#x933B . #xEFA7) + (#x9344 . #xEEFD) + (#x9347 . #x8FE4E8) + (#x9348 . #x8FE4E9) + (#x9349 . #x8FE4EA) + (#x934B . #xC6E9) + (#x934D . #xC5D5) + (#x9350 . #x8FE4EB) + (#x9351 . #x8FE4EC) + (#x9352 . #x8FE4ED) + (#x9354 . #xC4D7) + (#x9355 . #x8FE4EE) + (#x9356 . #xEFAC) + (#x9357 . #x8FE4EF) + (#x9358 . #x8FE4F0) + (#x935A . #x8FE4F1) + (#x935B . #xC3C3) + (#x935C . #xEFA8) + (#x935E . #x8FE4F2) + (#x9360 . #xEFA9) + (#x9364 . #x8FE4F3) + (#x9365 . #x8FE4F4) + (#x9367 . #x8FE4F5) + (#x9369 . #x8FE4F6) + (#x936A . #x8FE4F7) + (#x936C . #xB7AD) + (#x936D . #x8FE4F8) + (#x936E . #xEFAB) + (#x936F . #x8FE4F9) + (#x9370 . #x8FE4FA) + (#x9371 . #x8FE4FB) + (#x9373 . #x8FE4FC) + (#x9374 . #x8FE4FD) + (#x9375 . #xB8B0) + (#x9376 . #x8FE4FE) + (#x937A . #x8FE5A1) + (#x937C . #xEFAA) + (#x937D . #x8FE5A2) + (#x937E . #xBEE1) + (#x937F . #x8FE5A3) + (#x9380 . #x8FE5A4) + (#x9381 . #x8FE5A5) + (#x9382 . #x8FE5A6) + (#x9388 . #x8FE5A7) + (#x938A . #x8FE5A8) + (#x938B . #x8FE5A9) + (#x938C . #xB3F9) + (#x938D . #x8FE5AA) + (#x938F . #x8FE5AB) + (#x9392 . #x8FE5AC) + (#x9394 . #xEFB0) + (#x9395 . #x8FE5AD) + (#x9396 . #xBABF) + (#x9397 . #xC1F9) + (#x9398 . #x8FE5AE) + (#x939A . #xC4CA) + (#x939B . #x8FE5AF) + (#x939E . #x8FE5B0) + (#x93A1 . #x8FE5B1) + (#x93A3 . #x8FE5B2) + (#x93A4 . #x8FE5B3) + (#x93A6 . #x8FE5B4) + (#x93A7 . #xB3BB) + (#x93A8 . #x8FE5B5) + (#x93A9 . #x8FE5BB) + (#x93AB . #x8FE5B6) + (#x93AC . #xEFAE) + (#x93AD . #xEFAF) + (#x93AE . #xC4C3) + (#x93B0 . #xEFAD) + (#x93B4 . #x8FE5B7) + (#x93B5 . #x8FE5B8) + (#x93B6 . #x8FE5B9) + (#x93B9 . #xEFB1) + (#x93BA . #x8FE5BA) + (#x93C1 . #x8FE5BC) + (#x93C3 . #xEFB7) + (#x93C4 . #x8FE5BD) + (#x93C5 . #x8FE5BE) + (#x93C6 . #x8FE5BF) + (#x93C7 . #x8FE5C0) + (#x93C8 . #xEFBA) + (#x93C9 . #x8FE5C1) + (#x93CA . #x8FE5C2) + (#x93CB . #x8FE5C3) + (#x93CC . #x8FE5C4) + (#x93CD . #x8FE5C5) + (#x93D0 . #xEFB9) + (#x93D1 . #xC5AD) + (#x93D3 . #x8FE5C6) + (#x93D6 . #xEFB2) + (#x93D7 . #xEFB3) + (#x93D8 . #xEFB6) + (#x93D9 . #x8FE5C7) + (#x93DC . #x8FE5C8) + (#x93DD . #xEFB8) + (#x93DE . #x8FE5C9) + (#x93DF . #x8FE5CA) + (#x93E1 . #xB6C0) + (#x93E2 . #x8FE5CB) + (#x93E4 . #xEFBB) + (#x93E5 . #xEFB5) + (#x93E6 . #x8FE5CC) + (#x93E7 . #x8FE5CD) + (#x93E8 . #xEFB4) + (#x93F7 . #x8FE5CF) + (#x93F8 . #x8FE5D0) + (#x93F9 . #x8FE5CE) + (#x93FA . #x8FE5D1) + (#x93FB . #x8FE5D2) + (#x93FD . #x8FE5D3) + (#x9401 . #x8FE5D4) + (#x9402 . #x8FE5D5) + (#x9403 . #xEFBF) + (#x9404 . #x8FE5D6) + (#x9407 . #xEFC0) + (#x9408 . #x8FE5D7) + (#x9409 . #x8FE5D8) + (#x940D . #x8FE5D9) + (#x940E . #x8FE5DA) + (#x940F . #x8FE5DB) + (#x9410 . #xEFC1) + (#x9413 . #xEFBE) + (#x9414 . #xEFBD) + (#x9415 . #x8FE5DC) + (#x9416 . #x8FE5DD) + (#x9417 . #x8FE5DE) + (#x9418 . #xBEE2) + (#x9419 . #xC6AA) + (#x941A . #xEFBC) + (#x941F . #x8FE5DF) + (#x9421 . #xEFC5) + (#x942B . #xEFC3) + (#x942E . #x8FE5E0) + (#x942F . #x8FE5E1) + (#x9431 . #x8FE5E2) + (#x9432 . #x8FE5E3) + (#x9433 . #x8FE5E4) + (#x9434 . #x8FE5E5) + (#x9435 . #xEFC4) + (#x9436 . #xEFC2) + (#x9438 . #xC2F8) + (#x943A . #xEFC6) + (#x943B . #x8FE5E6) + (#x943D . #x8FE5E8) + (#x943F . #x8FE5E7) + (#x9441 . #xEFC7) + (#x9443 . #x8FE5E9) + (#x9444 . #xEFC9) + (#x9445 . #x8FE5EA) + (#x9448 . #x8FE5EB) + (#x944A . #x8FE5EC) + (#x944C . #x8FE5ED) + (#x9451 . #xB4D5) + (#x9452 . #xEFC8) + (#x9453 . #xCCFA) + (#x9455 . #x8FE5EE) + (#x9459 . #x8FE5EF) + (#x945A . #xEFD4) + (#x945B . #xEFCA) + (#x945C . #x8FE5F0) + (#x945E . #xEFCD) + (#x945F . #x8FE5F1) + (#x9460 . #xEFCB) + (#x9461 . #x8FE5F2) + (#x9462 . #xEFCC) + (#x9463 . #x8FE5F3) + (#x9468 . #x8FE5F4) + (#x946A . #xEFCE) + (#x946B . #x8FE5F5) + (#x946D . #x8FE5F6) + (#x946E . #x8FE5F7) + (#x946F . #x8FE5F8) + (#x9470 . #xEFD0) + (#x9471 . #x8FE5F9) + (#x9472 . #x8FE5FA) + (#x9475 . #xEFD1) + (#x9477 . #xEFD2) + (#x947C . #xEFD5) + (#x947D . #xEFD3) + (#x947E . #xEFD6) + (#x947F . #xEFD8) + (#x9481 . #xEFD7) + (#x9483 . #x8FE5FC) + (#x9484 . #x8FE5FB) + (#x9577 . #xC4B9) + (#x9578 . #x8FE5FD) + (#x9579 . #x8FE5FE) + (#x957E . #x8FE6A1) + (#x9580 . #xCCE7) + (#x9582 . #xEFD9) + (#x9583 . #xC1AE) + (#x9584 . #x8FE6A2) + (#x9587 . #xEFDA) + (#x9588 . #x8FE6A3) + (#x9589 . #xCAC4) + (#x958A . #xEFDB) + (#x958B . #xB3AB) + (#x958C . #x8FE6A4) + (#x958D . #x8FE6A5) + (#x958E . #x8FE6A6) + (#x958F . #xB1BC) + (#x9591 . #xB4D7) + (#x9593 . #xB4D6) + (#x9594 . #xEFDC) + (#x9596 . #xEFDD) + (#x9598 . #xEFDE) + (#x9599 . #xEFDF) + (#x959D . #x8FE6A7) + (#x959E . #x8FE6A8) + (#x959F . #x8FE6A9) + (#x95A0 . #xEFE0) + (#x95A1 . #x8FE6AA) + (#x95A2 . #xB4D8) + (#x95A3 . #xB3D5) + (#x95A4 . #xB9DE) + (#x95A5 . #xC8B6) + (#x95A6 . #x8FE6AB) + (#x95A7 . #xEFE2) + (#x95A8 . #xEFE1) + (#x95A9 . #x8FE6AC) + (#x95AB . #x8FE6AD) + (#x95AC . #x8FE6AE) + (#x95AD . #xEFE3) + (#x95B2 . #xB1DC) + (#x95B4 . #x8FE6AF) + (#x95B6 . #x8FE6B0) + (#x95B9 . #xEFE6) + (#x95BA . #x8FE6B1) + (#x95BB . #xEFE5) + (#x95BC . #xEFE4) + (#x95BD . #x8FE6B2) + (#x95BE . #xEFE7) + (#x95BF . #x8FE6B3) + (#x95C3 . #xEFEA) + (#x95C6 . #x8FE6B4) + (#x95C7 . #xB0C7) + (#x95C8 . #x8FE6B5) + (#x95C9 . #x8FE6B6) + (#x95CA . #xEFE8) + (#x95CB . #x8FE6B7) + (#x95CC . #xEFEC) + (#x95CD . #xEFEB) + (#x95D0 . #x8FE6B8) + (#x95D1 . #x8FE6B9) + (#x95D2 . #x8FE6BA) + (#x95D3 . #x8FE6BB) + (#x95D4 . #xEFEE) + (#x95D5 . #xEFED) + (#x95D6 . #xEFEF) + (#x95D8 . #xC6AE) + (#x95D9 . #x8FE6BC) + (#x95DA . #x8FE6BD) + (#x95DC . #xEFF0) + (#x95DD . #x8FE6BE) + (#x95DE . #x8FE6BF) + (#x95DF . #x8FE6C0) + (#x95E0 . #x8FE6C1) + (#x95E1 . #xEFF1) + (#x95E2 . #xEFF3) + (#x95E4 . #x8FE6C2) + (#x95E5 . #xEFF2) + (#x95E6 . #x8FE6C3) + (#x961C . #xC9EC) + (#x961D . #x8FE6C4) + (#x961E . #x8FE6C5) + (#x9621 . #xEFF4) + (#x9622 . #x8FE6C6) + (#x9624 . #x8FE6C7) + (#x9625 . #x8FE6C8) + (#x9626 . #x8FE6C9) + (#x9628 . #xEFF5) + (#x962A . #xBAE5) + (#x962C . #x8FE6CA) + (#x962E . #xEFF6) + (#x962F . #xEFF7) + (#x9631 . #x8FE6CB) + (#x9632 . #xCBC9) + (#x9633 . #x8FE6CC) + (#x9637 . #x8FE6CD) + (#x9638 . #x8FE6CE) + (#x9639 . #x8FE6CF) + (#x963A . #x8FE6D0) + (#x963B . #xC1CB) + (#x963C . #x8FE6D1) + (#x963D . #x8FE6D2) + (#x963F . #xB0A4) + (#x9640 . #xC2CB) + (#x9641 . #x8FE6D3) + (#x9642 . #xEFF8) + (#x9644 . #xC9ED) + (#x964B . #xEFFB) + (#x964C . #xEFF9) + (#x964D . #xB9DF) + (#x964F . #xEFFA) + (#x9650 . #xB8C2) + (#x9652 . #x8FE6D4) + (#x9654 . #x8FE6D5) + (#x9656 . #x8FE6D6) + (#x9657 . #x8FE6D7) + (#x9658 . #x8FE6D8) + (#x965B . #xCAC5) + (#x965C . #xEFFD) + (#x965D . #xF0A1) + (#x965E . #xEFFE) + (#x965F . #xF0A2) + (#x9661 . #x8FE6D9) + (#x9662 . #xB1A1) + (#x9663 . #xBFD8) + (#x9664 . #xBDFC) + (#x9665 . #xB4D9) + (#x9666 . #xF0A3) + (#x966A . #xC7E6) + (#x966C . #xF0A5) + (#x966E . #x8FE6DA) + (#x9670 . #xB1A2) + (#x9672 . #xF0A4) + (#x9673 . #xC4C4) + (#x9674 . #x8FE6DB) + (#x9675 . #xCECD) + (#x9676 . #xC6AB) + (#x9677 . #xEFFC) + (#x9678 . #xCEA6) + (#x967A . #xB8B1) + (#x967B . #x8FE6DC) + (#x967C . #x8FE6DD) + (#x967D . #xCDDB) + (#x967E . #x8FE6DE) + (#x967F . #x8FE6DF) + (#x9681 . #x8FE6E0) + (#x9682 . #x8FE6E1) + (#x9683 . #x8FE6E2) + (#x9684 . #x8FE6E3) + (#x9685 . #xB6F9) + (#x9686 . #xCEB4) + (#x9688 . #xB7A8) + (#x9689 . #x8FE6E4) + (#x968A . #xC2E2) + (#x968B . #xE7A1) + (#x968D . #xF0A6) + (#x968E . #xB3AC) + (#x968F . #xBFEF) + (#x9691 . #x8FE6E5) + (#x9694 . #xB3D6) + (#x9695 . #xF0A8) + (#x9696 . #x8FE6E6) + (#x9697 . #xF0A9) + (#x9698 . #xF0A7) + (#x9699 . #xB7E4) + (#x969A . #x8FE6E7) + (#x969B . #xBADD) + (#x969C . #xBEE3) + (#x969D . #x8FE6E8) + (#x969F . #x8FE6E9) + (#x96A0 . #xB1A3) + (#x96A3 . #xCED9) + (#x96A4 . #x8FE6EA) + (#x96A5 . #x8FE6EB) + (#x96A6 . #x8FE6EC) + (#x96A7 . #xF0AB) + (#x96A8 . #xEEAE) + (#x96A9 . #x8FE6ED) + (#x96AA . #xF0AA) + (#x96AE . #x8FE6EE) + (#x96AF . #x8FE6EF) + (#x96B0 . #xF0AE) + (#x96B1 . #xF0AC) + (#x96B2 . #xF0AD) + (#x96B3 . #x8FE6F0) + (#x96B4 . #xF0AF) + (#x96B6 . #xF0B0) + (#x96B7 . #xCEEC) + (#x96B8 . #xF0B1) + (#x96B9 . #xF0B2) + (#x96BA . #x8FE6F1) + (#x96BB . #xC0C9) + (#x96BC . #xC8BB) + (#x96C0 . #xBFFD) + (#x96C1 . #xB4E7) + (#x96C4 . #xCDBA) + (#x96C5 . #xB2ED) + (#x96C6 . #xBDB8) + (#x96C7 . #xB8DB) + (#x96C9 . #xF0B5) + (#x96CA . #x8FE6F2) + (#x96CB . #xF0B4) + (#x96CC . #xBBF3) + (#x96CD . #xF0B6) + (#x96CE . #xF0B3) + (#x96D1 . #xBBA8) + (#x96D2 . #x8FE6F3) + (#x96D5 . #xF0BA) + (#x96D6 . #xEAAD) + (#x96D8 . #x8FE6F5) + (#x96D9 . #xD2D6) + (#x96DA . #x8FE6F6) + (#x96DB . #xBFF7) + (#x96DC . #xF0B8) + (#x96DD . #x8FE6F7) + (#x96DE . #x8FE6F8) + (#x96DF . #x8FE6F9) + (#x96E2 . #xCEA5) + (#x96E3 . #xC6F1) + (#x96E8 . #xB1AB) + (#x96E9 . #x8FE6FA) + (#x96EA . #xC0E3) + (#x96EB . #xBCB6) + (#x96EF . #x8FE6FB) + (#x96F0 . #xCAB7) + (#x96F1 . #x8FE6FC) + (#x96F2 . #xB1C0) + (#x96F6 . #xCEED) + (#x96F7 . #xCDEB) + (#x96F9 . #xF0BB) + (#x96FA . #x8FE6FD) + (#x96FB . #xC5C5) + (#x9700 . #xBCFB) + (#x9702 . #x8FE6FE) + (#x9703 . #x8FE7A1) + (#x9704 . #xF0BC) + (#x9705 . #x8FE7A2) + (#x9706 . #xF0BD) + (#x9707 . #xBFCC) + (#x9708 . #xF0BE) + (#x9709 . #x8FE7A3) + (#x970A . #xCEEE) + (#x970D . #xF0B9) + (#x970E . #xF0C0) + (#x970F . #xF0C2) + (#x9711 . #xF0C1) + (#x9713 . #xF0BF) + (#x9716 . #xF0C3) + (#x9719 . #xF0C4) + (#x971A . #x8FE7A4) + (#x971B . #x8FE7A5) + (#x971C . #xC1FA) + (#x971D . #x8FE7A6) + (#x971E . #xB2E2) + (#x9721 . #x8FE7A7) + (#x9722 . #x8FE7A8) + (#x9723 . #x8FE7A9) + (#x9724 . #xF0C5) + (#x9727 . #xCCB8) + (#x9728 . #x8FE7AA) + (#x972A . #xF0C6) + (#x9730 . #xF0C7) + (#x9731 . #x8FE7AB) + (#x9732 . #xCFAA) + (#x9733 . #x8FE7AC) + (#x9738 . #xDBB1) + (#x9739 . #xF0C8) + (#x973D . #xF0C9) + (#x973E . #xF0CA) + (#x9741 . #x8FE7AD) + (#x9742 . #xF0CE) + (#x9743 . #x8FE7AE) + (#x9744 . #xF0CB) + (#x9746 . #xF0CC) + (#x9748 . #xF0CD) + (#x9749 . #xF0CF) + (#x974A . #x8FE7AF) + (#x974E . #x8FE7B0) + (#x974F . #x8FE7B1) + (#x9752 . #xC0C4) + (#x9755 . #x8FE7B2) + (#x9756 . #xCCF7) + (#x9757 . #x8FE7B3) + (#x9758 . #x8FE7B4) + (#x9759 . #xC0C5) + (#x975A . #x8FE7B5) + (#x975B . #x8FE7B6) + (#x975C . #xF0D0) + (#x975E . #xC8F3) + (#x9760 . #xF0D1) + (#x9761 . #xF3D3) + (#x9762 . #xCCCC) + (#x9763 . #x8FE7B7) + (#x9764 . #xF0D2) + (#x9766 . #xF0D3) + (#x9767 . #x8FE7B8) + (#x9768 . #xF0D4) + (#x9769 . #xB3D7) + (#x976A . #x8FE7B9) + (#x976B . #xF0D6) + (#x976D . #xBFD9) + (#x976E . #x8FE7BA) + (#x9771 . #xF0D7) + (#x9773 . #x8FE7BB) + (#x9774 . #xB7A4) + (#x9776 . #x8FE7BC) + (#x9777 . #x8FE7BD) + (#x9778 . #x8FE7BE) + (#x9779 . #xF0D8) + (#x977A . #xF0DC) + (#x977B . #x8FE7BF) + (#x977C . #xF0DA) + (#x977D . #x8FE7C0) + (#x977F . #x8FE7C1) + (#x9780 . #x8FE7C2) + (#x9781 . #xF0DB) + (#x9784 . #xB3F3) + (#x9785 . #xF0D9) + (#x9786 . #xF0DD) + (#x9789 . #x8FE7C3) + (#x978B . #xF0DE) + (#x978D . #xB0C8) + (#x978F . #xF0DF) + (#x9790 . #xF0E0) + (#x9795 . #x8FE7C4) + (#x9796 . #x8FE7C5) + (#x9797 . #x8FE7C6) + (#x9798 . #xBEE4) + (#x9799 . #x8FE7C7) + (#x979A . #x8FE7C8) + (#x979C . #xF0E1) + (#x979E . #x8FE7C9) + (#x979F . #x8FE7CA) + (#x97A0 . #xB5C7) + (#x97A2 . #x8FE7CB) + (#x97A3 . #xF0E4) + (#x97A6 . #xF0E3) + (#x97A8 . #xF0E2) + (#x97AB . #xEBF1) + (#x97AC . #x8FE7CC) + (#x97AD . #xCADC) + (#x97AE . #x8FE7CD) + (#x97B1 . #x8FE7CE) + (#x97B2 . #x8FE7CF) + (#x97B3 . #xF0E5) + (#x97B4 . #xF0E6) + (#x97B5 . #x8FE7D0) + (#x97B6 . #x8FE7D1) + (#x97B8 . #x8FE7D2) + (#x97B9 . #x8FE7D3) + (#x97BA . #x8FE7D4) + (#x97BC . #x8FE7D5) + (#x97BE . #x8FE7D6) + (#x97BF . #x8FE7D7) + (#x97C1 . #x8FE7D8) + (#x97C3 . #xF0E7) + (#x97C4 . #x8FE7D9) + (#x97C5 . #x8FE7DA) + (#x97C6 . #xF0E8) + (#x97C7 . #x8FE7DB) + (#x97C8 . #xF0E9) + (#x97C9 . #x8FE7DC) + (#x97CA . #x8FE7DD) + (#x97CB . #xF0EA) + (#x97CC . #x8FE7DE) + (#x97CD . #x8FE7DF) + (#x97CE . #x8FE7E0) + (#x97D0 . #x8FE7E1) + (#x97D1 . #x8FE7E2) + (#x97D3 . #xB4DA) + (#x97D4 . #x8FE7E3) + (#x97D7 . #x8FE7E4) + (#x97D8 . #x8FE7E5) + (#x97D9 . #x8FE7E6) + (#x97DB . #x8FE7EA) + (#x97DC . #xF0EB) + (#x97DD . #x8FE7E7) + (#x97DE . #x8FE7E8) + (#x97E0 . #x8FE7E9) + (#x97E1 . #x8FE7EB) + (#x97E4 . #x8FE7EC) + (#x97ED . #xF0EC) + (#x97EE . #xC7A3) + (#x97EF . #x8FE7ED) + (#x97F1 . #x8FE7EE) + (#x97F2 . #xF0EE) + (#x97F3 . #xB2BB) + (#x97F4 . #x8FE7EF) + (#x97F5 . #xF0F1) + (#x97F6 . #xF0F0) + (#x97F7 . #x8FE7F0) + (#x97F8 . #x8FE7F1) + (#x97FA . #x8FE7F2) + (#x97FB . #xB1A4) + (#x97FF . #xB6C1) + (#x9801 . #xCAC7) + (#x9802 . #xC4BA) + (#x9803 . #xBAA2) + (#x9805 . #xB9E0) + (#x9806 . #xBDE7) + (#x9807 . #x8FE7F3) + (#x9808 . #xBFDC) + (#x980A . #x8FE7F4) + (#x980C . #xF0F3) + (#x980D . #x8FE7F6) + (#x980E . #x8FE7F7) + (#x980F . #xF0F2) + (#x9810 . #xCDC2) + (#x9811 . #xB4E8) + (#x9812 . #xC8D2) + (#x9813 . #xC6DC) + (#x9814 . #x8FE7F8) + (#x9816 . #x8FE7F9) + (#x9817 . #xBFFC) + (#x9818 . #xCECE) + (#x9819 . #x8FE7F5) + (#x981A . #xB7DB) + (#x981C . #x8FE7FA) + (#x981E . #x8FE7FB) + (#x9820 . #x8FE7FC) + (#x9821 . #xF0F6) + (#x9823 . #x8FE7FD) + (#x9824 . #xF0F5) + (#x9825 . #x8FE8A8) + (#x9826 . #x8FE7FE) + (#x982B . #x8FE8A1) + (#x982C . #xCBCB) + (#x982D . #xC6AC) + (#x982E . #x8FE8A2) + (#x982F . #x8FE8A3) + (#x9830 . #x8FE8A4) + (#x9832 . #x8FE8A5) + (#x9833 . #x8FE8A6) + (#x9834 . #xB1D0) + (#x9835 . #x8FE8A7) + (#x9837 . #xF0F7) + (#x9838 . #xF0F4) + (#x983B . #xC9D1) + (#x983C . #xCDEA) + (#x983D . #xF0F8) + (#x983E . #x8FE8A9) + (#x9844 . #x8FE8AA) + (#x9846 . #xF0F9) + (#x9847 . #x8FE8AB) + (#x984A . #x8FE8AC) + (#x984B . #xF0FB) + (#x984C . #xC2EA) + (#x984D . #xB3DB) + (#x984E . #xB3DC) + (#x984F . #xF0FA) + (#x9851 . #x8FE8AD) + (#x9852 . #x8FE8AE) + (#x9853 . #x8FE8AF) + (#x9854 . #xB4E9) + (#x9855 . #xB8B2) + (#x9856 . #x8FE8B0) + (#x9857 . #x8FE8B1) + (#x9858 . #xB4EA) + (#x9859 . #x8FE8B2) + (#x985A . #x8FE8B3) + (#x985B . #xC5BF) + (#x985E . #xCEE0) + (#x9862 . #x8FE8B4) + (#x9863 . #x8FE8B5) + (#x9865 . #x8FE8B6) + (#x9866 . #x8FE8B7) + (#x9867 . #xB8DC) + (#x986A . #x8FE8B8) + (#x986B . #xF0FC) + (#x986C . #x8FE8B9) + (#x986F . #xF0FD) + (#x9870 . #xF0FE) + (#x9871 . #xF1A1) + (#x9873 . #xF1A3) + (#x9874 . #xF1A2) + (#x98A8 . #xC9F7) + (#x98AA . #xF1A4) + (#x98AB . #x8FE8BA) + (#x98AD . #x8FE8BB) + (#x98AE . #x8FE8BC) + (#x98AF . #xF1A5) + (#x98B0 . #x8FE8BD) + (#x98B1 . #xF1A6) + (#x98B4 . #x8FE8BE) + (#x98B6 . #xF1A7) + (#x98B7 . #x8FE8BF) + (#x98B8 . #x8FE8C0) + (#x98BA . #x8FE8C1) + (#x98BB . #x8FE8C2) + (#x98BF . #x8FE8C3) + (#x98C2 . #x8FE8C4) + (#x98C3 . #xF1A9) + (#x98C4 . #xF1A8) + (#x98C5 . #x8FE8C5) + (#x98C6 . #xF1AA) + (#x98C8 . #x8FE8C6) + (#x98CC . #x8FE8C7) + (#x98DB . #xC8F4) + (#x98DC . #xE6CC) + (#x98DF . #xBFA9) + (#x98E1 . #x8FE8C8) + (#x98E2 . #xB5B2) + (#x98E3 . #x8FE8C9) + (#x98E5 . #x8FE8CA) + (#x98E6 . #x8FE8CB) + (#x98E7 . #x8FE8CC) + (#x98E9 . #xF1AB) + (#x98EA . #x8FE8CD) + (#x98EB . #xF1AC) + (#x98ED . #xD2AC) + (#x98EE . #xDDBB) + (#x98EF . #xC8D3) + (#x98F2 . #xB0FB) + (#x98F3 . #x8FE8CE) + (#x98F4 . #xB0BB) + (#x98F6 . #x8FE8CF) + (#x98FC . #xBBF4) + (#x98FD . #xCBB0) + (#x98FE . #xBEFE) + (#x9902 . #x8FE8D0) + (#x9903 . #xF1AD) + (#x9905 . #xCCDF) + (#x9907 . #x8FE8D1) + (#x9908 . #x8FE8D2) + (#x9909 . #xF1AE) + (#x990A . #xCDDC) + (#x990C . #xB1C2) + (#x9910 . #xBBC1) + (#x9911 . #x8FE8D3) + (#x9912 . #xF1AF) + (#x9913 . #xB2EE) + (#x9914 . #xF1B0) + (#x9915 . #x8FE8D4) + (#x9916 . #x8FE8D5) + (#x9917 . #x8FE8D6) + (#x9918 . #xF1B1) + (#x991A . #x8FE8D7) + (#x991B . #x8FE8D8) + (#x991C . #x8FE8D9) + (#x991D . #xF1B3) + (#x991E . #xF1B4) + (#x991F . #x8FE8DA) + (#x9920 . #xF1B6) + (#x9921 . #xF1B2) + (#x9922 . #x8FE8DB) + (#x9924 . #xF1B5) + (#x9926 . #x8FE8DC) + (#x9927 . #x8FE8DD) + (#x9928 . #xB4DB) + (#x992B . #x8FE8DE) + (#x992C . #xF1B7) + (#x992E . #xF1B8) + (#x9931 . #x8FE8DF) + (#x9932 . #x8FE8E0) + (#x9933 . #x8FE8E1) + (#x9934 . #x8FE8E2) + (#x9935 . #x8FE8E3) + (#x9939 . #x8FE8E4) + (#x993A . #x8FE8E5) + (#x993B . #x8FE8E6) + (#x993C . #x8FE8E7) + (#x993D . #xF1B9) + (#x993E . #xF1BA) + (#x9940 . #x8FE8E8) + (#x9941 . #x8FE8E9) + (#x9942 . #xF1BB) + (#x9945 . #xF1BD) + (#x9946 . #x8FE8EA) + (#x9947 . #x8FE8EB) + (#x9948 . #x8FE8EC) + (#x9949 . #xF1BC) + (#x994B . #xF1BF) + (#x994C . #xF1C2) + (#x994D . #x8FE8ED) + (#x994E . #x8FE8EE) + (#x9950 . #xF1BE) + (#x9951 . #xF1C0) + (#x9952 . #xF1C1) + (#x9954 . #x8FE8EF) + (#x9955 . #xF1C3) + (#x9957 . #xB6C2) + (#x9958 . #x8FE8F0) + (#x9959 . #x8FE8F1) + (#x995B . #x8FE8F2) + (#x995C . #x8FE8F3) + (#x995E . #x8FE8F4) + (#x995F . #x8FE8F5) + (#x9960 . #x8FE8F6) + (#x9996 . #xBCF3) + (#x9997 . #xF1C4) + (#x9998 . #xF1C5) + (#x9999 . #xB9E1) + (#x999B . #x8FE8F7) + (#x999D . #x8FE8F8) + (#x999F . #x8FE8F9) + (#x99A5 . #xF1C6) + (#x99A6 . #x8FE8FA) + (#x99A8 . #xB3BE) + (#x99AC . #xC7CF) + (#x99AD . #xF1C7) + (#x99AE . #xF1C8) + (#x99B0 . #x8FE8FB) + (#x99B1 . #x8FE8FC) + (#x99B2 . #x8FE8FD) + (#x99B3 . #xC3DA) + (#x99B4 . #xC6EB) + (#x99B5 . #x8FE8FE) + (#x99B9 . #x8FE9A1) + (#x99BA . #x8FE9A2) + (#x99BC . #xF1C9) + (#x99BD . #x8FE9A3) + (#x99BF . #x8FE9A4) + (#x99C1 . #xC7FD) + (#x99C3 . #x8FE9A5) + (#x99C4 . #xC2CC) + (#x99C5 . #xB1D8) + (#x99C6 . #xB6EE) + (#x99C8 . #xB6EF) + (#x99C9 . #x8FE9A6) + (#x99D0 . #xC3F3) + (#x99D1 . #xF1CE) + (#x99D2 . #xB6F0) + (#x99D3 . #x8FE9A7) + (#x99D4 . #x8FE9A8) + (#x99D5 . #xB2EF) + (#x99D8 . #xF1CD) + (#x99D9 . #x8FE9A9) + (#x99DA . #x8FE9AA) + (#x99DB . #xF1CB) + (#x99DC . #x8FE9AB) + (#x99DD . #xF1CC) + (#x99DE . #x8FE9AC) + (#x99DF . #xF1CA) + (#x99E2 . #xF1D8) + (#x99E7 . #x8FE9AD) + (#x99EA . #x8FE9AE) + (#x99EB . #x8FE9AF) + (#x99EC . #x8FE9B0) + (#x99ED . #xF1CF) + (#x99EE . #xF1D0) + (#x99F0 . #x8FE9B1) + (#x99F1 . #xF1D1) + (#x99F2 . #xF1D2) + (#x99F4 . #x8FE9B2) + (#x99F5 . #x8FE9B3) + (#x99F8 . #xF1D4) + (#x99F9 . #x8FE9B4) + (#x99FB . #xF1D3) + (#x99FD . #x8FE9B5) + (#x99FE . #x8FE9B6) + (#x99FF . #xBDD9) + (#x9A01 . #xF1D5) + (#x9A02 . #x8FE9B7) + (#x9A03 . #x8FE9B8) + (#x9A04 . #x8FE9B9) + (#x9A05 . #xF1D7) + (#x9A0B . #x8FE9BA) + (#x9A0C . #x8FE9BB) + (#x9A0E . #xB5B3) + (#x9A0F . #xF1D6) + (#x9A10 . #x8FE9BC) + (#x9A11 . #x8FE9BD) + (#x9A12 . #xC1FB) + (#x9A13 . #xB8B3) + (#x9A16 . #x8FE9BE) + (#x9A19 . #xF1D9) + (#x9A1E . #x8FE9BF) + (#x9A20 . #x8FE9C0) + (#x9A22 . #x8FE9C1) + (#x9A23 . #x8FE9C2) + (#x9A24 . #x8FE9C3) + (#x9A27 . #x8FE9C4) + (#x9A28 . #xC2CD) + (#x9A2B . #xF1DA) + (#x9A2D . #x8FE9C5) + (#x9A2E . #x8FE9C6) + (#x9A30 . #xC6AD) + (#x9A33 . #x8FE9C7) + (#x9A35 . #x8FE9C8) + (#x9A36 . #x8FE9C9) + (#x9A37 . #xF1DB) + (#x9A38 . #x8FE9CA) + (#x9A3E . #xF1E0) + (#x9A40 . #xF1DE) + (#x9A41 . #x8FE9CC) + (#x9A42 . #xF1DD) + (#x9A43 . #xF1DF) + (#x9A44 . #x8FE9CD) + (#x9A45 . #xF1DC) + (#x9A47 . #x8FE9CB) + (#x9A4A . #x8FE9CE) + (#x9A4B . #x8FE9CF) + (#x9A4C . #x8FE9D0) + (#x9A4D . #xF1E2) + (#x9A4E . #x8FE9D1) + (#x9A51 . #x8FE9D2) + (#x9A54 . #x8FE9D3) + (#x9A55 . #xF1E1) + (#x9A56 . #x8FE9D4) + (#x9A57 . #xF1E4) + (#x9A5A . #xB6C3) + (#x9A5B . #xF1E3) + (#x9A5D . #x8FE9D5) + (#x9A5F . #xF1E5) + (#x9A62 . #xF1E6) + (#x9A64 . #xF1E8) + (#x9A65 . #xF1E7) + (#x9A69 . #xF1E9) + (#x9A6A . #xF1EB) + (#x9A6B . #xF1EA) + (#x9AA8 . #xB9FC) + (#x9AAA . #x8FE9D6) + (#x9AAC . #x8FE9D7) + (#x9AAD . #xF1EC) + (#x9AAE . #x8FE9D8) + (#x9AAF . #x8FE9D9) + (#x9AB0 . #xF1ED) + (#x9AB2 . #x8FE9DA) + (#x9AB4 . #x8FE9DB) + (#x9AB5 . #x8FE9DC) + (#x9AB6 . #x8FE9DD) + (#x9AB8 . #xB3BC) + (#x9AB9 . #x8FE9DE) + (#x9ABB . #x8FE9DF) + (#x9ABC . #xF1EE) + (#x9ABE . #x8FE9E0) + (#x9ABF . #x8FE9E1) + (#x9AC0 . #xF1EF) + (#x9AC1 . #x8FE9E2) + (#x9AC3 . #x8FE9E3) + (#x9AC4 . #xBFF1) + (#x9AC6 . #x8FE9E4) + (#x9AC8 . #x8FE9E5) + (#x9ACE . #x8FE9E6) + (#x9ACF . #xF1F0) + (#x9AD0 . #x8FE9E7) + (#x9AD1 . #xF1F1) + (#x9AD2 . #x8FE9E8) + (#x9AD3 . #xF1F2) + (#x9AD4 . #xF1F3) + (#x9AD5 . #x8FE9E9) + (#x9AD6 . #x8FE9EA) + (#x9AD7 . #x8FE9EB) + (#x9AD8 . #xB9E2) + (#x9ADB . #x8FE9EC) + (#x9ADC . #x8FE9ED) + (#x9ADE . #xF1F4) + (#x9ADF . #xF1F5) + (#x9AE0 . #x8FE9EE) + (#x9AE2 . #xF1F6) + (#x9AE3 . #xF1F7) + (#x9AE4 . #x8FE9EF) + (#x9AE5 . #x8FE9F0) + (#x9AE6 . #xF1F8) + (#x9AE7 . #x8FE9F1) + (#x9AE9 . #x8FE9F2) + (#x9AEA . #xC8B1) + (#x9AEB . #xF1FA) + (#x9AEC . #x8FE9F3) + (#x9AED . #xC9A6) + (#x9AEE . #xF1FB) + (#x9AEF . #xF1F9) + (#x9AF1 . #xF1FD) + (#x9AF2 . #x8FE9F4) + (#x9AF3 . #x8FE9F5) + (#x9AF4 . #xF1FC) + (#x9AF5 . #x8FE9F6) + (#x9AF7 . #xF1FE) + (#x9AF9 . #x8FE9F7) + (#x9AFA . #x8FE9F8) + (#x9AFB . #xF2A1) + (#x9AFD . #x8FE9F9) + (#x9AFF . #x8FE9FA) + (#x9B00 . #x8FE9FB) + (#x9B01 . #x8FE9FC) + (#x9B02 . #x8FE9FD) + (#x9B03 . #x8FE9FE) + (#x9B04 . #x8FEAA1) + (#x9B05 . #x8FEAA2) + (#x9B06 . #xF2A2) + (#x9B08 . #x8FEAA3) + (#x9B09 . #x8FEAA4) + (#x9B0B . #x8FEAA5) + (#x9B0C . #x8FEAA6) + (#x9B0D . #x8FEAA7) + (#x9B0E . #x8FEAA8) + (#x9B10 . #x8FEAA9) + (#x9B12 . #x8FEAAA) + (#x9B16 . #x8FEAAB) + (#x9B18 . #xF2A3) + (#x9B19 . #x8FEAAC) + (#x9B1A . #xF2A4) + (#x9B1B . #x8FEAAD) + (#x9B1C . #x8FEAAE) + (#x9B1F . #xF2A5) + (#x9B20 . #x8FEAAF) + (#x9B22 . #xF2A6) + (#x9B23 . #xF2A7) + (#x9B25 . #xF2A8) + (#x9B26 . #x8FEAB0) + (#x9B27 . #xF2A9) + (#x9B28 . #xF2AA) + (#x9B29 . #xF2AB) + (#x9B2A . #xF2AC) + (#x9B2B . #x8FEAB1) + (#x9B2D . #x8FEAB2) + (#x9B2E . #xF2AD) + (#x9B2F . #xF2AE) + (#x9B31 . #xDDB5) + (#x9B32 . #xF2AF) + (#x9B33 . #x8FEAB3) + (#x9B34 . #x8FEAB4) + (#x9B35 . #x8FEAB5) + (#x9B37 . #x8FEAB6) + (#x9B39 . #x8FEAB7) + (#x9B3A . #x8FEAB8) + (#x9B3B . #xE4F8) + (#x9B3C . #xB5B4) + (#x9B3D . #x8FEAB9) + (#x9B41 . #xB3A1) + (#x9B42 . #xBAB2) + (#x9B43 . #xF2B1) + (#x9B44 . #xF2B0) + (#x9B45 . #xCCA5) + (#x9B48 . #x8FEABA) + (#x9B4B . #x8FEABB) + (#x9B4C . #x8FEABC) + (#x9B4D . #xF2B3) + (#x9B4E . #xF2B4) + (#x9B4F . #xF2B2) + (#x9B51 . #xF2B5) + (#x9B54 . #xCBE2) + (#x9B55 . #x8FEABD) + (#x9B56 . #x8FEABE) + (#x9B57 . #x8FEABF) + (#x9B58 . #xF2B6) + (#x9B5A . #xB5FB) + (#x9B5B . #x8FEAC0) + (#x9B5E . #x8FEAC1) + (#x9B61 . #x8FEAC2) + (#x9B63 . #x8FEAC3) + (#x9B65 . #x8FEAC4) + (#x9B66 . #x8FEAC5) + (#x9B68 . #x8FEAC6) + (#x9B6A . #x8FEAC7) + (#x9B6B . #x8FEAC8) + (#x9B6C . #x8FEAC9) + (#x9B6D . #x8FEACA) + (#x9B6E . #x8FEACB) + (#x9B6F . #xCFA5) + (#x9B73 . #x8FEACC) + (#x9B74 . #xF2B7) + (#x9B75 . #x8FEACD) + (#x9B77 . #x8FEACE) + (#x9B78 . #x8FEACF) + (#x9B79 . #x8FEAD0) + (#x9B7F . #x8FEAD1) + (#x9B80 . #x8FEAD2) + (#x9B83 . #xF2B9) + (#x9B84 . #x8FEAD3) + (#x9B85 . #x8FEAD4) + (#x9B86 . #x8FEAD5) + (#x9B87 . #x8FEAD6) + (#x9B89 . #x8FEAD7) + (#x9B8A . #x8FEAD8) + (#x9B8B . #x8FEAD9) + (#x9B8D . #x8FEADA) + (#x9B8E . #xB0BE) + (#x9B8F . #x8FEADB) + (#x9B90 . #x8FEADC) + (#x9B91 . #xF2BA) + (#x9B92 . #xCAAB) + (#x9B93 . #xF2B8) + (#x9B94 . #x8FEADD) + (#x9B96 . #xF2BB) + (#x9B97 . #xF2BC) + (#x9B9A . #x8FEADE) + (#x9B9D . #x8FEADF) + (#x9B9E . #x8FEAE0) + (#x9B9F . #xF2BD) + (#x9BA0 . #xF2BE) + (#x9BA6 . #x8FEAE1) + (#x9BA7 . #x8FEAE2) + (#x9BA8 . #xF2BF) + (#x9BA9 . #x8FEAE3) + (#x9BAA . #xCBEE) + (#x9BAB . #xBBAD) + (#x9BAC . #x8FEAE4) + (#x9BAD . #xBAFA) + (#x9BAE . #xC1AF) + (#x9BB0 . #x8FEAE5) + (#x9BB1 . #x8FEAE6) + (#x9BB2 . #x8FEAE7) + (#x9BB4 . #xF2C0) + (#x9BB7 . #x8FEAE8) + (#x9BB8 . #x8FEAE9) + (#x9BB9 . #xF2C3) + (#x9BBB . #x8FEAEA) + (#x9BBC . #x8FEAEB) + (#x9BBE . #x8FEAEC) + (#x9BBF . #x8FEAED) + (#x9BC0 . #xF2C1) + (#x9BC1 . #x8FEAEE) + (#x9BC6 . #xF2C4) + (#x9BC7 . #x8FEAEF) + (#x9BC8 . #x8FEAF0) + (#x9BC9 . #xB8F1) + (#x9BCA . #xF2C2) + (#x9BCE . #x8FEAF1) + (#x9BCF . #xF2C5) + (#x9BD0 . #x8FEAF2) + (#x9BD1 . #xF2C6) + (#x9BD2 . #xF2C7) + (#x9BD4 . #xF2CB) + (#x9BD6 . #xBBAA) + (#x9BD7 . #x8FEAF3) + (#x9BD8 . #x8FEAF4) + (#x9BDB . #xC2E4) + (#x9BDD . #x8FEAF5) + (#x9BDF . #x8FEAF6) + (#x9BE1 . #xF2CC) + (#x9BE2 . #xF2C9) + (#x9BE3 . #xF2C8) + (#x9BE4 . #xF2CA) + (#x9BE5 . #x8FEAF7) + (#x9BE7 . #x8FEAF8) + (#x9BE8 . #xB7DF) + (#x9BEA . #x8FEAF9) + (#x9BEB . #x8FEAFA) + (#x9BEF . #x8FEAFB) + (#x9BF0 . #xF2D0) + (#x9BF1 . #xF2CF) + (#x9BF2 . #xF2CE) + (#x9BF3 . #x8FEAFC) + (#x9BF5 . #xB0B3) + (#x9BF7 . #x8FEAFD) + (#x9BF8 . #x8FEAFE) + (#x9BF9 . #x8FEBA1) + (#x9BFA . #x8FEBA2) + (#x9BFD . #x8FEBA3) + (#x9BFF . #x8FEBA4) + (#x9C00 . #x8FEBA5) + (#x9C02 . #x8FEBA6) + (#x9C04 . #xF2DA) + (#x9C06 . #xF2D6) + (#x9C08 . #xF2D7) + (#x9C09 . #xF2D3) + (#x9C0A . #xF2D9) + (#x9C0B . #x8FEBA7) + (#x9C0C . #xF2D5) + (#x9C0D . #xB3E2) + (#x9C0F . #x8FEBA8) + (#x9C10 . #xCFCC) + (#x9C11 . #x8FEBA9) + (#x9C12 . #xF2D8) + (#x9C13 . #xF2D4) + (#x9C14 . #xF2D2) + (#x9C15 . #xF2D1) + (#x9C16 . #x8FEBAA) + (#x9C18 . #x8FEBAB) + (#x9C19 . #x8FEBAC) + (#x9C1A . #x8FEBAD) + (#x9C1B . #xF2DC) + (#x9C1C . #x8FEBAE) + (#x9C1E . #x8FEBAF) + (#x9C21 . #xF2DF) + (#x9C22 . #x8FEBB0) + (#x9C23 . #x8FEBB1) + (#x9C24 . #xF2DE) + (#x9C25 . #xF2DD) + (#x9C26 . #x8FEBB2) + (#x9C27 . #x8FEBB3) + (#x9C28 . #x8FEBB4) + (#x9C29 . #x8FEBB5) + (#x9C2A . #x8FEBB6) + (#x9C2D . #xC9C9) + (#x9C2E . #xF2DB) + (#x9C2F . #xB0F3) + (#x9C30 . #xF2E0) + (#x9C31 . #x8FEBB7) + (#x9C32 . #xF2E2) + (#x9C35 . #x8FEBB8) + (#x9C36 . #x8FEBB9) + (#x9C37 . #x8FEBBA) + (#x9C39 . #xB3EF) + (#x9C3A . #xF2CD) + (#x9C3B . #xB1B7) + (#x9C3D . #x8FEBBB) + (#x9C3E . #xF2E4) + (#x9C41 . #x8FEBBC) + (#x9C43 . #x8FEBBD) + (#x9C44 . #x8FEBBE) + (#x9C45 . #x8FEBBF) + (#x9C46 . #xF2E3) + (#x9C47 . #xF2E1) + (#x9C48 . #xC3AD) + (#x9C49 . #x8FEBC0) + (#x9C4A . #x8FEBC1) + (#x9C4E . #x8FEBC2) + (#x9C4F . #x8FEBC3) + (#x9C50 . #x8FEBC4) + (#x9C52 . #xCBF0) + (#x9C53 . #x8FEBC5) + (#x9C54 . #x8FEBC6) + (#x9C56 . #x8FEBC7) + (#x9C57 . #xCEDA) + (#x9C58 . #x8FEBC8) + (#x9C5A . #xF2E5) + (#x9C5B . #x8FEBC9) + (#x9C5C . #x8FEBD0) + (#x9C5D . #x8FEBCA) + (#x9C5E . #x8FEBCB) + (#x9C5F . #x8FEBCC) + (#x9C60 . #xF2E6) + (#x9C63 . #x8FEBCD) + (#x9C67 . #xF2E7) + (#x9C68 . #x8FEBD2) + (#x9C69 . #x8FEBCE) + (#x9C6A . #x8FEBCF) + (#x9C6B . #x8FEBD1) + (#x9C6E . #x8FEBD3) + (#x9C70 . #x8FEBD4) + (#x9C72 . #x8FEBD5) + (#x9C75 . #x8FEBD6) + (#x9C76 . #xF2E8) + (#x9C77 . #x8FEBD7) + (#x9C78 . #xF2E9) + (#x9C7B . #x8FEBD8) + (#x9CE5 . #xC4BB) + (#x9CE6 . #x8FEBD9) + (#x9CE7 . #xF2EA) + (#x9CE9 . #xC8B7) + (#x9CEB . #xF2EF) + (#x9CEC . #xF2EB) + (#x9CF0 . #xF2EC) + (#x9CF2 . #x8FEBDA) + (#x9CF3 . #xCBB1) + (#x9CF4 . #xCCC4) + (#x9CF6 . #xC6D0) + (#x9CF7 . #x8FEBDB) + (#x9CF9 . #x8FEBDC) + (#x9D02 . #x8FEBDE) + (#x9D03 . #xF2F0) + (#x9D06 . #xF2F1) + (#x9D07 . #xC6BE) + (#x9D08 . #xF2EE) + (#x9D09 . #xF2ED) + (#x9D0B . #x8FEBDD) + (#x9D0E . #xB2AA) + (#x9D11 . #x8FEBDF) + (#x9D12 . #xF2F9) + (#x9D15 . #xF2F8) + (#x9D17 . #x8FEBE0) + (#x9D18 . #x8FEBE1) + (#x9D1B . #xB1F5) + (#x9D1C . #x8FEBE2) + (#x9D1D . #x8FEBE3) + (#x9D1E . #x8FEBE4) + (#x9D1F . #xF2F6) + (#x9D23 . #xF2F5) + (#x9D26 . #xF2F3) + (#x9D28 . #xB3FB) + (#x9D2A . #xF2F2) + (#x9D2B . #xBCB2) + (#x9D2C . #xB2A9) + (#x9D2F . #x8FEBE5) + (#x9D30 . #x8FEBE6) + (#x9D32 . #x8FEBE7) + (#x9D33 . #x8FEBE8) + (#x9D34 . #x8FEBE9) + (#x9D3A . #x8FEBEA) + (#x9D3B . #xB9E3) + (#x9D3C . #x8FEBEB) + (#x9D3D . #x8FEBED) + (#x9D3E . #xF2FC) + (#x9D3F . #xF2FB) + (#x9D41 . #xF2FA) + (#x9D42 . #x8FEBEE) + (#x9D43 . #x8FEBEF) + (#x9D44 . #xF2F7) + (#x9D45 . #x8FEBEC) + (#x9D46 . #xF2FD) + (#x9D47 . #x8FEBF0) + (#x9D48 . #xF2FE) + (#x9D4A . #x8FEBF1) + (#x9D50 . #xF3A5) + (#x9D51 . #xF3A4) + (#x9D53 . #x8FEBF2) + (#x9D54 . #x8FEBF3) + (#x9D59 . #xF3A6) + (#x9D5C . #xB1AD) + (#x9D5D . #xF3A1) + (#x9D5E . #xF3A2) + (#x9D5F . #x8FEBF4) + (#x9D60 . #xB9F4) + (#x9D61 . #xCCB9) + (#x9D62 . #x8FEBF6) + (#x9D63 . #x8FEBF5) + (#x9D64 . #xF3A3) + (#x9D65 . #x8FEBF7) + (#x9D69 . #x8FEBF8) + (#x9D6A . #x8FEBF9) + (#x9D6B . #x8FEBFA) + (#x9D6C . #xCBB2) + (#x9D6F . #xF3AB) + (#x9D70 . #x8FEBFB) + (#x9D72 . #xF3A7) + (#x9D76 . #x8FEBFC) + (#x9D77 . #x8FEBFD) + (#x9D7A . #xF3AC) + (#x9D7B . #x8FEBFE) + (#x9D7C . #x8FECA1) + (#x9D7E . #x8FECA2) + (#x9D83 . #x8FECA3) + (#x9D84 . #x8FECA4) + (#x9D86 . #x8FECA5) + (#x9D87 . #xF3A9) + (#x9D89 . #xF3A8) + (#x9D8A . #x8FECA6) + (#x9D8D . #x8FECA7) + (#x9D8E . #x8FECA8) + (#x9D8F . #xB7DC) + (#x9D92 . #x8FECA9) + (#x9D93 . #x8FECAA) + (#x9D95 . #x8FECAB) + (#x9D96 . #x8FECAC) + (#x9D97 . #x8FECAD) + (#x9D98 . #x8FECAE) + (#x9D9A . #xF3AD) + (#x9DA1 . #x8FECAF) + (#x9DA4 . #xF3AE) + (#x9DA9 . #xF3AF) + (#x9DAA . #x8FECB0) + (#x9DAB . #xF3AA) + (#x9DAC . #x8FECB1) + (#x9DAE . #x8FECB2) + (#x9DAF . #xF2F4) + (#x9DB1 . #x8FECB3) + (#x9DB2 . #xF3B0) + (#x9DB4 . #xC4E1) + (#x9DB5 . #x8FECB4) + (#x9DB8 . #xF3B4) + (#x9DB9 . #x8FECB5) + (#x9DBA . #xF3B5) + (#x9DBB . #xF3B3) + (#x9DBC . #x8FECB6) + (#x9DBF . #x8FECB7) + (#x9DC1 . #xF3B2) + (#x9DC2 . #xF3B8) + (#x9DC3 . #x8FECB8) + (#x9DC4 . #xF3B1) + (#x9DC6 . #xF3B6) + (#x9DC7 . #x8FECB9) + (#x9DC9 . #x8FECBA) + (#x9DCA . #x8FECBB) + (#x9DCF . #xF3B7) + (#x9DD3 . #xF3BA) + (#x9DD4 . #x8FECBC) + (#x9DD5 . #x8FECBD) + (#x9DD6 . #x8FECBE) + (#x9DD7 . #x8FECBF) + (#x9DD9 . #xF3B9) + (#x9DDA . #x8FECC0) + (#x9DDE . #x8FECC1) + (#x9DDF . #x8FECC2) + (#x9DE0 . #x8FECC3) + (#x9DE5 . #x8FECC4) + (#x9DE6 . #xF3BC) + (#x9DE7 . #x8FECC5) + (#x9DE9 . #x8FECC6) + (#x9DEB . #x8FECC7) + (#x9DED . #xF3BD) + (#x9DEE . #x8FECC8) + (#x9DEF . #xF3BE) + (#x9DF0 . #x8FECC9) + (#x9DF2 . #xCFC9) + (#x9DF3 . #x8FECCA) + (#x9DF4 . #x8FECCB) + (#x9DF8 . #xF3BB) + (#x9DF9 . #xC2EB) + (#x9DFA . #xBAED) + (#x9DFD . #xF3BF) + (#x9DFE . #x8FECCC) + (#x9E02 . #x8FECCE) + (#x9E07 . #x8FECCF) + (#x9E0A . #x8FECCD) + (#x9E0E . #x8FECD0) + (#x9E10 . #x8FECD1) + (#x9E11 . #x8FECD2) + (#x9E12 . #x8FECD3) + (#x9E15 . #x8FECD4) + (#x9E16 . #x8FECD5) + (#x9E19 . #x8FECD6) + (#x9E1A . #xF3C0) + (#x9E1B . #xF3C1) + (#x9E1C . #x8FECD7) + (#x9E1D . #x8FECD8) + (#x9E1E . #xF3C2) + (#x9E75 . #xF3C3) + (#x9E78 . #xB8B4) + (#x9E79 . #xF3C4) + (#x9E7A . #x8FECD9) + (#x9E7B . #x8FECDA) + (#x9E7C . #x8FECDB) + (#x9E7D . #xF3C5) + (#x9E7F . #xBCAF) + (#x9E80 . #x8FECDC) + (#x9E81 . #xF3C6) + (#x9E82 . #x8FECDD) + (#x9E83 . #x8FECDE) + (#x9E84 . #x8FECDF) + (#x9E85 . #x8FECE0) + (#x9E87 . #x8FECE1) + (#x9E88 . #xF3C7) + (#x9E8B . #xF3C8) + (#x9E8C . #xF3C9) + (#x9E8E . #x8FECE2) + (#x9E8F . #x8FECE3) + (#x9E91 . #xF3CC) + (#x9E92 . #xF3CA) + (#x9E93 . #xCFBC) + (#x9E95 . #xF3CB) + (#x9E96 . #x8FECE4) + (#x9E97 . #xCEEF) + (#x9E98 . #x8FECE5) + (#x9E9B . #x8FECE6) + (#x9E9D . #xF3CD) + (#x9E9E . #x8FECE7) + (#x9E9F . #xCEDB) + (#x9EA4 . #x8FECE8) + (#x9EA5 . #xF3CE) + (#x9EA6 . #xC7FE) + (#x9EA8 . #x8FECE9) + (#x9EA9 . #xF3CF) + (#x9EAA . #xF3D1) + (#x9EAC . #x8FECEA) + (#x9EAD . #xF3D2) + (#x9EAE . #x8FECEB) + (#x9EAF . #x8FECEC) + (#x9EB0 . #x8FECED) + (#x9EB3 . #x8FECEE) + (#x9EB4 . #x8FECEF) + (#x9EB5 . #x8FECF0) + (#x9EB8 . #xF3D0) + (#x9EB9 . #xB9ED) + (#x9EBA . #xCCCD) + (#x9EBB . #xCBE3) + (#x9EBC . #xD6F7) + (#x9EBE . #xDDE0) + (#x9EBF . #xCBFB) + (#x9EC4 . #xB2AB) + (#x9EC6 . #x8FECF1) + (#x9EC8 . #x8FECF2) + (#x9ECB . #x8FECF3) + (#x9ECC . #xF3D4) + (#x9ECD . #xB5D0) + (#x9ECE . #xF3D5) + (#x9ECF . #xF3D6) + (#x9ED0 . #xF3D7) + (#x9ED2 . #xB9F5) + (#x9ED4 . #xF3D8) + (#x9ED5 . #x8FECF4) + (#x9ED8 . #xE0D4) + (#x9ED9 . #xCCDB) + (#x9EDB . #xC2E3) + (#x9EDC . #xF3D9) + (#x9EDD . #xF3DB) + (#x9EDE . #xF3DA) + (#x9EDF . #x8FECF5) + (#x9EE0 . #xF3DC) + (#x9EE4 . #x8FECF6) + (#x9EE5 . #xF3DD) + (#x9EE7 . #x8FECF7) + (#x9EE8 . #xF3DE) + (#x9EEC . #x8FECF8) + (#x9EED . #x8FECF9) + (#x9EEE . #x8FECFA) + (#x9EEF . #xF3DF) + (#x9EF0 . #x8FECFB) + (#x9EF1 . #x8FECFC) + (#x9EF2 . #x8FECFD) + (#x9EF4 . #xF3E0) + (#x9EF5 . #x8FECFE) + (#x9EF6 . #xF3E1) + (#x9EF7 . #xF3E2) + (#x9EF8 . #x8FEDA1) + (#x9EF9 . #xF3E3) + (#x9EFB . #xF3E4) + (#x9EFC . #xF3E5) + (#x9EFD . #xF3E6) + (#x9EFF . #x8FEDA2) + (#x9F02 . #x8FEDA3) + (#x9F03 . #x8FEDA4) + (#x9F07 . #xF3E7) + (#x9F08 . #xF3E8) + (#x9F09 . #x8FEDA5) + (#x9F0E . #xC5A4) + (#x9F0F . #x8FEDA6) + (#x9F10 . #x8FEDA7) + (#x9F11 . #x8FEDA8) + (#x9F12 . #x8FEDA9) + (#x9F13 . #xB8DD) + (#x9F14 . #x8FEDAA) + (#x9F15 . #xF3EA) + (#x9F16 . #x8FEDAB) + (#x9F17 . #x8FEDAC) + (#x9F19 . #x8FEDAD) + (#x9F1A . #x8FEDAE) + (#x9F1B . #x8FEDAF) + (#x9F1F . #x8FEDB0) + (#x9F20 . #xC1CD) + (#x9F21 . #xF3EB) + (#x9F22 . #x8FEDB1) + (#x9F26 . #x8FEDB2) + (#x9F2A . #x8FEDB3) + (#x9F2B . #x8FEDB4) + (#x9F2C . #xF3EC) + (#x9F2F . #x8FEDB5) + (#x9F31 . #x8FEDB6) + (#x9F32 . #x8FEDB7) + (#x9F34 . #x8FEDB8) + (#x9F37 . #x8FEDB9) + (#x9F39 . #x8FEDBA) + (#x9F3A . #x8FEDBB) + (#x9F3B . #xC9A1) + (#x9F3C . #x8FEDBC) + (#x9F3D . #x8FEDBD) + (#x9F3E . #xF3ED) + (#x9F3F . #x8FEDBE) + (#x9F41 . #x8FEDBF) + (#x9F43 . #x8FEDC0) + (#x9F44 . #x8FEDC1) + (#x9F45 . #x8FEDC2) + (#x9F46 . #x8FEDC3) + (#x9F47 . #x8FEDC4) + (#x9F4A . #xF3EE) + (#x9F4B . #xE3B7) + (#x9F4E . #xECDA) + (#x9F4F . #xF0ED) + (#x9F52 . #xF3EF) + (#x9F53 . #x8FEDC5) + (#x9F54 . #xF3F0) + (#x9F55 . #x8FEDC6) + (#x9F56 . #x8FEDC7) + (#x9F57 . #x8FEDC8) + (#x9F58 . #x8FEDC9) + (#x9F5A . #x8FEDCA) + (#x9F5D . #x8FEDCB) + (#x9F5E . #x8FEDCC) + (#x9F5F . #xF3F2) + (#x9F60 . #xF3F3) + (#x9F61 . #xF3F4) + (#x9F62 . #xCEF0) + (#x9F63 . #xF3F1) + (#x9F66 . #xF3F5) + (#x9F67 . #xF3F6) + (#x9F68 . #x8FEDCD) + (#x9F69 . #x8FEDCE) + (#x9F6A . #xF3F8) + (#x9F6C . #xF3F7) + (#x9F6D . #x8FEDCF) + (#x9F6E . #x8FEDD0) + (#x9F6F . #x8FEDD1) + (#x9F70 . #x8FEDD2) + (#x9F71 . #x8FEDD3) + (#x9F72 . #xF3FA) + (#x9F73 . #x8FEDD4) + (#x9F75 . #x8FEDD5) + (#x9F76 . #xF3FB) + (#x9F77 . #xF3F9) + (#x9F7A . #x8FEDD6) + (#x9F7D . #x8FEDD7) + (#x9F8D . #xCEB6) + (#x9F8F . #x8FEDD8) + (#x9F90 . #x8FEDD9) + (#x9F91 . #x8FEDDA) + (#x9F92 . #x8FEDDB) + (#x9F94 . #x8FEDDC) + (#x9F95 . #xF3FC) + (#x9F96 . #x8FEDDD) + (#x9F97 . #x8FEDDE) + (#x9F9C . #xF3FD) + (#x9F9D . #xE3D4) + (#x9F9E . #x8FEDDF) + (#x9FA0 . #xF3FE) + (#x9FA1 . #x8FEDE0) + (#x9FA2 . #x8FEDE1) + (#x9FA3 . #x8FEDE2) + (#x9FA5 . #x8FEDE3) + (#xFF01 . #xA1AA) + (#xFF03 . #xA1F4) + (#xFF04 . #xA1F0) + (#xFF05 . #xA1F3) + (#xFF06 . #xA1F5) + (#xFF08 . #xA1CA) + (#xFF09 . #xA1CB) + (#xFF0A . #xA1F6) + (#xFF0B . #xA1DC) + (#xFF0C . #xA1A4) + (#xFF0E . #xA1A5) + (#xFF0F . #xA1BF) + (#xFF10 . #xA3B0) + (#xFF11 . #xA3B1) + (#xFF12 . #xA3B2) + (#xFF13 . #xA3B3) + (#xFF14 . #xA3B4) + (#xFF15 . #xA3B5) + (#xFF16 . #xA3B6) + (#xFF17 . #xA3B7) + (#xFF18 . #xA3B8) + (#xFF19 . #xA3B9) + (#xFF1A . #xA1A7) + (#xFF1B . #xA1A8) + (#xFF1C . #xA1E3) + (#xFF1D . #xA1E1) + (#xFF1E . #xA1E4) + (#xFF1F . #xA1A9) + (#xFF20 . #xA1F7) + (#xFF21 . #xA3C1) + (#xFF22 . #xA3C2) + (#xFF23 . #xA3C3) + (#xFF24 . #xA3C4) + (#xFF25 . #xA3C5) + (#xFF26 . #xA3C6) + (#xFF27 . #xA3C7) + (#xFF28 . #xA3C8) + (#xFF29 . #xA3C9) + (#xFF2A . #xA3CA) + (#xFF2B . #xA3CB) + (#xFF2C . #xA3CC) + (#xFF2D . #xA3CD) + (#xFF2E . #xA3CE) + (#xFF2F . #xA3CF) + (#xFF30 . #xA3D0) + (#xFF31 . #xA3D1) + (#xFF32 . #xA3D2) + (#xFF33 . #xA3D3) + (#xFF34 . #xA3D4) + (#xFF35 . #xA3D5) + (#xFF36 . #xA3D6) + (#xFF37 . #xA3D7) + (#xFF38 . #xA3D8) + (#xFF39 . #xA3D9) + (#xFF3A . #xA3DA) + (#xFF3B . #xA1CE) + (#xFF3C . #xA1C0) + (#xFF3D . #xA1CF) + (#xFF3E . #xA1B0) + (#xFF3F . #xA1B2) + (#xFF40 . #xA1AE) + (#xFF41 . #xA3E1) + (#xFF42 . #xA3E2) + (#xFF43 . #xA3E3) + (#xFF44 . #xA3E4) + (#xFF45 . #xA3E5) + (#xFF46 . #xA3E6) + (#xFF47 . #xA3E7) + (#xFF48 . #xA3E8) + (#xFF49 . #xA3E9) + (#xFF4A . #xA3EA) + (#xFF4B . #xA3EB) + (#xFF4C . #xA3EC) + (#xFF4D . #xA3ED) + (#xFF4E . #xA3EE) + (#xFF4F . #xA3EF) + (#xFF50 . #xA3F0) + (#xFF51 . #xA3F1) + (#xFF52 . #xA3F2) + (#xFF53 . #xA3F3) + (#xFF54 . #xA3F4) + (#xFF55 . #xA3F5) + (#xFF56 . #xA3F6) + (#xFF57 . #xA3F7) + (#xFF58 . #xA3F8) + (#xFF59 . #xA3F9) + (#xFF5A . #xA3FA) + (#xFF5B . #xA1D0) + (#xFF5C . #xA1C3) + (#xFF5D . #xA1D1) + (#xFF5E . #x8FA2B7) + (#xFF61 . #x8EA1) + (#xFF62 . #x8EA2) + (#xFF63 . #x8EA3) + (#xFF64 . #x8EA4) + (#xFF65 . #x8EA5) + (#xFF66 . #x8EA6) + (#xFF67 . #x8EA7) + (#xFF68 . #x8EA8) + (#xFF69 . #x8EA9) + (#xFF6A . #x8EAA) + (#xFF6B . #x8EAB) + (#xFF6C . #x8EAC) + (#xFF6D . #x8EAD) + (#xFF6E . #x8EAE) + (#xFF6F . #x8EAF) + (#xFF70 . #x8EB0) + (#xFF71 . #x8EB1) + (#xFF72 . #x8EB2) + (#xFF73 . #x8EB3) + (#xFF74 . #x8EB4) + (#xFF75 . #x8EB5) + (#xFF76 . #x8EB6) + (#xFF77 . #x8EB7) + (#xFF78 . #x8EB8) + (#xFF79 . #x8EB9) + (#xFF7A . #x8EBA) + (#xFF7B . #x8EBB) + (#xFF7C . #x8EBC) + (#xFF7D . #x8EBD) + (#xFF7E . #x8EBE) + (#xFF7F . #x8EBF) + (#xFF80 . #x8EC0) + (#xFF81 . #x8EC1) + (#xFF82 . #x8EC2) + (#xFF83 . #x8EC3) + (#xFF84 . #x8EC4) + (#xFF85 . #x8EC5) + (#xFF86 . #x8EC6) + (#xFF87 . #x8EC7) + (#xFF88 . #x8EC8) + (#xFF89 . #x8EC9) + (#xFF8A . #x8ECA) + (#xFF8B . #x8ECB) + (#xFF8C . #x8ECC) + (#xFF8D . #x8ECD) + (#xFF8E . #x8ECE) + (#xFF8F . #x8ECF) + (#xFF90 . #x8ED0) + (#xFF91 . #x8ED1) + (#xFF92 . #x8ED2) + (#xFF93 . #x8ED3) + (#xFF94 . #x8ED4) + (#xFF95 . #x8ED5) + (#xFF96 . #x8ED6) + (#xFF97 . #x8ED7) + (#xFF98 . #x8ED8) + (#xFF99 . #x8ED9) + (#xFF9A . #x8EDA) + (#xFF9B . #x8EDB) + (#xFF9C . #x8EDC) + (#xFF9D . #x8EDD) + (#xFF9E . #x8EDE) + (#xFF9F . #x8EDF))) + (ucs->eucjp ; mono-directional table UCS -> EUC-JP + ;; some implementations convert EUC-JP into other UCS code point. + ;; + '((#x2015 . #xA1BD) + (#x2225 . #xA1C2) + (#xFF0D . #xA1DD) + (#xFFE0 . #xA1F1) + (#xFFE1 . #xA1F2) + (#xFFE2 . #xA2CC) + (#xFFE3 . #xA1B1) + (#xFFE4 . #x8FA2C3) + (#xFFE5 . #xA1EF)))) (dotimes (i 128) (setf (gethash i ucs-to-eucjp-table) i) (setf (gethash i eucjp-to-ucs-table) i)) (dolist (pair ucs<->eucjp) (when (gethash (car pair) ucs-to-eucjp-table) - (error "duplicated ucs: ~X" (car pair))) + (error "duplicated ucs: ~X" (car pair))) (when (gethash (cdr pair) eucjp-to-ucs-table) - (error "duplicated eucjp: ~X" (car pair))) + (error "duplicated eucjp: ~X" (car pair))) (setf (gethash (car pair) ucs-to-eucjp-table) (cdr pair)) (setf (gethash (cdr pair) eucjp-to-ucs-table) (car pair))) (dolist (pair ucs->eucjp) (when (gethash (car pair) ucs-to-eucjp-table) - (error "duplicated ucs: ~X" (car pair))) + (error "duplicated ucs: ~X" (car pair))) (setf (gethash (car pair) ucs-to-eucjp-table) (cdr pair)))) (defun ucs-to-eucjp (code) (declare (optimize speed (safety 0)) - (type fixnum code)) + (type fixnum code)) (gethash code ucs-to-eucjp-table)) (defun eucjp-to-ucs (code) (declare (optimize speed (safety 0)) - (type fixnum code)) + (type fixnum code)) (gethash code eucjp-to-ucs-table))) ;;; for fd-stream.lisp (define-external-format/variable-width (:euc-jp :eucjp :|eucJP|) t (let ((euc (ucs-to-eucjp (char-code byte)))) (if euc - (cond ((< euc #x100) 1) - ((< euc #x10000) 2) - ((< euc #x1000000) 3)) - ;; FIXME: no error handler in upstream? - 1)) + (cond ((< euc #x100) 1) + ((< euc #x10000) 2) + ((< euc #x1000000) 3)) + ;; FIXME: no error handler in upstream? + 1)) (let ((euc (ucs-to-eucjp bits))) (if (null euc) - (stream-encoding-error-and-handle stream byte) - (ecase size - (1 (setf (sap-ref-8 sap tail) euc)) - (2 (setf (sap-ref-8 sap tail) (ldb (byte 8 8) euc) - (sap-ref-8 sap (1+ tail)) (ldb (byte 8 0) euc))) - (3 (setf (sap-ref-8 sap tail) (ldb (byte 8 16) euc) - (sap-ref-8 sap (1+ tail)) (ldb (byte 8 8) euc) - (sap-ref-8 sap (+ 2 tail)) (ldb (byte 8 0) euc)))))) + (stream-encoding-error-and-handle stream byte) + (ecase size + (1 (setf (sap-ref-8 sap tail) euc)) + (2 (setf (sap-ref-8 sap tail) (ldb (byte 8 8) euc) + (sap-ref-8 sap (1+ tail)) (ldb (byte 8 0) euc))) + (3 (setf (sap-ref-8 sap tail) (ldb (byte 8 16) euc) + (sap-ref-8 sap (1+ tail)) (ldb (byte 8 8) euc) + (sap-ref-8 sap (+ 2 tail)) (ldb (byte 8 0) euc)))))) (cond ((< byte #x80) 1) - ((or (= byte #x8E) (<= #xA1 byte #xFE)) 2) - ((= byte #x8F) 3)) + ((or (= byte #x8E) (<= #xA1 byte #xFE)) 2) + ((= byte #x8F) 3)) (let* ((euc (ecase size - (1 byte) - (2 (let ((byte2 (sap-ref-8 sap (1+ head)))) - (unless (<= #xA1 byte2 #xFE) - (return-from decode-break-reason 2)) - (dpb byte (byte 8 8) byte2))) - (3 (let ((byte2 (sap-ref-8 sap (1+ head))) - (byte3 (sap-ref-8 sap (+ 2 head)))) - (unless (and (<= #xA1 byte2 #xFE) - (<= #xA1 byte2 #xFE)) - (return-from decode-break-reason 3)) - (dpb byte (byte 8 16) (dpb byte2 (byte 8 8) byte3)))))) - (ucs (eucjp-to-ucs euc))) + (1 byte) + (2 (let ((byte2 (sap-ref-8 sap (1+ head)))) + (unless (<= #xA1 byte2 #xFE) + (return-from decode-break-reason 2)) + (dpb byte (byte 8 8) byte2))) + (3 (let ((byte2 (sap-ref-8 sap (1+ head))) + (byte3 (sap-ref-8 sap (+ 2 head)))) + (unless (and (<= #xA1 byte2 #xFE) + (<= #xA1 byte2 #xFE)) + (return-from decode-break-reason 3)) + (dpb byte (byte 8 16) (dpb byte2 (byte 8 8) byte3)))))) + (ucs (eucjp-to-ucs euc))) (if (null ucs) - (return-from decode-break-reason 3) - (code-char ucs)))) + (return-from decode-break-reason 3) + (code-char ucs)))) ;;; for octets.lisp (define-condition malformed-eucjp (octet-decoding-error) ()) @@ -13096,46 +13096,46 @@ (declaim (inline char-len-as-eucjp)) (defun char-len-as-eucjp (code) (declare (optimize speed (safety 0)) - (type fixnum code)) + (type fixnum code)) (cond ((< code 0) (bug "can't happen")) - ((< code #x100) 1) - ((< code #x10000) 2) - ((< code #x1000000) 3) - (t (bug "can't happen")))) + ((< code #x100) 1) + ((< code #x10000) 2) + ((< code #x1000000) 3) + (t (bug "can't happen")))) (declaim (inline char->eucjp)) (defun char->eucjp (char dest string pos) (declare (optimize speed (safety 0)) - (type (array (unsigned-byte 8) (*)) dest)) + (type (array (unsigned-byte 8) (*)) dest)) (let ((code (ucs-to-eucjp (char-code char)))) (if code - (flet ((add-byte (b) - (declare (type (unsigned-byte 8) b)) - (vector-push-extend b dest))) - (declare (inline add-byte)) - (setf code (the fixnum code)) - (ecase (char-len-as-eucjp code) - (1 - (add-byte code)) - (2 - (add-byte (ldb (byte 8 8) code)) - (add-byte (ldb (byte 8 0) code))) - (3 - (add-byte (ldb (byte 8 16) code)) - (add-byte (ldb (byte 8 8) code)) - (add-byte (ldb (byte 8 0) code))))) - (encoding-error :euc-jp string pos)))) + (flet ((add-byte (b) + (declare (type (unsigned-byte 8) b)) + (vector-push-extend b dest))) + (declare (inline add-byte)) + (setf code (the fixnum code)) + (ecase (char-len-as-eucjp code) + (1 + (add-byte code)) + (2 + (add-byte (ldb (byte 8 8) code)) + (add-byte (ldb (byte 8 0) code))) + (3 + (add-byte (ldb (byte 8 16) code)) + (add-byte (ldb (byte 8 8) code)) + (add-byte (ldb (byte 8 0) code))))) + (encoding-error :euc-jp string pos)))) (defun string->eucjp (string sstart send additional-space) (declare (optimize speed (safety 0)) - (type simple-string string) - (type array-range sstart send additional-space)) + (type simple-string string) + (type array-range sstart send additional-space)) (let ((array (make-array (+ additional-space (- send sstart)) - :element-type '(unsigned-byte 8) - :adjustable t - :fill-pointer 0))) + :element-type '(unsigned-byte 8) + :adjustable t + :fill-pointer 0))) (loop for i from sstart below send - do (char->eucjp (char string i) array string i)) + do (char->eucjp (char string i) array string i)) (dotimes (i additional-space) (vector-push-extend 0 array)) (coerce array '(simple-array (unsigned-byte 8) (*))))) @@ -13145,72 +13145,72 @@ `(progn ;;(declaim (inline ,name)) (defun ,name (array pos end) - (declare (optimize speed (safety 0)) - (type ,type array) - (type array-range pos end)) - ;; returns the number of bytes consumed and nil if it's a - ;; valid character or the number of bytes consumed and a - ;; replacement string if it's not. - (let ((initial-byte (,accessor array pos)) - (reject-reason nil) - (reject-position pos) - (remaining-bytes (- end pos))) - (declare (type array-range reject-position remaining-bytes)) - (labels ((valid-eucjp-starter-byte-p (b) - (declare (type (unsigned-byte 8) b)) - (let ((ok (cond ((< b #x80) 1) - ((or (= b #x8E) (<= #xA1 b #xFE)) 2) - ((= b #x8F) 3)))) - (unless ok - (setf reject-reason 'invalid-eucjp-starter-byte)) - ok)) - (enough-bytes-left-p (x) - (let ((ok (> end (+ pos (1- x))))) - (unless ok - (setf reject-reason 'end-of-input-in-character)) - ok)) - (valid-secondary-p (x) - (let* ((idx (the array-range (+ pos x))) - (b (,accessor array idx)) - (ok (<= #xA1 b #xFE))) - (unless ok - (setf reject-reason 'invalid-eucjp-continuation-byte) - (setf reject-position idx)) - ok)) - (preliminary-ok-for-length (maybe-len len) - (and (eql maybe-len len) - ;; Has to be done in this order so that - ;; certain broken sequences (e.g., the - ;; two-byte sequence `"initial (length 3)" - ;; "non-continuation"' -- `#xef #x32') - ;; signal only part of that sequence as - ;; erronous. - (loop for i from 1 below (min len remaining-bytes) - always (valid-secondary-p i)) - (enough-bytes-left-p len)))) - (declare (inline valid-eucjp-starter-byte-p - enough-bytes-left-p - valid-secondary-p - preliminary-ok-for-length)) - (let ((maybe-len (valid-eucjp-starter-byte-p initial-byte))) - (cond ((eql maybe-len 1) - (values 1 nil)) - ((preliminary-ok-for-length maybe-len 2) - (values 2 nil)) - ((preliminary-ok-for-length maybe-len 3) - (values 3 nil)) - (t - (let* ((bad-end (ecase reject-reason - (invalid-eucjp-starter-byte - (1+ pos)) - (end-of-input-in-character - end) - (invalid-eucjp-continuation-byte - reject-position))) - (bad-len (- bad-end pos))) - (declare (type array-range bad-end bad-len)) - (let ((replacement (decoding-error array pos bad-end :euc-jp reject-reason reject-position))) - (values bad-len replacement)))))))))))) + (declare (optimize speed (safety 0)) + (type ,type array) + (type array-range pos end)) + ;; returns the number of bytes consumed and nil if it's a + ;; valid character or the number of bytes consumed and a + ;; replacement string if it's not. + (let ((initial-byte (,accessor array pos)) + (reject-reason nil) + (reject-position pos) + (remaining-bytes (- end pos))) + (declare (type array-range reject-position remaining-bytes)) + (labels ((valid-eucjp-starter-byte-p (b) + (declare (type (unsigned-byte 8) b)) + (let ((ok (cond ((< b #x80) 1) + ((or (= b #x8E) (<= #xA1 b #xFE)) 2) + ((= b #x8F) 3)))) + (unless ok + (setf reject-reason 'invalid-eucjp-starter-byte)) + ok)) + (enough-bytes-left-p (x) + (let ((ok (> end (+ pos (1- x))))) + (unless ok + (setf reject-reason 'end-of-input-in-character)) + ok)) + (valid-secondary-p (x) + (let* ((idx (the array-range (+ pos x))) + (b (,accessor array idx)) + (ok (<= #xA1 b #xFE))) + (unless ok + (setf reject-reason 'invalid-eucjp-continuation-byte) + (setf reject-position idx)) + ok)) + (preliminary-ok-for-length (maybe-len len) + (and (eql maybe-len len) + ;; Has to be done in this order so that + ;; certain broken sequences (e.g., the + ;; two-byte sequence `"initial (length 3)" + ;; "non-continuation"' -- `#xef #x32') + ;; signal only part of that sequence as + ;; erronous. + (loop for i from 1 below (min len remaining-bytes) + always (valid-secondary-p i)) + (enough-bytes-left-p len)))) + (declare (inline valid-eucjp-starter-byte-p + enough-bytes-left-p + valid-secondary-p + preliminary-ok-for-length)) + (let ((maybe-len (valid-eucjp-starter-byte-p initial-byte))) + (cond ((eql maybe-len 1) + (values 1 nil)) + ((preliminary-ok-for-length maybe-len 2) + (values 2 nil)) + ((preliminary-ok-for-length maybe-len 3) + (values 3 nil)) + (t + (let* ((bad-end (ecase reject-reason + (invalid-eucjp-starter-byte + (1+ pos)) + (end-of-input-in-character + end) + (invalid-eucjp-continuation-byte + reject-position))) + (bad-len (- bad-end pos))) + (declare (type array-range bad-end bad-len)) + (let ((replacement (decoding-error array pos bad-end :euc-jp reject-reason reject-position))) + (values bad-len replacement)))))))))))) (instantiate-octets-definition define-bytes-per-eucjp-character) (defmacro define-simple-get-eucjp-char (accessor type) @@ -13218,48 +13218,48 @@ `(progn (declaim (inline ,name)) (defun ,name (array pos bytes) - (declare (optimize speed (safety 0)) - (type ,type array) - (type array-range pos) - (type (integer 1 3) bytes)) - (flet ((cref (x) - (,accessor array (the array-range (+ pos x))))) - (declare (inline cref)) - (let ((code (eucjp-to-ucs (ecase bytes - (1 (cref 0)) - (2 (logior (ash (cref 0) 8) (cref 1))) - (3 (logior (ash (cref 0) 16) - (ash (cref 1) 8) - (cref 2))))))) - (if code - (code-char code) - (decoding-error array pos (+ pos bytes) :euc-jp - 'malformed-eucjp pos)))))))) + (declare (optimize speed (safety 0)) + (type ,type array) + (type array-range pos) + (type (integer 1 3) bytes)) + (flet ((cref (x) + (,accessor array (the array-range (+ pos x))))) + (declare (inline cref)) + (let ((code (eucjp-to-ucs (ecase bytes + (1 (cref 0)) + (2 (logior (ash (cref 0) 8) (cref 1))) + (3 (logior (ash (cref 0) 16) + (ash (cref 1) 8) + (cref 2))))))) + (if code + (code-char code) + (decoding-error array pos (+ pos bytes) :euc-jp + 'malformed-eucjp pos)))))))) (instantiate-octets-definition define-simple-get-eucjp-char) (defmacro define-eucjp->string (accessor type) (let ((name (make-od-name 'eucjp->string accessor))) `(progn (defun ,name (array astart aend) - (declare (optimize speed (safety 0)) - (type ,type array) - (type array-range astart aend)) - (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) - (loop with pos = astart - while (< pos aend) - do (multiple-value-bind (bytes invalid) - (,(make-od-name 'bytes-per-eucjp-character accessor) array pos aend) - (declare (type (or null string) invalid)) - (cond - ((null invalid) - (vector-push-extend (,(make-od-name 'simple-get-eucjp-char accessor) array pos bytes) string)) - (t - (dotimes (i (length invalid)) - (vector-push-extend (char invalid i) string)))) - (incf pos bytes))) - (coerce string 'simple-string)))))) + (declare (optimize speed (safety 0)) + (type ,type array) + (type array-range astart aend)) + (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) + (loop with pos = astart + while (< pos aend) + do (multiple-value-bind (bytes invalid) + (,(make-od-name 'bytes-per-eucjp-character accessor) array pos aend) + (declare (type (or null string) invalid)) + (cond + ((null invalid) + (vector-push-extend (,(make-od-name 'simple-get-eucjp-char accessor) array pos bytes) string)) + (t + (dotimes (i (length invalid)) + (vector-push-extend (char invalid i) string)))) + (incf pos bytes))) + (coerce string 'simple-string)))))) (instantiate-octets-definition define-eucjp->string) (push '((:euc-jp :eucjp :|eucJP|) - eucjp->string-aref string->eucjp) + eucjp->string-aref string->eucjp) *external-format-functions*) diff --git a/src/code/eval.lisp b/src/code/eval.lisp index b33ca52..3e4c729 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -21,8 +21,8 @@ ;; evaluations/compilations, though [e.g. the ignored variable in ;; (DEFUN FOO (X) 1)]. -- CSR, 2003-05-13 (let ((fun (sb!c:compile-in-lexenv nil - `(lambda () ,expr) - lexenv))) + `(lambda () ,expr) + lexenv))) (funcall fun))) ;;; Handle PROGN and implicit PROGN. @@ -30,9 +30,9 @@ (unless (list-with-length-p progn-body) (let ((*print-circle* t)) (error 'simple-program-error - :format-control - "~@" - :format-arguments (list progn-body)))) + :format-control + "~@" + :format-arguments (list progn-body)))) ;; Note: ;; * We can't just use (MAP NIL #'EVAL PROGN-BODY) here, because we ;; need to take care to return all the values of the final EVAL. @@ -40,11 +40,11 @@ ;; gives the right result when PROGN-BODY is NIL, because ;; (FIRST NIL) = (REST NIL) = NIL. (do* ((i progn-body rest-i) - (rest-i (rest i) (rest i))) + (rest-i (rest i) (rest i))) (nil) (if rest-i ; if not last element of list - (eval-in-lexenv (first i) lexenv) - (return (eval-in-lexenv (first i) lexenv))))) + (eval-in-lexenv (first i) lexenv) + (return (eval-in-lexenv (first i) lexenv))))) (defun eval-locally (exp lexenv &key vars) (multiple-value-bind (body decls) @@ -63,9 +63,9 @@ ;; then thrown away, as it happens]). -- CSR, ;; 2002-10-24 (let* ((sb!c:*lexenv* lexenv) - (sb!c::*free-funs* (make-hash-table :test 'equal)) - (sb!c::*free-vars* (make-hash-table :test 'eq)) - (sb!c::*undefined-warnings* nil)) + (sb!c::*free-funs* (make-hash-table :test 'equal)) + (sb!c::*free-vars* (make-hash-table :test 'eq)) + (sb!c::*undefined-warnings* nil)) ;; FIXME: VALUES declaration (sb!c::process-decls decls vars @@ -86,108 +86,108 @@ ;; (aver (lexenv-simple-p lexenv)) (handler-bind ((sb!c:compiler-error - (lambda (c) - (if (boundp 'sb!c::*compiler-error-bailout*) - ;; if we're in the compiler, delegate either to a higher - ;; authority or, if that's us, back down to the - ;; outermost compiler handler... - (progn - (signal c) - nil) - ;; ... if we're not in the compiler, better signal the - ;; error straight away. - (invoke-restart 'sb!c::signal-error))))) + (lambda (c) + (if (boundp 'sb!c::*compiler-error-bailout*) + ;; if we're in the compiler, delegate either to a higher + ;; authority or, if that's us, back down to the + ;; outermost compiler handler... + (progn + (signal c) + nil) + ;; ... if we're not in the compiler, better signal the + ;; error straight away. + (invoke-restart 'sb!c::signal-error))))) (let ((exp (macroexpand original-exp lexenv))) (typecase exp - (symbol - (ecase (info :variable :kind exp) - (:constant - (values (info :variable :constant-value exp))) - ((:special :global) - (symbol-value exp)) - ;; FIXME: This special case here is a symptom of non-ANSI - ;; weirdness in SBCL's ALIEN implementation, which could - ;; cause problems for e.g. code walkers. It'd probably be - ;; good to ANSIfy it by making alien variable accessors - ;; into ordinary forms, e.g. (SB-UNIX:ENV) and (SETF - ;; SB-UNIX:ENV), instead of magical symbols, e.g. plain - ;; SB-UNIX:ENV. Then if the old magical-symbol syntax is to - ;; be retained for compatibility, it can be implemented - ;; with DEFINE-SYMBOL-MACRO, keeping the code walkers - ;; happy. - (:alien - (%eval original-exp lexenv)))) - (list - (let ((name (first exp)) - (n-args (1- (length exp)))) - (case name - ((function) - (unless (= n-args 1) - (error "wrong number of args to FUNCTION:~% ~S" exp)) - (let ((name (second exp))) - (if (and (legal-fun-name-p name) - (not (consp (let ((sb!c:*lexenv* lexenv)) - (sb!c:lexenv-find name funs))))) - (%coerce-name-to-fun name) - (%eval original-exp lexenv)))) - ((quote) - (unless (= n-args 1) - (error "wrong number of args to QUOTE:~% ~S" exp)) - (second exp)) - (setq - (unless (evenp n-args) - (error "odd number of args to SETQ:~% ~S" exp)) - (unless (zerop n-args) - (do ((name (cdr exp) (cddr name))) - ((null name) - (do ((args (cdr exp) (cddr args))) - ((null (cddr args)) - ;; We duplicate the call to SET so that the - ;; correct value gets returned. - (set (first args) (eval-in-lexenv (second args) lexenv))) - (set (first args) (eval-in-lexenv (second args) lexenv)))) - (let ((symbol (first name))) - (case (info :variable :kind symbol) - (:special) - (t (return (%eval original-exp lexenv)))) - (unless (type= (info :variable :type symbol) - *universal-type*) - ;; let the compiler deal with type checking - (return (%eval original-exp lexenv))))))) - ((progn) - (eval-progn-body (rest exp) lexenv)) - ((eval-when) - ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR - ;; instead of PROGRAM-ERROR when there's something wrong - ;; with the syntax here (e.g. missing SITUATIONS). This - ;; could be fixed by hand-crafting clauses to catch and - ;; report each possibility, but it would probably be - ;; cleaner to write a new macro - ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does - ;; DESTRUCTURING-BIND and promotes any mismatch to - ;; PROGRAM-ERROR, then to use it here and in (probably - ;; dozens of) other places where the same problem - ;; arises. - (destructuring-bind (eval-when situations &rest body) exp - (declare (ignore eval-when)) - (multiple-value-bind (ct lt e) - (sb!c:parse-eval-when-situations situations) - ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of - ;; the situation :EXECUTE (or EVAL) controls whether - ;; evaluation occurs for other EVAL-WHEN forms; that - ;; is, those that are not top level forms, or those - ;; in code processed by EVAL or COMPILE. If the - ;; :EXECUTE situation is specified in such a form, - ;; then the body forms are processed as an implicit - ;; PROGN; otherwise, the EVAL-WHEN form returns NIL. - (declare (ignore ct lt)) - (when e - (eval-progn-body body lexenv))))) - ((locally) - (eval-locally exp lexenv)) - ((macrolet) - (destructuring-bind (definitions &rest body) - (rest exp) + (symbol + (ecase (info :variable :kind exp) + (:constant + (values (info :variable :constant-value exp))) + ((:special :global) + (symbol-value exp)) + ;; FIXME: This special case here is a symptom of non-ANSI + ;; weirdness in SBCL's ALIEN implementation, which could + ;; cause problems for e.g. code walkers. It'd probably be + ;; good to ANSIfy it by making alien variable accessors + ;; into ordinary forms, e.g. (SB-UNIX:ENV) and (SETF + ;; SB-UNIX:ENV), instead of magical symbols, e.g. plain + ;; SB-UNIX:ENV. Then if the old magical-symbol syntax is to + ;; be retained for compatibility, it can be implemented + ;; with DEFINE-SYMBOL-MACRO, keeping the code walkers + ;; happy. + (:alien + (%eval original-exp lexenv)))) + (list + (let ((name (first exp)) + (n-args (1- (length exp)))) + (case name + ((function) + (unless (= n-args 1) + (error "wrong number of args to FUNCTION:~% ~S" exp)) + (let ((name (second exp))) + (if (and (legal-fun-name-p name) + (not (consp (let ((sb!c:*lexenv* lexenv)) + (sb!c:lexenv-find name funs))))) + (%coerce-name-to-fun name) + (%eval original-exp lexenv)))) + ((quote) + (unless (= n-args 1) + (error "wrong number of args to QUOTE:~% ~S" exp)) + (second exp)) + (setq + (unless (evenp n-args) + (error "odd number of args to SETQ:~% ~S" exp)) + (unless (zerop n-args) + (do ((name (cdr exp) (cddr name))) + ((null name) + (do ((args (cdr exp) (cddr args))) + ((null (cddr args)) + ;; We duplicate the call to SET so that the + ;; correct value gets returned. + (set (first args) (eval-in-lexenv (second args) lexenv))) + (set (first args) (eval-in-lexenv (second args) lexenv)))) + (let ((symbol (first name))) + (case (info :variable :kind symbol) + (:special) + (t (return (%eval original-exp lexenv)))) + (unless (type= (info :variable :type symbol) + *universal-type*) + ;; let the compiler deal with type checking + (return (%eval original-exp lexenv))))))) + ((progn) + (eval-progn-body (rest exp) lexenv)) + ((eval-when) + ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR + ;; instead of PROGRAM-ERROR when there's something wrong + ;; with the syntax here (e.g. missing SITUATIONS). This + ;; could be fixed by hand-crafting clauses to catch and + ;; report each possibility, but it would probably be + ;; cleaner to write a new macro + ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does + ;; DESTRUCTURING-BIND and promotes any mismatch to + ;; PROGRAM-ERROR, then to use it here and in (probably + ;; dozens of) other places where the same problem + ;; arises. + (destructuring-bind (eval-when situations &rest body) exp + (declare (ignore eval-when)) + (multiple-value-bind (ct lt e) + (sb!c:parse-eval-when-situations situations) + ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of + ;; the situation :EXECUTE (or EVAL) controls whether + ;; evaluation occurs for other EVAL-WHEN forms; that + ;; is, those that are not top level forms, or those + ;; in code processed by EVAL or COMPILE. If the + ;; :EXECUTE situation is specified in such a form, + ;; then the body forms are processed as an implicit + ;; PROGN; otherwise, the EVAL-WHEN form returns NIL. + (declare (ignore ct lt)) + (when e + (eval-progn-body body lexenv))))) + ((locally) + (eval-locally exp lexenv)) + ((macrolet) + (destructuring-bind (definitions &rest body) + (rest exp) (let ((lexenv (let ((sb!c:*lexenv* lexenv)) (sb!c::funcall-in-macrolet-lexenv @@ -197,8 +197,8 @@ sb!c:*lexenv*) :eval)))) (eval-locally `(locally ,@body) lexenv)))) - ((symbol-macrolet) - (destructuring-bind (definitions &rest body) (rest exp) + ((symbol-macrolet) + (destructuring-bind (definitions &rest body) (rest exp) (multiple-value-bind (lexenv vars) (let ((sb!c:*lexenv* lexenv)) (sb!c::funcall-in-symbol-macrolet-lexenv @@ -207,16 +207,16 @@ (values sb!c:*lexenv* vars)) :eval)) (eval-locally `(locally ,@body) lexenv :vars vars)))) - (t - (if (and (symbolp name) - (eq (info :function :kind name) :function)) - (collect ((args)) + (t + (if (and (symbolp name) + (eq (info :function :kind name) :function)) + (collect ((args)) (dolist (arg (rest exp)) (args (eval-in-lexenv arg lexenv))) (apply (symbol-function name) (args))) - (%eval exp lexenv)))))) - (t - exp))))) + (%eval exp lexenv)))))) + (t + exp))))) ;;; miscellaneous full function definitions of things which are ;;; ordinarily handled magically by the compiler @@ -228,14 +228,14 @@ last argument, appended to the value of the last argument, which must be a list." (cond ((atom arguments) - (apply function arg)) - ((atom (cdr arguments)) - (apply function (cons arg (car arguments)))) - (t (do* ((a1 arguments a2) - (a2 (cdr arguments) (cdr a2))) - ((atom (cdr a2)) - (rplacd a1 (car a2)) - (apply function (cons arg arguments))))))) + (apply function arg)) + ((atom (cdr arguments)) + (apply function (cons arg (car arguments)))) + (t (do* ((a1 arguments a2) + (a2 (cdr arguments) (cdr a2))) + ((atom (cdr a2)) + (rplacd a1 (car a2)) + (apply function (cons arg arguments))))))) (defun funcall (function &rest arguments) #!+sb-doc diff --git a/src/code/exhaust.lisp b/src/code/exhaust.lisp index 7c6ec72..b1cf791 100644 --- a/src/code/exhaust.lisp +++ b/src/code/exhaust.lisp @@ -12,10 +12,10 @@ (in-package "SB!KERNEL") (define-alien-routine ("protect_control_stack_guard_page" - %protect-control-stack-guard-page) + %protect-control-stack-guard-page) sb!alien:void (thread-sap system-area-pointer) (protect-p sb!alien:int)) (defun protect-control-stack-guard-page (n) - (%protect-control-stack-guard-page + (%protect-control-stack-guard-page (sb!thread::thread-%sap sb!thread:*current-thread*) (if n 1 0))) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 69660e8..1c96917 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -34,12 +34,12 @@ ;;;; the FD-STREAM structure (defstruct (fd-stream - (:constructor %make-fd-stream) - (:conc-name fd-stream-) - (:predicate fd-stream-p) - (:include ansi-stream - (misc #'fd-stream-misc-routine)) - (:copier nil)) + (:constructor %make-fd-stream) + (:conc-name fd-stream-) + (:predicate fd-stream-p) + (:include ansi-stream + (misc #'fd-stream-misc-routine)) + (:copier nil)) ;; the name of this stream (name nil) @@ -48,13 +48,13 @@ ;; the backup file namestring for the old file, for :IF-EXISTS ;; :RENAME or :RENAME-AND-DELETE. (original nil :type (or simple-string null)) - (delete-original nil) ; for :if-exists :rename-and-delete + (delete-original nil) ; for :if-exists :rename-and-delete ;;; the number of bytes per element (element-size 1 :type index) ;; the type of element being transfered - (element-type 'base-char) + (element-type 'base-char) ;; the Unix file descriptor - (fd -1 :type fixnum) + (fd -1 :type fixnum) ;; controls when the output buffer is flushed (buffering :full :type (member :full :line :none)) ;; controls whether the input buffer must be cleared before output @@ -104,25 +104,25 @@ ;;; common idioms for reporting low-level stream and file problems (defun simple-stream-perror (note-format stream errno) (error 'simple-stream-error - :stream stream - :format-control "~@<~?: ~2I~_~A~:>" - :format-arguments (list note-format (list stream) (strerror errno)))) + :stream stream + :format-control "~@<~?: ~2I~_~A~:>" + :format-arguments (list note-format (list stream) (strerror errno)))) (defun simple-file-perror (note-format pathname errno) (error 'simple-file-error - :pathname pathname - :format-control "~@<~?: ~2I~_~A~:>" - :format-arguments - (list note-format (list pathname) (strerror errno)))) + :pathname pathname + :format-control "~@<~?: ~2I~_~A~:>" + :format-arguments + (list note-format (list pathname) (strerror errno)))) (defun stream-decoding-error (stream octets) (error 'stream-decoding-error - :stream stream + :stream stream ;; FIXME: dunno how to get at OCTETS currently, or even if ;; that's the right thing to report. :octets octets)) (defun stream-encoding-error (stream code) (error 'stream-encoding-error - :stream stream + :stream stream :code code)) ;;; Returning true goes into end of file handling, false will enter another @@ -130,20 +130,20 @@ (defun stream-decoding-error-and-handle (stream octet-count) (restart-case (stream-decoding-error stream - (let ((sap (fd-stream-ibuf-sap stream)) - (head (fd-stream-ibuf-head stream))) - (loop for i from 0 below octet-count - collect (sap-ref-8 sap (+ head i))))) + (let ((sap (fd-stream-ibuf-sap stream)) + (head (fd-stream-ibuf-head stream))) + (loop for i from 0 below octet-count + collect (sap-ref-8 sap (+ head i))))) (attempt-resync () :report (lambda (stream) - (format stream - "~@")) (fd-stream-resync stream) nil) (force-end-of-file () :report (lambda (stream) - (format stream "~@")) + (format stream "~@")) t))) (defun stream-encoding-error-and-handle (stream code) @@ -151,7 +151,7 @@ (stream-encoding-error stream code) (output-nothing () :report (lambda (stream) - (format stream "~@")) + (format stream "~@")) (throw 'output-nothing nil)))) ;;; This is called by the server when we can write to the given file @@ -160,29 +160,29 @@ ;;; is wrong. (defun frob-output-later (stream) (let* ((stuff (pop (fd-stream-output-later stream))) - (base (car stuff)) - (start (cadr stuff)) - (end (caddr stuff)) - (reuse-sap (cadddr stuff)) - (length (- end start))) + (base (car stuff)) + (start (cadr stuff)) + (end (caddr stuff)) + (reuse-sap (cadddr stuff)) + (length (- end start))) (declare (type index start end length)) (multiple-value-bind (count errno) - (sb!unix:unix-write (fd-stream-fd stream) - base - start - length) + (sb!unix:unix-write (fd-stream-fd stream) + base + start + length) (cond ((not count) - (if (= errno sb!unix:ewouldblock) - (error "Write would have blocked, but SERVER told us to go.") - (simple-stream-perror "couldn't write to ~S" stream errno))) - ((eql count length) ; Hot damn, it worked. - (when reuse-sap - (push base *available-buffers*))) - ((not (null count)) ; sorta worked.. - (push (list base - (the index (+ start count)) - end) - (fd-stream-output-later stream)))))) + (if (= errno sb!unix:ewouldblock) + (error "Write would have blocked, but SERVER told us to go.") + (simple-stream-perror "couldn't write to ~S" stream errno))) + ((eql count length) ; Hot damn, it worked. + (when reuse-sap + (push base *available-buffers*))) + ((not (null count)) ; sorta worked.. + (push (list base + (the index (+ start count)) + end) + (fd-stream-output-later stream)))))) (unless (fd-stream-output-later stream) (sb!sys:remove-fd-handler (fd-stream-handler stream)) (setf (fd-stream-handler stream) nil))) @@ -190,17 +190,17 @@ ;;; Arange to output the string when we can write on the file descriptor. (defun output-later (stream base start end reuse-sap) (cond ((null (fd-stream-output-later stream)) - (setf (fd-stream-output-later stream) - (list (list base start end reuse-sap))) - (setf (fd-stream-handler stream) - (sb!sys:add-fd-handler (fd-stream-fd stream) - :output - (lambda (fd) - (declare (ignore fd)) - (frob-output-later stream))))) - (t - (nconc (fd-stream-output-later stream) - (list (list base start end reuse-sap))))) + (setf (fd-stream-output-later stream) + (list (list base start end reuse-sap))) + (setf (fd-stream-handler stream) + (sb!sys:add-fd-handler (fd-stream-fd stream) + :output + (lambda (fd) + (declare (ignore fd)) + (frob-output-later stream))))) + (t + (nconc (fd-stream-output-later stream) + (list (list base start end reuse-sap))))) (when reuse-sap (let ((new-buffer (next-available-buffer))) (setf (fd-stream-obuf-sap stream) new-buffer) @@ -211,25 +211,25 @@ ;;; this would block, queue it. (defun frob-output (stream base start end reuse-sap) (declare (type fd-stream stream) - (type (or system-area-pointer (simple-array * (*))) base) - (type index start end)) + (type (or system-area-pointer (simple-array * (*))) base) + (type index start end)) (if (not (null (fd-stream-output-later stream))) ; something buffered. (progn - (output-later stream base start end reuse-sap) - ;; ### check to see whether any of this noise can be output - ) + (output-later stream base start end reuse-sap) + ;; ### check to see whether any of this noise can be output + ) (let ((length (- end start))) - (multiple-value-bind (count errno) - (sb!unix:unix-write (fd-stream-fd stream) base start length) - (cond ((not count) - (if (= errno sb!unix:ewouldblock) - (output-later stream base start end reuse-sap) - (simple-stream-perror "couldn't write to ~S" - stream - errno))) - ((not (eql count length)) - (output-later stream base (the index (+ start count)) - end reuse-sap))))))) + (multiple-value-bind (count errno) + (sb!unix:unix-write (fd-stream-fd stream) base start length) + (cond ((not count) + (if (= errno sb!unix:ewouldblock) + (output-later stream base start end reuse-sap) + (simple-stream-perror "couldn't write to ~S" + stream + errno))) + ((not (eql count length)) + (output-later stream base (the index (+ start count)) + end reuse-sap))))))) ;;; Flush any data in the output buffer. (defun flush-output-buffer (stream) @@ -239,63 +239,63 @@ (setf (fd-stream-obuf-tail stream) 0)))) (defmacro output-wrapper/variable-width ((stream size buffering restart) - &body body) + &body body) (let ((stream-var (gensym))) `(let ((,stream-var ,stream) - (size ,size)) + (size ,size)) ,(unless (eq (car buffering) :none) - `(when (< (fd-stream-obuf-length ,stream-var) - (+ (fd-stream-obuf-tail ,stream-var) - size)) + `(when (< (fd-stream-obuf-length ,stream-var) + (+ (fd-stream-obuf-tail ,stream-var) + size)) (flush-output-buffer ,stream-var))) ,(unless (eq (car buffering) :none) - `(when (and (not (fd-stream-dual-channel-p ,stream-var)) - (> (fd-stream-ibuf-tail ,stream-var) - (fd-stream-ibuf-head ,stream-var))) + `(when (and (not (fd-stream-dual-channel-p ,stream-var)) + (> (fd-stream-ibuf-tail ,stream-var) + (fd-stream-ibuf-head ,stream-var))) (file-position ,stream-var (file-position ,stream-var)))) ,(if restart `(catch 'output-nothing - ,@body - (incf (fd-stream-obuf-tail ,stream-var) size)) + ,@body + (incf (fd-stream-obuf-tail ,stream-var) size)) `(progn ,@body (incf (fd-stream-obuf-tail ,stream-var) size))) ,(ecase (car buffering) - (:none - `(flush-output-buffer ,stream-var)) - (:line - `(when (eq (char-code byte) (char-code #\Newline)) - (flush-output-buffer ,stream-var))) - (:full)) + (:none + `(flush-output-buffer ,stream-var)) + (:line + `(when (eq (char-code byte) (char-code #\Newline)) + (flush-output-buffer ,stream-var))) + (:full)) (values)))) (defmacro output-wrapper ((stream size buffering restart) &body body) (let ((stream-var (gensym))) `(let ((,stream-var ,stream)) ,(unless (eq (car buffering) :none) - `(when (< (fd-stream-obuf-length ,stream-var) - (+ (fd-stream-obuf-tail ,stream-var) - ,size)) + `(when (< (fd-stream-obuf-length ,stream-var) + (+ (fd-stream-obuf-tail ,stream-var) + ,size)) (flush-output-buffer ,stream-var))) ,(unless (eq (car buffering) :none) - `(when (and (not (fd-stream-dual-channel-p ,stream-var)) - (> (fd-stream-ibuf-tail ,stream-var) - (fd-stream-ibuf-head ,stream-var))) + `(when (and (not (fd-stream-dual-channel-p ,stream-var)) + (> (fd-stream-ibuf-tail ,stream-var) + (fd-stream-ibuf-head ,stream-var))) (file-position ,stream-var (file-position ,stream-var)))) ,(if restart - `(catch 'output-nothing - ,@body - (incf (fd-stream-obuf-tail ,stream-var) ,size)) + `(catch 'output-nothing + ,@body + (incf (fd-stream-obuf-tail ,stream-var) ,size)) `(progn ,@body (incf (fd-stream-obuf-tail ,stream-var) ,size))) ,(ecase (car buffering) - (:none - `(flush-output-buffer ,stream-var)) - (:line - `(when (eq (char-code byte) (char-code #\Newline)) - (flush-output-buffer ,stream-var))) - (:full)) + (:none + `(flush-output-buffer ,stream-var)) + (:line + `(when (eq (char-code byte) (char-code #\Newline)) + (flush-output-buffer ,stream-var))) + (:full)) (values)))) (defmacro def-output-routines/variable-width @@ -303,25 +303,25 @@ &body body) (declare (optimize (speed 1))) (cons 'progn - (mapcar - (lambda (buffering) - (let ((function - (intern (format nil name-fmt (string (car buffering)))))) - `(progn - (defun ,function (stream byte) - (output-wrapper/variable-width (stream ,size ,buffering ,restart) - ,@body)) - (setf *output-routines* - (nconc *output-routines* - ',(mapcar - (lambda (type) - (list type - (car buffering) - function - 1 - external-format)) - (cdr buffering))))))) - bufferings))) + (mapcar + (lambda (buffering) + (let ((function + (intern (format nil name-fmt (string (car buffering)))))) + `(progn + (defun ,function (stream byte) + (output-wrapper/variable-width (stream ,size ,buffering ,restart) + ,@body)) + (setf *output-routines* + (nconc *output-routines* + ',(mapcar + (lambda (type) + (list type + (car buffering) + function + 1 + external-format)) + (cdr buffering))))))) + bufferings))) ;;; Define output routines that output numbers SIZE bytes long for the ;;; given bufferings. Use BODY to do the actual output. @@ -329,89 +329,89 @@ &body body) (declare (optimize (speed 1))) (cons 'progn - (mapcar - (lambda (buffering) - (let ((function - (intern (format nil name-fmt (string (car buffering)))))) - `(progn - (defun ,function (stream byte) - (output-wrapper (stream ,size ,buffering ,restart) - ,@body)) - (setf *output-routines* - (nconc *output-routines* - ',(mapcar - (lambda (type) - (list type - (car buffering) - function - size - nil)) - (cdr buffering))))))) - bufferings))) + (mapcar + (lambda (buffering) + (let ((function + (intern (format nil name-fmt (string (car buffering)))))) + `(progn + (defun ,function (stream byte) + (output-wrapper (stream ,size ,buffering ,restart) + ,@body)) + (setf *output-routines* + (nconc *output-routines* + ',(mapcar + (lambda (type) + (list type + (car buffering) + function + size + nil)) + (cdr buffering))))))) + bufferings))) ;;; FIXME: is this used anywhere any more? (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED" - 1 + 1 t - (:none character) - (:line character) - (:full character)) + (:none character) + (:line character) + (:full character)) (if (char= byte #\Newline) (setf (fd-stream-char-pos stream) 0) (incf (fd-stream-char-pos stream))) (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) - (char-code byte))) + (char-code byte))) (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED" - 1 + 1 nil - (:none (unsigned-byte 8)) - (:full (unsigned-byte 8))) + (:none (unsigned-byte 8)) + (:full (unsigned-byte 8))) (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) - byte)) + byte)) (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED" - 1 + 1 nil - (:none (signed-byte 8)) - (:full (signed-byte 8))) + (:none (signed-byte 8)) + (:full (signed-byte 8))) (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream) - (fd-stream-obuf-tail stream)) - byte)) + (fd-stream-obuf-tail stream)) + byte)) (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED" - 2 + 2 nil - (:none (unsigned-byte 16)) - (:full (unsigned-byte 16))) + (:none (unsigned-byte 16)) + (:full (unsigned-byte 16))) (setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) - byte)) + byte)) (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED" - 2 + 2 nil - (:none (signed-byte 16)) - (:full (signed-byte 16))) + (:none (signed-byte 16)) + (:full (signed-byte 16))) (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream) - (fd-stream-obuf-tail stream)) - byte)) + (fd-stream-obuf-tail stream)) + byte)) (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED" - 4 + 4 nil - (:none (unsigned-byte 32)) - (:full (unsigned-byte 32))) + (:none (unsigned-byte 32)) + (:full (unsigned-byte 32))) (setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream)) - byte)) + byte)) (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED" - 4 + 4 nil - (:none (signed-byte 32)) - (:full (signed-byte 32))) + (:none (signed-byte 32)) + (:full (signed-byte 32))) (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream) - (fd-stream-obuf-tail stream)) - byte)) + (fd-stream-obuf-tail stream)) + byte)) ;;; Do the actual output. If there is space to buffer the string, ;;; buffer it. If the string would normally fit in the buffer, but @@ -424,52 +424,52 @@ "Output THING to FD-STREAM. THING can be any kind of vector or a SAP. If THING is a SAP, END must be supplied (as length won't work)." (let ((start (or start 0)) - (end (or end (length (the (simple-array * (*)) thing))))) + (end (or end (length (the (simple-array * (*)) thing))))) (declare (type index start end)) (when (and (not (fd-stream-dual-channel-p fd-stream)) - (> (fd-stream-ibuf-tail fd-stream) - (fd-stream-ibuf-head fd-stream))) + (> (fd-stream-ibuf-tail fd-stream) + (fd-stream-ibuf-head fd-stream))) (file-position fd-stream (file-position fd-stream))) (let* ((len (fd-stream-obuf-length fd-stream)) - (tail (fd-stream-obuf-tail fd-stream)) - (space (- len tail)) - (bytes (- end start)) - (newtail (+ tail bytes))) + (tail (fd-stream-obuf-tail fd-stream)) + (space (- len tail)) + (bytes (- end start)) + (newtail (+ tail bytes))) (cond ((minusp bytes) ; error case - (error ":END before :START!")) - ((zerop bytes)) ; easy case - ((<= bytes space) - (if (system-area-pointer-p thing) - (system-area-ub8-copy thing start + (error ":END before :START!")) + ((zerop bytes)) ; easy case + ((<= bytes space) + (if (system-area-pointer-p thing) + (system-area-ub8-copy thing start (fd-stream-obuf-sap fd-stream) tail bytes) - ;; FIXME: There should be some type checking somewhere to - ;; verify that THING here is a vector, not just . - (copy-ub8-to-system-area thing start + ;; FIXME: There should be some type checking somewhere to + ;; verify that THING here is a vector, not just . + (copy-ub8-to-system-area thing start (fd-stream-obuf-sap fd-stream) tail bytes)) - (setf (fd-stream-obuf-tail fd-stream) newtail)) - ((<= bytes len) - (flush-output-buffer fd-stream) - (if (system-area-pointer-p thing) - (system-area-ub8-copy thing + (setf (fd-stream-obuf-tail fd-stream) newtail)) + ((<= bytes len) + (flush-output-buffer fd-stream) + (if (system-area-pointer-p thing) + (system-area-ub8-copy thing start (fd-stream-obuf-sap fd-stream) 0 bytes) - ;; FIXME: There should be some type checking somewhere to - ;; verify that THING here is a vector, not just . - (copy-ub8-to-system-area thing + ;; FIXME: There should be some type checking somewhere to + ;; verify that THING here is a vector, not just . + (copy-ub8-to-system-area thing start (fd-stream-obuf-sap fd-stream) 0 bytes)) - (setf (fd-stream-obuf-tail fd-stream) bytes)) - (t - (flush-output-buffer fd-stream) - (frob-output fd-stream thing start end nil)))))) + (setf (fd-stream-obuf-tail fd-stream) bytes)) + (t + (flush-output-buffer fd-stream) + (frob-output fd-stream thing start end nil)))))) ;;; the routine to use to output a string. If the stream is ;;; unbuffered, slam the string down the file descriptor, otherwise @@ -483,20 +483,20 @@ ;;; cover for them here. -- WHN 20000203 (defun fd-sout (stream thing start end) (let ((start (or start 0)) - (end (or end (length (the vector thing))))) + (end (or end (length (the vector thing))))) (declare (fixnum start end)) (if (stringp thing) - (let ((last-newline (and (find #\newline (the simple-string thing) - :start start :end end) - ;; FIXME why do we need both calls? - ;; Is find faster forwards than - ;; position is backwards? - (position #\newline (the simple-string thing) - :from-end t - :start start - :end end)))) - (if (and (typep thing 'base-string) - (eq (fd-stream-external-format stream) :latin-1)) + (let ((last-newline (and (find #\newline (the simple-string thing) + :start start :end end) + ;; FIXME why do we need both calls? + ;; Is find faster forwards than + ;; position is backwards? + (position #\newline (the simple-string thing) + :from-end t + :start start + :end end)))) + (if (and (typep thing 'base-string) + (eq (fd-stream-external-format stream) :latin-1)) (ecase (fd-stream-buffering stream) (:full (output-raw-bytes stream thing start end)) @@ -506,23 +506,23 @@ (flush-output-buffer stream))) (:none (frob-output stream thing start end nil))) - (ecase (fd-stream-buffering stream) - (:full (funcall (fd-stream-output-bytes stream) - stream thing nil start end)) - (:line (funcall (fd-stream-output-bytes stream) - stream thing last-newline start end)) - (:none (funcall (fd-stream-output-bytes stream) - stream thing t start end)))) - (if last-newline - (setf (fd-stream-char-pos stream) - (- end last-newline 1)) - (incf (fd-stream-char-pos stream) - (- end start)))) - (ecase (fd-stream-buffering stream) - ((:line :full) - (output-raw-bytes stream thing start end)) - (:none - (frob-output stream thing start end nil)))))) + (ecase (fd-stream-buffering stream) + (:full (funcall (fd-stream-output-bytes stream) + stream thing nil start end)) + (:line (funcall (fd-stream-output-bytes stream) + stream thing last-newline start end)) + (:none (funcall (fd-stream-output-bytes stream) + stream thing t start end)))) + (if last-newline + (setf (fd-stream-char-pos stream) + (- end last-newline 1)) + (incf (fd-stream-char-pos stream) + (- end start)))) + (ecase (fd-stream-buffering stream) + ((:line :full) + (output-raw-bytes stream thing start end)) + (:none + (frob-output stream thing start end nil)))))) (defvar *external-formats* () #!+sb-doc @@ -537,75 +537,75 @@ (when (subtypep type 'character) (dolist (entry *external-formats*) (when (member external-format (first entry)) - (return-from pick-output-routine - (values (symbol-function (nth (ecase buffering - (:none 4) - (:line 5) - (:full 6)) - entry)) - 'character - 1 - (symbol-function (fourth entry)) - (first (first entry))))))) + (return-from pick-output-routine + (values (symbol-function (nth (ecase buffering + (:none 4) + (:line 5) + (:full 6)) + entry)) + 'character + 1 + (symbol-function (fourth entry)) + (first (first entry))))))) (dolist (entry *output-routines*) (when (and (subtypep type (first entry)) - (eq buffering (second entry)) - (or (not (fifth entry)) - (eq external-format (fifth entry)))) + (eq buffering (second entry)) + (or (not (fifth entry)) + (eq external-format (fifth entry)))) (return-from pick-output-routine - (values (symbol-function (third entry)) - (first entry) - (fourth entry))))) + (values (symbol-function (third entry)) + (first entry) + (fourth entry))))) ;; KLUDGE: dealing with the buffering here leads to excessive code ;; explosion. ;; ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE) - if (subtypep type `(unsigned-byte ,i)) - do (return-from pick-output-routine - (values - (ecase buffering - (:none - (lambda (stream byte) - (output-wrapper (stream (/ i 8) (:none) nil) - (loop for j from 0 below (/ i 8) - do (setf (sap-ref-8 - (fd-stream-obuf-sap stream) - (+ j (fd-stream-obuf-tail stream))) - (ldb (byte 8 (- i 8 (* j 8))) byte)))))) - (:full - (lambda (stream byte) - (output-wrapper (stream (/ i 8) (:full) nil) - (loop for j from 0 below (/ i 8) - do (setf (sap-ref-8 - (fd-stream-obuf-sap stream) - (+ j (fd-stream-obuf-tail stream))) - (ldb (byte 8 (- i 8 (* j 8))) byte))))))) - `(unsigned-byte ,i) - (/ i 8)))) + if (subtypep type `(unsigned-byte ,i)) + do (return-from pick-output-routine + (values + (ecase buffering + (:none + (lambda (stream byte) + (output-wrapper (stream (/ i 8) (:none) nil) + (loop for j from 0 below (/ i 8) + do (setf (sap-ref-8 + (fd-stream-obuf-sap stream) + (+ j (fd-stream-obuf-tail stream))) + (ldb (byte 8 (- i 8 (* j 8))) byte)))))) + (:full + (lambda (stream byte) + (output-wrapper (stream (/ i 8) (:full) nil) + (loop for j from 0 below (/ i 8) + do (setf (sap-ref-8 + (fd-stream-obuf-sap stream) + (+ j (fd-stream-obuf-tail stream))) + (ldb (byte 8 (- i 8 (* j 8))) byte))))))) + `(unsigned-byte ,i) + (/ i 8)))) (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE) - if (subtypep type `(signed-byte ,i)) - do (return-from pick-output-routine - (values - (ecase buffering - (:none - (lambda (stream byte) - (output-wrapper (stream (/ i 8) (:none) nil) - (loop for j from 0 below (/ i 8) - do (setf (sap-ref-8 - (fd-stream-obuf-sap stream) - (+ j (fd-stream-obuf-tail stream))) - (ldb (byte 8 (- i 8 (* j 8))) byte)))))) - (:full - (lambda (stream byte) - (output-wrapper (stream (/ i 8) (:full) nil) - (loop for j from 0 below (/ i 8) - do (setf (sap-ref-8 - (fd-stream-obuf-sap stream) - (+ j (fd-stream-obuf-tail stream))) - (ldb (byte 8 (- i 8 (* j 8))) byte))))))) - `(signed-byte ,i) - (/ i 8))))) + if (subtypep type `(signed-byte ,i)) + do (return-from pick-output-routine + (values + (ecase buffering + (:none + (lambda (stream byte) + (output-wrapper (stream (/ i 8) (:none) nil) + (loop for j from 0 below (/ i 8) + do (setf (sap-ref-8 + (fd-stream-obuf-sap stream) + (+ j (fd-stream-obuf-tail stream))) + (ldb (byte 8 (- i 8 (* j 8))) byte)))))) + (:full + (lambda (stream byte) + (output-wrapper (stream (/ i 8) (:full) nil) + (loop for j from 0 below (/ i 8) + do (setf (sap-ref-8 + (fd-stream-obuf-sap stream) + (+ j (fd-stream-obuf-tail stream))) + (ldb (byte 8 (- i 8 (* j 8))) byte))))))) + `(signed-byte ,i) + (/ i 8))))) ;;;; input routines and related noise @@ -619,24 +619,24 @@ ;;; SYSTEM:SERVER if necessary. (defun refill-buffer/fd (stream) (let ((fd (fd-stream-fd stream)) - (ibuf-sap (fd-stream-ibuf-sap stream)) - (buflen (fd-stream-ibuf-length stream)) - (head (fd-stream-ibuf-head stream)) - (tail (fd-stream-ibuf-tail stream))) + (ibuf-sap (fd-stream-ibuf-sap stream)) + (buflen (fd-stream-ibuf-length stream)) + (head (fd-stream-ibuf-head stream)) + (tail (fd-stream-ibuf-tail stream))) (declare (type index head tail)) (unless (zerop head) (cond ((eql head tail) - (setf head 0) - (setf tail 0) - (setf (fd-stream-ibuf-head stream) 0) - (setf (fd-stream-ibuf-tail stream) 0)) - (t - (decf tail head) - (system-area-ub8-copy ibuf-sap head + (setf head 0) + (setf tail 0) + (setf (fd-stream-ibuf-head stream) 0) + (setf (fd-stream-ibuf-tail stream) 0)) + (t + (decf tail head) + (system-area-ub8-copy ibuf-sap head ibuf-sap 0 tail) - (setf head 0) - (setf (fd-stream-ibuf-head stream) 0) - (setf (fd-stream-ibuf-tail stream) tail)))) + (setf head 0) + (setf (fd-stream-ibuf-head stream) 0) + (setf (fd-stream-ibuf-tail stream) tail)))) (setf (fd-stream-listen stream) nil) (sb!unix:with-restarted-syscall (count errno) ;; FIXME: Judging from compiler warnings, this WITH-ALIEN form expands @@ -652,176 +652,176 @@ (sb!alien:addr read-fds) nil nil 0 0)) (case count - (1) - (0 - (unless (sb!sys:wait-until-fd-usable - fd :input (fd-stream-timeout stream)) - (error 'io-timeout :stream stream :direction :read))) - (t - (simple-stream-perror "couldn't check whether ~S is readable" - stream - errno)))) + (1) + (0 + (unless (sb!sys:wait-until-fd-usable + fd :input (fd-stream-timeout stream)) + (error 'io-timeout :stream stream :direction :read))) + (t + (simple-stream-perror "couldn't check whether ~S is readable" + stream + errno)))) (multiple-value-bind (count errno) - (sb!unix:unix-read fd - (sb!sys:int-sap (+ (sb!sys:sap-int ibuf-sap) tail)) - (- buflen tail)) + (sb!unix:unix-read fd + (sb!sys:int-sap (+ (sb!sys:sap-int ibuf-sap) tail)) + (- buflen tail)) (cond ((null count) - (if (eql errno sb!unix:ewouldblock) - (progn - (unless (sb!sys:wait-until-fd-usable - fd :input (fd-stream-timeout stream)) - (error 'io-timeout :stream stream :direction :read)) - (refill-buffer/fd stream)) - (simple-stream-perror "couldn't read from ~S" stream errno))) - ((zerop count) - (setf (fd-stream-listen stream) :eof) - (/show0 "THROWing EOF-INPUT-CATCHER") - (throw 'eof-input-catcher nil)) - (t - (incf (fd-stream-ibuf-tail stream) count) + (if (eql errno sb!unix:ewouldblock) + (progn + (unless (sb!sys:wait-until-fd-usable + fd :input (fd-stream-timeout stream)) + (error 'io-timeout :stream stream :direction :read)) + (refill-buffer/fd stream)) + (simple-stream-perror "couldn't read from ~S" stream errno))) + ((zerop count) + (setf (fd-stream-listen stream) :eof) + (/show0 "THROWing EOF-INPUT-CATCHER") + (throw 'eof-input-catcher nil)) + (t + (incf (fd-stream-ibuf-tail stream) count) count))))) - + ;;; Make sure there are at least BYTES number of bytes in the input ;;; buffer. Keep calling REFILL-BUFFER/FD until that condition is met. (defmacro input-at-least (stream bytes) (let ((stream-var (gensym)) - (bytes-var (gensym))) + (bytes-var (gensym))) `(let ((,stream-var ,stream) - (,bytes-var ,bytes)) + (,bytes-var ,bytes)) (loop - (when (>= (- (fd-stream-ibuf-tail ,stream-var) - (fd-stream-ibuf-head ,stream-var)) - ,bytes-var) - (return)) - (refill-buffer/fd ,stream-var))))) + (when (>= (- (fd-stream-ibuf-tail ,stream-var) + (fd-stream-ibuf-head ,stream-var)) + ,bytes-var) + (return)) + (refill-buffer/fd ,stream-var))))) (defmacro input-wrapper/variable-width ((stream bytes eof-error eof-value) - &body read-forms) + &body read-forms) (let ((stream-var (gensym)) - (retry-var (gensym)) - (element-var (gensym))) + (retry-var (gensym)) + (element-var (gensym))) `(let ((,stream-var ,stream) - (size nil)) + (size nil)) (if (fd-stream-unread ,stream-var) - (prog1 - (fd-stream-unread ,stream-var) - (setf (fd-stream-unread ,stream-var) nil) - (setf (fd-stream-listen ,stream-var) nil)) - (let ((,element-var nil) - (decode-break-reason nil)) - (do ((,retry-var t)) - ((not ,retry-var)) - (unless - (catch 'eof-input-catcher - (setf decode-break-reason - (block decode-break-reason - (input-at-least ,stream-var 1) - (let* ((byte (sap-ref-8 (fd-stream-ibuf-sap - ,stream-var) - (fd-stream-ibuf-head - ,stream-var)))) - (setq size ,bytes) - (input-at-least ,stream-var size) - (setq ,element-var (locally ,@read-forms)) - (setq ,retry-var nil)) - nil)) - (when decode-break-reason - (stream-decoding-error-and-handle stream - decode-break-reason)) - t) - (let ((octet-count (- (fd-stream-ibuf-tail ,stream-var) - (fd-stream-ibuf-head ,stream-var)))) - (when (or (zerop octet-count) - (and (not ,element-var) - (not decode-break-reason) - (stream-decoding-error-and-handle - stream octet-count))) - (setq ,retry-var nil))))) - (cond (,element-var - (incf (fd-stream-ibuf-head ,stream-var) size) - ,element-var) - (t - (eof-or-lose ,stream-var ,eof-error ,eof-value)))))))) + (prog1 + (fd-stream-unread ,stream-var) + (setf (fd-stream-unread ,stream-var) nil) + (setf (fd-stream-listen ,stream-var) nil)) + (let ((,element-var nil) + (decode-break-reason nil)) + (do ((,retry-var t)) + ((not ,retry-var)) + (unless + (catch 'eof-input-catcher + (setf decode-break-reason + (block decode-break-reason + (input-at-least ,stream-var 1) + (let* ((byte (sap-ref-8 (fd-stream-ibuf-sap + ,stream-var) + (fd-stream-ibuf-head + ,stream-var)))) + (setq size ,bytes) + (input-at-least ,stream-var size) + (setq ,element-var (locally ,@read-forms)) + (setq ,retry-var nil)) + nil)) + (when decode-break-reason + (stream-decoding-error-and-handle stream + decode-break-reason)) + t) + (let ((octet-count (- (fd-stream-ibuf-tail ,stream-var) + (fd-stream-ibuf-head ,stream-var)))) + (when (or (zerop octet-count) + (and (not ,element-var) + (not decode-break-reason) + (stream-decoding-error-and-handle + stream octet-count))) + (setq ,retry-var nil))))) + (cond (,element-var + (incf (fd-stream-ibuf-head ,stream-var) size) + ,element-var) + (t + (eof-or-lose ,stream-var ,eof-error ,eof-value)))))))) ;;; a macro to wrap around all input routines to handle EOF-ERROR noise (defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms) (let ((stream-var (gensym)) - (element-var (gensym))) + (element-var (gensym))) `(let ((,stream-var ,stream)) (if (fd-stream-unread ,stream-var) - (prog1 - (fd-stream-unread ,stream-var) - (setf (fd-stream-unread ,stream-var) nil) - (setf (fd-stream-listen ,stream-var) nil)) - (let ((,element-var - (catch 'eof-input-catcher - (input-at-least ,stream-var ,bytes) - (locally ,@read-forms)))) - (cond (,element-var - (incf (fd-stream-ibuf-head ,stream-var) ,bytes) - ,element-var) - (t - (eof-or-lose ,stream-var ,eof-error ,eof-value)))))))) + (prog1 + (fd-stream-unread ,stream-var) + (setf (fd-stream-unread ,stream-var) nil) + (setf (fd-stream-listen ,stream-var) nil)) + (let ((,element-var + (catch 'eof-input-catcher + (input-at-least ,stream-var ,bytes) + (locally ,@read-forms)))) + (cond (,element-var + (incf (fd-stream-ibuf-head ,stream-var) ,bytes) + ,element-var) + (t + (eof-or-lose ,stream-var ,eof-error ,eof-value)))))))) (defmacro def-input-routine/variable-width (name - (type external-format size sap head) - &rest body) + (type external-format size sap head) + &rest body) `(progn (defun ,name (stream eof-error eof-value) (input-wrapper/variable-width (stream ,size eof-error eof-value) - (let ((,sap (fd-stream-ibuf-sap stream)) - (,head (fd-stream-ibuf-head stream))) - ,@body))) + (let ((,sap (fd-stream-ibuf-sap stream)) + (,head (fd-stream-ibuf-head stream))) + ,@body))) (setf *input-routines* - (nconc *input-routines* - (list (list ',type ',name 1 ',external-format)))))) + (nconc *input-routines* + (list (list ',type ',name 1 ',external-format)))))) (defmacro def-input-routine (name - (type size sap head) - &rest body) + (type size sap head) + &rest body) `(progn (defun ,name (stream eof-error eof-value) (input-wrapper (stream ,size eof-error eof-value) - (let ((,sap (fd-stream-ibuf-sap stream)) - (,head (fd-stream-ibuf-head stream))) - ,@body))) + (let ((,sap (fd-stream-ibuf-sap stream)) + (,head (fd-stream-ibuf-head stream))) + ,@body))) (setf *input-routines* - (nconc *input-routines* - (list (list ',type ',name ',size nil)))))) + (nconc *input-routines* + (list (list ',type ',name ',size nil)))))) ;;; STREAM-IN routine for reading a string char (def-input-routine input-character - (character 1 sap head) + (character 1 sap head) (code-char (sap-ref-8 sap head))) ;;; STREAM-IN routine for reading an unsigned 8 bit number (def-input-routine input-unsigned-8bit-byte - ((unsigned-byte 8) 1 sap head) + ((unsigned-byte 8) 1 sap head) (sap-ref-8 sap head)) ;;; STREAM-IN routine for reading a signed 8 bit number (def-input-routine input-signed-8bit-number - ((signed-byte 8) 1 sap head) + ((signed-byte 8) 1 sap head) (signed-sap-ref-8 sap head)) ;;; STREAM-IN routine for reading an unsigned 16 bit number (def-input-routine input-unsigned-16bit-byte - ((unsigned-byte 16) 2 sap head) + ((unsigned-byte 16) 2 sap head) (sap-ref-16 sap head)) ;;; STREAM-IN routine for reading a signed 16 bit number (def-input-routine input-signed-16bit-byte - ((signed-byte 16) 2 sap head) + ((signed-byte 16) 2 sap head) (signed-sap-ref-16 sap head)) ;;; STREAM-IN routine for reading a unsigned 32 bit number (def-input-routine input-unsigned-32bit-byte - ((unsigned-byte 32) 4 sap head) + ((unsigned-byte 32) 4 sap head) (sap-ref-32 sap head)) ;;; STREAM-IN routine for reading a signed 32 bit number (def-input-routine input-signed-32bit-byte - ((signed-byte 32) 4 sap head) + ((signed-byte 32) 4 sap head) (signed-sap-ref-32 sap head)) @@ -833,63 +833,63 @@ (when (subtypep type 'character) (dolist (entry *external-formats*) (when (member external-format (first entry)) - (return-from pick-input-routine - (values (symbol-function (third entry)) - 'character - 1 - (symbol-function (second entry)) - (first (first entry))))))) + (return-from pick-input-routine + (values (symbol-function (third entry)) + 'character + 1 + (symbol-function (second entry)) + (first (first entry))))))) (dolist (entry *input-routines*) (when (and (subtypep type (first entry)) - (or (not (fourth entry)) - (eq external-format (fourth entry)))) + (or (not (fourth entry)) + (eq external-format (fourth entry)))) (return-from pick-input-routine - (values (symbol-function (second entry)) - (first entry) - (third entry))))) + (values (symbol-function (second entry)) + (first entry) + (third entry))))) ;; FIXME: let's do it the hard way, then (but ignore things like ;; endianness, efficiency, and the necessary coupling between these ;; and the output routines). -- CSR, 2004-02-09 (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE really) - if (subtypep type `(unsigned-byte ,i)) - do (return-from pick-input-routine - (values - (lambda (stream eof-error eof-value) - (input-wrapper (stream (/ i 8) eof-error eof-value) - (let ((sap (fd-stream-ibuf-sap stream)) - (head (fd-stream-ibuf-head stream))) - (loop for j from 0 below (/ i 8) - with result = 0 - do (setf result - (+ (* 256 result) - (sap-ref-8 sap (+ head j)))) - finally (return result))))) - `(unsigned-byte ,i) - (/ i 8)))) + if (subtypep type `(unsigned-byte ,i)) + do (return-from pick-input-routine + (values + (lambda (stream eof-error eof-value) + (input-wrapper (stream (/ i 8) eof-error eof-value) + (let ((sap (fd-stream-ibuf-sap stream)) + (head (fd-stream-ibuf-head stream))) + (loop for j from 0 below (/ i 8) + with result = 0 + do (setf result + (+ (* 256 result) + (sap-ref-8 sap (+ head j)))) + finally (return result))))) + `(unsigned-byte ,i) + (/ i 8)))) (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE really) - if (subtypep type `(signed-byte ,i)) - do (return-from pick-input-routine - (values - (lambda (stream eof-error eof-value) - (input-wrapper (stream (/ i 8) eof-error eof-value) - (let ((sap (fd-stream-ibuf-sap stream)) - (head (fd-stream-ibuf-head stream))) - (loop for j from 0 below (/ i 8) - with result = 0 - do (setf result - (+ (* 256 result) - (sap-ref-8 sap (+ head j)))) - finally (return (if (logbitp (1- i) result) + if (subtypep type `(signed-byte ,i)) + do (return-from pick-input-routine + (values + (lambda (stream eof-error eof-value) + (input-wrapper (stream (/ i 8) eof-error eof-value) + (let ((sap (fd-stream-ibuf-sap stream)) + (head (fd-stream-ibuf-head stream))) + (loop for j from 0 below (/ i 8) + with result = 0 + do (setf result + (+ (* 256 result) + (sap-ref-8 sap (+ head j)))) + finally (return (if (logbitp (1- i) result) (dpb result (byte i 0) -1) result)))))) - `(signed-byte ,i) - (/ i 8))))) + `(signed-byte ,i) + (/ i 8))))) ;;; Return a string constructed from SAP, START, and END. (defun string-from-sap (sap start end) (declare (type index start end)) (let* ((length (- end start)) - (string (make-string length))) + (string (make-string length))) (copy-ub8-from-system-area sap start string 0 length) @@ -901,7 +901,7 @@ ;;; there is a definite amount of reading to be done, so blocking ;;; isn't too problematical. (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p - &aux (total-copied 0)) + &aux (total-copied 0)) (declare (type fd-stream stream)) (declare (type index start requested total-copied)) (let ((unread (fd-stream-unread stream))) @@ -913,47 +913,47 @@ ;; KLUDGE: this is a slightly-unrolled-and-inlined version of ;; %BYTE-BLT (etypecase buffer - (system-area-pointer - (setf (sap-ref-8 buffer start) (char-code unread))) - ((simple-unboxed-array (*)) - (setf (aref buffer start) unread))) + (system-area-pointer + (setf (sap-ref-8 buffer start) (char-code unread))) + ((simple-unboxed-array (*)) + (setf (aref buffer start) unread))) (setf (fd-stream-unread stream) nil) (setf (fd-stream-listen stream) nil) (incf total-copied))) (do () (nil) (let* ((remaining-request (- requested total-copied)) - (head (fd-stream-ibuf-head stream)) - (tail (fd-stream-ibuf-tail stream)) - (available (- tail head)) - (n-this-copy (min remaining-request available)) - (this-start (+ start total-copied)) - (this-end (+ this-start n-this-copy)) - (sap (fd-stream-ibuf-sap stream))) + (head (fd-stream-ibuf-head stream)) + (tail (fd-stream-ibuf-tail stream)) + (available (- tail head)) + (n-this-copy (min remaining-request available)) + (this-start (+ start total-copied)) + (this-end (+ this-start n-this-copy)) + (sap (fd-stream-ibuf-sap stream))) (declare (type index remaining-request head tail available)) (declare (type index n-this-copy)) - ;; Copy data from stream buffer into user's buffer. + ;; Copy data from stream buffer into user's buffer. (%byte-blt sap head buffer this-start this-end) (incf (fd-stream-ibuf-head stream) n-this-copy) (incf total-copied n-this-copy) ;; Maybe we need to refill the stream buffer. (cond (;; If there were enough data in the stream buffer, we're done. - (= total-copied requested) - (return total-copied)) - (;; If EOF, we're done in another way. + (= total-copied requested) + (return total-copied)) + (;; If EOF, we're done in another way. (null (catch 'eof-input-catcher (refill-buffer/fd stream))) - (if eof-error-p - (error 'end-of-file :stream stream) - (return total-copied))) - ;; Otherwise we refilled the stream buffer, so fall - ;; through into another pass of the loop. - )))) + (if eof-error-p + (error 'end-of-file :stream stream) + (return total-copied))) + ;; Otherwise we refilled the stream buffer, so fall + ;; through into another pass of the loop. + )))) (defun fd-stream-resync (stream) (dolist (entry *external-formats*) (when (member (fd-stream-external-format stream) (first entry)) (return-from fd-stream-resync - (funcall (symbol-function (eighth entry)) stream))))) + (funcall (symbol-function (eighth entry)) stream))))) ;;; FIXME: OAOOM here vrt. *EXTERNAL-FORMAT-FUNCTIONS* in fd-stream.lisp (defmacro define-external-format (external-format size output-restart @@ -965,238 +965,238 @@ (in-char-function (symbolicate "INPUT-CHAR/" name))) `(progn (defun ,out-function (stream string flush-p start end) - (let ((start (or start 0)) - (end (or end (length string)))) - (declare (type index start end)) - (when (and (not (fd-stream-dual-channel-p stream)) - (> (fd-stream-ibuf-tail stream) - (fd-stream-ibuf-head stream))) - (file-position stream (file-position stream))) - (when (< end start) - (error ":END before :START!")) - (do () - ((= end start)) - (setf (fd-stream-obuf-tail stream) - (do* ((len (fd-stream-obuf-length stream)) - (sap (fd-stream-obuf-sap stream)) - (tail (fd-stream-obuf-tail stream))) - ((or (= start end) (< (- len tail) 4)) tail) + (let ((start (or start 0)) + (end (or end (length string)))) + (declare (type index start end)) + (when (and (not (fd-stream-dual-channel-p stream)) + (> (fd-stream-ibuf-tail stream) + (fd-stream-ibuf-head stream))) + (file-position stream (file-position stream))) + (when (< end start) + (error ":END before :START!")) + (do () + ((= end start)) + (setf (fd-stream-obuf-tail stream) + (do* ((len (fd-stream-obuf-length stream)) + (sap (fd-stream-obuf-sap stream)) + (tail (fd-stream-obuf-tail stream))) + ((or (= start end) (< (- len tail) 4)) tail) ,(if output-restart - `(catch 'output-nothing - (let* ((byte (aref string start)) - (bits (char-code byte))) - ,out-expr - (incf tail ,size))) + `(catch 'output-nothing + (let* ((byte (aref string start)) + (bits (char-code byte))) + ,out-expr + (incf tail ,size))) `(let* ((byte (aref string start)) (bits (char-code byte))) ,out-expr (incf tail ,size))) - (incf start))) - (when (< start end) - (flush-output-buffer stream))) - (when flush-p - (flush-output-buffer stream)))) + (incf start))) + (when (< start end) + (flush-output-buffer stream))) + (when flush-p + (flush-output-buffer stream)))) (def-output-routines (,format - ,size + ,size ,output-restart - (:none character) - (:line character) - (:full character)) - (if (char= byte #\Newline) - (setf (fd-stream-char-pos stream) 0) - (incf (fd-stream-char-pos stream))) - (let ((bits (char-code byte)) - (sap (fd-stream-obuf-sap stream)) - (tail (fd-stream-obuf-tail stream))) - ,out-expr)) + (:none character) + (:line character) + (:full character)) + (if (char= byte #\Newline) + (setf (fd-stream-char-pos stream) 0) + (incf (fd-stream-char-pos stream))) + (let ((bits (char-code byte)) + (sap (fd-stream-obuf-sap stream)) + (tail (fd-stream-obuf-tail stream))) + ,out-expr)) (defun ,in-function (stream buffer start requested eof-error-p - &aux (total-copied 0)) - (declare (type fd-stream stream)) - (declare (type index start requested total-copied)) - (let ((unread (fd-stream-unread stream))) - (when unread - (setf (aref buffer start) unread) - (setf (fd-stream-unread stream) nil) - (setf (fd-stream-listen stream) nil) - (incf total-copied))) - (do () - (nil) - (let* ((head (fd-stream-ibuf-head stream)) - (tail (fd-stream-ibuf-tail stream)) - (sap (fd-stream-ibuf-sap stream))) - (declare (type index head tail)) - ;; Copy data from stream buffer into user's buffer. - (do () - ((or (= tail head) (= requested total-copied))) - (let* ((byte (sap-ref-8 sap head))) - (when (> ,size (- tail head)) - (return)) - (setf (aref buffer (+ start total-copied)) ,in-expr) - (incf total-copied) - (incf head ,size))) - (setf (fd-stream-ibuf-head stream) head) - ;; Maybe we need to refill the stream buffer. - (cond ( ;; If there were enough data in the stream buffer, we're done. - (= total-copied requested) - (return total-copied)) - ( ;; If EOF, we're done in another way. + &aux (total-copied 0)) + (declare (type fd-stream stream)) + (declare (type index start requested total-copied)) + (let ((unread (fd-stream-unread stream))) + (when unread + (setf (aref buffer start) unread) + (setf (fd-stream-unread stream) nil) + (setf (fd-stream-listen stream) nil) + (incf total-copied))) + (do () + (nil) + (let* ((head (fd-stream-ibuf-head stream)) + (tail (fd-stream-ibuf-tail stream)) + (sap (fd-stream-ibuf-sap stream))) + (declare (type index head tail)) + ;; Copy data from stream buffer into user's buffer. + (do () + ((or (= tail head) (= requested total-copied))) + (let* ((byte (sap-ref-8 sap head))) + (when (> ,size (- tail head)) + (return)) + (setf (aref buffer (+ start total-copied)) ,in-expr) + (incf total-copied) + (incf head ,size))) + (setf (fd-stream-ibuf-head stream) head) + ;; Maybe we need to refill the stream buffer. + (cond ( ;; If there were enough data in the stream buffer, we're done. + (= total-copied requested) + (return total-copied)) + ( ;; If EOF, we're done in another way. (null (catch 'eof-input-catcher (refill-buffer/fd stream))) - (if eof-error-p - (error 'end-of-file :stream stream) - (return total-copied))) - ;; Otherwise we refilled the stream buffer, so fall - ;; through into another pass of the loop. - )))) + (if eof-error-p + (error 'end-of-file :stream stream) + (return total-copied))) + ;; Otherwise we refilled the stream buffer, so fall + ;; through into another pass of the loop. + )))) (def-input-routine ,in-char-function (character ,size sap head) - (let ((byte (sap-ref-8 sap head))) - ,in-expr)) + (let ((byte (sap-ref-8 sap head))) + ,in-expr)) (setf *external-formats* (cons '(,external-format ,in-function ,in-char-function ,out-function - ,@(mapcar #'(lambda (buffering) - (intern (format nil format (string buffering)))) - '(:none :line :full))) - *external-formats*))))) + ,@(mapcar #'(lambda (buffering) + (intern (format nil format (string buffering)))) + '(:none :line :full))) + *external-formats*))))) (defmacro define-external-format/variable-width (external-format output-restart out-size-expr out-expr in-size-expr in-expr) (let* ((name (first external-format)) - (out-function (symbolicate "OUTPUT-BYTES/" name)) - (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name))) - (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name)) - (in-char-function (symbolicate "INPUT-CHAR/" name)) - (resync-function (symbolicate "RESYNC/" name))) + (out-function (symbolicate "OUTPUT-BYTES/" name)) + (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name))) + (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name)) + (in-char-function (symbolicate "INPUT-CHAR/" name)) + (resync-function (symbolicate "RESYNC/" name))) `(progn (defun ,out-function (stream string flush-p start end) - (let ((start (or start 0)) - (end (or end (length string)))) - (declare (type index start end)) - (when (and (not (fd-stream-dual-channel-p stream)) - (> (fd-stream-ibuf-tail stream) - (fd-stream-ibuf-head stream))) - (file-position stream (file-position stream))) - (when (< end start) - (error ":END before :START!")) - (do () - ((= end start)) - (setf (fd-stream-obuf-tail stream) - (do* ((len (fd-stream-obuf-length stream)) - (sap (fd-stream-obuf-sap stream)) - (tail (fd-stream-obuf-tail stream))) - ((or (= start end) (< (- len tail) 4)) tail) - ,(if output-restart - `(catch 'output-nothing - (let* ((byte (aref string start)) - (bits (char-code byte)) - (size ,out-size-expr)) - ,out-expr - (incf tail size))) - `(let* ((byte (aref string start)) - (bits (char-code byte)) - (size ,out-size-expr)) - ,out-expr - (incf tail size))) - (incf start))) - (when (< start end) - (flush-output-buffer stream))) - (when flush-p - (flush-output-buffer stream)))) + (let ((start (or start 0)) + (end (or end (length string)))) + (declare (type index start end)) + (when (and (not (fd-stream-dual-channel-p stream)) + (> (fd-stream-ibuf-tail stream) + (fd-stream-ibuf-head stream))) + (file-position stream (file-position stream))) + (when (< end start) + (error ":END before :START!")) + (do () + ((= end start)) + (setf (fd-stream-obuf-tail stream) + (do* ((len (fd-stream-obuf-length stream)) + (sap (fd-stream-obuf-sap stream)) + (tail (fd-stream-obuf-tail stream))) + ((or (= start end) (< (- len tail) 4)) tail) + ,(if output-restart + `(catch 'output-nothing + (let* ((byte (aref string start)) + (bits (char-code byte)) + (size ,out-size-expr)) + ,out-expr + (incf tail size))) + `(let* ((byte (aref string start)) + (bits (char-code byte)) + (size ,out-size-expr)) + ,out-expr + (incf tail size))) + (incf start))) + (when (< start end) + (flush-output-buffer stream))) + (when flush-p + (flush-output-buffer stream)))) (def-output-routines/variable-width (,format - ,out-size-expr + ,out-size-expr ,output-restart - ,external-format - (:none character) - (:line character) - (:full character)) - (if (char= byte #\Newline) - (setf (fd-stream-char-pos stream) 0) - (incf (fd-stream-char-pos stream))) - (let ((bits (char-code byte)) - (sap (fd-stream-obuf-sap stream)) - (tail (fd-stream-obuf-tail stream))) - ,out-expr)) + ,external-format + (:none character) + (:line character) + (:full character)) + (if (char= byte #\Newline) + (setf (fd-stream-char-pos stream) 0) + (incf (fd-stream-char-pos stream))) + (let ((bits (char-code byte)) + (sap (fd-stream-obuf-sap stream)) + (tail (fd-stream-obuf-tail stream))) + ,out-expr)) (defun ,in-function (stream buffer start requested eof-error-p - &aux (total-copied 0)) - (declare (type fd-stream stream)) - (declare (type index start requested total-copied)) - (let ((unread (fd-stream-unread stream))) - (when unread - (setf (aref buffer start) unread) - (setf (fd-stream-unread stream) nil) - (setf (fd-stream-listen stream) nil) - (incf total-copied))) - (do () - (nil) - (let* ((head (fd-stream-ibuf-head stream)) - (tail (fd-stream-ibuf-tail stream)) - (sap (fd-stream-ibuf-sap stream)) - (head-start head) - (decode-break-reason nil)) - (declare (type index head tail)) - ;; Copy data from stream buffer into user's buffer. - (do ((size nil nil)) - ((or (= tail head) (= requested total-copied))) - (setf decode-break-reason - (block decode-break-reason - (let ((byte (sap-ref-8 sap head))) - (setq size ,in-size-expr) - (when (> size (- tail head)) - (return)) - (setf (aref buffer (+ start total-copied)) ,in-expr) - (incf total-copied) - (incf head size)) - nil)) - (setf (fd-stream-ibuf-head stream) head) - (when (and decode-break-reason - (= head head-start)) - (when (stream-decoding-error-and-handle - stream decode-break-reason) - (if eof-error-p - (error 'end-of-file :stream stream) - (return-from ,in-function total-copied))) - (setf head (fd-stream-ibuf-head stream)) - (setf tail (fd-stream-ibuf-tail stream))) - (when (plusp total-copied) - (return-from ,in-function total-copied))) - (setf (fd-stream-ibuf-head stream) head) - ;; Maybe we need to refill the stream buffer. - (cond ( ;; If there were enough data in the stream buffer, we're done. - (= total-copied requested) - (return total-copied)) - ( ;; If EOF, we're done in another way. - (or (eq decode-break-reason 'eof) - (null (catch 'eof-input-catcher + &aux (total-copied 0)) + (declare (type fd-stream stream)) + (declare (type index start requested total-copied)) + (let ((unread (fd-stream-unread stream))) + (when unread + (setf (aref buffer start) unread) + (setf (fd-stream-unread stream) nil) + (setf (fd-stream-listen stream) nil) + (incf total-copied))) + (do () + (nil) + (let* ((head (fd-stream-ibuf-head stream)) + (tail (fd-stream-ibuf-tail stream)) + (sap (fd-stream-ibuf-sap stream)) + (head-start head) + (decode-break-reason nil)) + (declare (type index head tail)) + ;; Copy data from stream buffer into user's buffer. + (do ((size nil nil)) + ((or (= tail head) (= requested total-copied))) + (setf decode-break-reason + (block decode-break-reason + (let ((byte (sap-ref-8 sap head))) + (setq size ,in-size-expr) + (when (> size (- tail head)) + (return)) + (setf (aref buffer (+ start total-copied)) ,in-expr) + (incf total-copied) + (incf head size)) + nil)) + (setf (fd-stream-ibuf-head stream) head) + (when (and decode-break-reason + (= head head-start)) + (when (stream-decoding-error-and-handle + stream decode-break-reason) + (if eof-error-p + (error 'end-of-file :stream stream) + (return-from ,in-function total-copied))) + (setf head (fd-stream-ibuf-head stream)) + (setf tail (fd-stream-ibuf-tail stream))) + (when (plusp total-copied) + (return-from ,in-function total-copied))) + (setf (fd-stream-ibuf-head stream) head) + ;; Maybe we need to refill the stream buffer. + (cond ( ;; If there were enough data in the stream buffer, we're done. + (= total-copied requested) + (return total-copied)) + ( ;; If EOF, we're done in another way. + (or (eq decode-break-reason 'eof) + (null (catch 'eof-input-catcher (refill-buffer/fd stream)))) - (if eof-error-p - (error 'end-of-file :stream stream) - (return total-copied))) - ;; Otherwise we refilled the stream buffer, so fall - ;; through into another pass of the loop. - )))) + (if eof-error-p + (error 'end-of-file :stream stream) + (return total-copied))) + ;; Otherwise we refilled the stream buffer, so fall + ;; through into another pass of the loop. + )))) (def-input-routine/variable-width ,in-char-function (character - ,external-format - ,in-size-expr - sap head) - (let ((byte (sap-ref-8 sap head))) - ,in-expr)) + ,external-format + ,in-size-expr + sap head) + (let ((byte (sap-ref-8 sap head))) + ,in-expr)) (defun ,resync-function (stream) (loop (input-at-least stream 1) (incf (fd-stream-ibuf-head stream)) (unless (block decode-break-reason - (let* ((sap (fd-stream-ibuf-sap stream)) - (head (fd-stream-ibuf-head stream)) - (byte (sap-ref-8 sap head)) - (size ,in-size-expr)) - ,in-expr) - nil) + (let* ((sap (fd-stream-ibuf-sap stream)) + (head (fd-stream-ibuf-head stream)) + (byte (sap-ref-8 sap head)) + (size ,in-size-expr)) + ,in-expr) + nil) (return)))) (setf *external-formats* (cons '(,external-format ,in-function ,in-char-function ,out-function - ,@(mapcar #'(lambda (buffering) - (intern (format nil format (string buffering)))) - '(:none :line :full)) - ,resync-function) - *external-formats*))))) + ,@(mapcar #'(lambda (buffering) + (intern (format nil format (string buffering)))) + '(:none :line :full)) + ,resync-function) + *external-formats*))))) (define-external-format (:latin-1 :latin1 :iso-8859-1) 1 t @@ -1205,7 +1205,7 @@ (setf (sap-ref-8 sap tail) bits)) (code-char byte)) -(define-external-format (:ascii :us-ascii :ansi_x3.4-1968 +(define-external-format (:ascii :us-ascii :ansi_x3.4-1968 :iso-646 :iso-646-us :|646|) 1 t (if (>= bits 128) @@ -1214,36 +1214,36 @@ (code-char byte)) (let* ((table (let ((s (make-string 256))) - (map-into s #'code-char - '(#x00 #x01 #x02 #x03 #x9c #x09 #x86 #x7f #x97 #x8d #x8e #x0b #x0c #x0d #x0e #x0f - #x10 #x11 #x12 #x13 #x9d #x85 #x08 #x87 #x18 #x19 #x92 #x8f #x1c #x1d #x1e #x1f - #x80 #x81 #x82 #x83 #x84 #x0a #x17 #x1b #x88 #x89 #x8a #x8b #x8c #x05 #x06 #x07 - #x90 #x91 #x16 #x93 #x94 #x95 #x96 #x04 #x98 #x99 #x9a #x9b #x14 #x15 #x9e #x1a - #x20 #xa0 #xe2 #xe4 #xe0 #xe1 #xe3 #xe5 #xe7 #xf1 #xa2 #x2e #x3c #x28 #x2b #x7c - #x26 #xe9 #xea #xeb #xe8 #xed #xee #xef #xec #xdf #x21 #x24 #x2a #x29 #x3b #xac - #x2d #x2f #xc2 #xc4 #xc0 #xc1 #xc3 #xc5 #xc7 #xd1 #xa6 #x2c #x25 #x5f #x3e #x3f - #xf8 #xc9 #xca #xcb #xc8 #xcd #xce #xcf #xcc #x60 #x3a #x23 #x40 #x27 #x3d #x22 - #xd8 #x61 #x62 #x63 #x64 #x65 #x66 #x67 #x68 #x69 #xab #xbb #xf0 #xfd #xfe #xb1 - #xb0 #x6a #x6b #x6c #x6d #x6e #x6f #x70 #x71 #x72 #xaa #xba #xe6 #xb8 #xc6 #xa4 - #xb5 #x7e #x73 #x74 #x75 #x76 #x77 #x78 #x79 #x7a #xa1 #xbf #xd0 #xdd #xde #xae - #x5e #xa3 #xa5 #xb7 #xa9 #xa7 #xb6 #xbc #xbd #xbe #x5b #x5d #xaf #xa8 #xb4 #xd7 - #x7b #x41 #x42 #x43 #x44 #x45 #x46 #x47 #x48 #x49 #xad #xf4 #xf6 #xf2 #xf3 #xf5 - #x7d #x4a #x4b #x4c #x4d #x4e #x4f #x50 #x51 #x52 #xb9 #xfb #xfc #xf9 #xfa #xff - #x5c #xf7 #x53 #x54 #x55 #x56 #x57 #x58 #x59 #x5a #xb2 #xd4 #xd6 #xd2 #xd3 #xd5 - #x30 #x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38 #x39 #xb3 #xdb #xdc #xd9 #xda #x9f)) - s)) + (map-into s #'code-char + '(#x00 #x01 #x02 #x03 #x9c #x09 #x86 #x7f #x97 #x8d #x8e #x0b #x0c #x0d #x0e #x0f + #x10 #x11 #x12 #x13 #x9d #x85 #x08 #x87 #x18 #x19 #x92 #x8f #x1c #x1d #x1e #x1f + #x80 #x81 #x82 #x83 #x84 #x0a #x17 #x1b #x88 #x89 #x8a #x8b #x8c #x05 #x06 #x07 + #x90 #x91 #x16 #x93 #x94 #x95 #x96 #x04 #x98 #x99 #x9a #x9b #x14 #x15 #x9e #x1a + #x20 #xa0 #xe2 #xe4 #xe0 #xe1 #xe3 #xe5 #xe7 #xf1 #xa2 #x2e #x3c #x28 #x2b #x7c + #x26 #xe9 #xea #xeb #xe8 #xed #xee #xef #xec #xdf #x21 #x24 #x2a #x29 #x3b #xac + #x2d #x2f #xc2 #xc4 #xc0 #xc1 #xc3 #xc5 #xc7 #xd1 #xa6 #x2c #x25 #x5f #x3e #x3f + #xf8 #xc9 #xca #xcb #xc8 #xcd #xce #xcf #xcc #x60 #x3a #x23 #x40 #x27 #x3d #x22 + #xd8 #x61 #x62 #x63 #x64 #x65 #x66 #x67 #x68 #x69 #xab #xbb #xf0 #xfd #xfe #xb1 + #xb0 #x6a #x6b #x6c #x6d #x6e #x6f #x70 #x71 #x72 #xaa #xba #xe6 #xb8 #xc6 #xa4 + #xb5 #x7e #x73 #x74 #x75 #x76 #x77 #x78 #x79 #x7a #xa1 #xbf #xd0 #xdd #xde #xae + #x5e #xa3 #xa5 #xb7 #xa9 #xa7 #xb6 #xbc #xbd #xbe #x5b #x5d #xaf #xa8 #xb4 #xd7 + #x7b #x41 #x42 #x43 #x44 #x45 #x46 #x47 #x48 #x49 #xad #xf4 #xf6 #xf2 #xf3 #xf5 + #x7d #x4a #x4b #x4c #x4d #x4e #x4f #x50 #x51 #x52 #xb9 #xfb #xfc #xf9 #xfa #xff + #x5c #xf7 #x53 #x54 #x55 #x56 #x57 #x58 #x59 #x5a #xb2 #xd4 #xd6 #xd2 #xd3 #xd5 + #x30 #x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38 #x39 #xb3 #xdb #xdc #xd9 #xda #x9f)) + s)) (reverse-table (let ((rt (make-array 256 :element-type '(unsigned-byte 8) :initial-element 0))) - (loop for char across table for i from 0 - do (aver (= 0 (aref rt (char-code char)))) - do (setf (aref rt (char-code char)) i)) - rt))) + (loop for char across table for i from 0 + do (aver (= 0 (aref rt (char-code char)))) + do (setf (aref rt (char-code char)) i)) + rt))) (define-external-format (:ebcdic-us :ibm-037 :ibm037) 1 t (if (>= bits 256) - (stream-encoding-error-and-handle stream bits) - (setf (sap-ref-8 sap tail) (aref reverse-table bits))) + (stream-encoding-error-and-handle stream bits) + (setf (sap-ref-8 sap tail) (aref reverse-table bits))) (aref table byte))) - + #!+sb-unicode (let ((latin-9-table (let ((table (make-string 256))) @@ -1280,47 +1280,47 @@ (define-external-format/variable-width (:utf-8 :utf8) nil (let ((bits (char-code byte))) (cond ((< bits #x80) 1) - ((< bits #x800) 2) - ((< bits #x10000) 3) - (t 4))) + ((< bits #x800) 2) + ((< bits #x10000) 3) + (t 4))) (ecase size (1 (setf (sap-ref-8 sap tail) bits)) (2 (setf (sap-ref-8 sap tail) (logior #xc0 (ldb (byte 5 6) bits)) - (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 0) bits)))) + (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 0) bits)))) (3 (setf (sap-ref-8 sap tail) (logior #xe0 (ldb (byte 4 12) bits)) - (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 6) bits)) - (sap-ref-8 sap (+ 2 tail)) (logior #x80 (ldb (byte 6 0) bits)))) + (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 6) bits)) + (sap-ref-8 sap (+ 2 tail)) (logior #x80 (ldb (byte 6 0) bits)))) (4 (setf (sap-ref-8 sap tail) (logior #xf0 (ldb (byte 3 18) bits)) - (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 12) bits)) - (sap-ref-8 sap (+ 2 tail)) (logior #x80 (ldb (byte 6 6) bits)) - (sap-ref-8 sap (+ 3 tail)) (logior #x80 (ldb (byte 6 0) bits))))) + (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 12) bits)) + (sap-ref-8 sap (+ 2 tail)) (logior #x80 (ldb (byte 6 6) bits)) + (sap-ref-8 sap (+ 3 tail)) (logior #x80 (ldb (byte 6 0) bits))))) (cond ((< byte #x80) 1) - ((< byte #xc2) (return-from decode-break-reason 1)) - ((< byte #xe0) 2) - ((< byte #xf0) 3) - (t 4)) + ((< byte #xc2) (return-from decode-break-reason 1)) + ((< byte #xe0) 2) + ((< byte #xf0) 3) + (t 4)) (code-char (ecase size - (1 byte) - (2 (let ((byte2 (sap-ref-8 sap (1+ head)))) - (unless (<= #x80 byte2 #xbf) - (return-from decode-break-reason 2)) - (dpb byte (byte 5 6) byte2))) - (3 (let ((byte2 (sap-ref-8 sap (1+ head))) - (byte3 (sap-ref-8 sap (+ 2 head)))) - (unless (and (<= #x80 byte2 #xbf) - (<= #x80 byte3 #xbf)) - (return-from decode-break-reason 3)) - (dpb byte (byte 4 12) (dpb byte2 (byte 6 6) byte3)))) - (4 (let ((byte2 (sap-ref-8 sap (1+ head))) - (byte3 (sap-ref-8 sap (+ 2 head))) - (byte4 (sap-ref-8 sap (+ 3 head)))) - (unless (and (<= #x80 byte2 #xbf) - (<= #x80 byte3 #xbf) - (<= #x80 byte4 #xbf)) - (return-from decode-break-reason 4)) - (dpb byte (byte 3 18) - (dpb byte2 (byte 6 12) - (dpb byte3 (byte 6 6) byte4)))))))) + (1 byte) + (2 (let ((byte2 (sap-ref-8 sap (1+ head)))) + (unless (<= #x80 byte2 #xbf) + (return-from decode-break-reason 2)) + (dpb byte (byte 5 6) byte2))) + (3 (let ((byte2 (sap-ref-8 sap (1+ head))) + (byte3 (sap-ref-8 sap (+ 2 head)))) + (unless (and (<= #x80 byte2 #xbf) + (<= #x80 byte3 #xbf)) + (return-from decode-break-reason 3)) + (dpb byte (byte 4 12) (dpb byte2 (byte 6 6) byte3)))) + (4 (let ((byte2 (sap-ref-8 sap (1+ head))) + (byte3 (sap-ref-8 sap (+ 2 head))) + (byte4 (sap-ref-8 sap (+ 3 head)))) + (unless (and (<= #x80 byte2 #xbf) + (<= #x80 byte3 #xbf) + (<= #x80 byte4 #xbf)) + (return-from decode-break-reason 4)) + (dpb byte (byte 3 18) + (dpb byte2 (byte 6 12) + (dpb byte3 (byte 6 6) byte4)))))))) ;;;; utility functions (misc routines, etc) @@ -1328,33 +1328,33 @@ ;;; OUTPUT-P indicate what slots to fill. The buffering slot must be ;;; set prior to calling this routine. (defun set-fd-stream-routines (fd-stream element-type external-format - input-p output-p buffer-p) + input-p output-p buffer-p) (let* ((target-type (case element-type - (unsigned-byte '(unsigned-byte 8)) - (signed-byte '(signed-byte 8)) - (:default 'character) - (t element-type))) - (character-stream-p (subtypep target-type 'character)) - (bivalent-stream-p (eq element-type :default)) - normalized-external-format - (bin-routine #'ill-bin) - (bin-type nil) - (bin-size nil) - (cin-routine #'ill-in) - (cin-type nil) - (cin-size nil) - (input-type nil) ;calculated from bin-type/cin-type - (input-size nil) ;calculated from bin-size/cin-size - (read-n-characters #'ill-in) - (bout-routine #'ill-bout) - (bout-type nil) - (bout-size nil) - (cout-routine #'ill-out) - (cout-type nil) - (cout-size nil) - (output-type nil) - (output-size nil) - (output-bytes #'ill-bout)) + (unsigned-byte '(unsigned-byte 8)) + (signed-byte '(signed-byte 8)) + (:default 'character) + (t element-type))) + (character-stream-p (subtypep target-type 'character)) + (bivalent-stream-p (eq element-type :default)) + normalized-external-format + (bin-routine #'ill-bin) + (bin-type nil) + (bin-size nil) + (cin-routine #'ill-in) + (cin-type nil) + (cin-size nil) + (input-type nil) ;calculated from bin-type/cin-type + (input-size nil) ;calculated from bin-size/cin-size + (read-n-characters #'ill-in) + (bout-routine #'ill-bout) + (bout-type nil) + (bout-size nil) + (cout-routine #'ill-out) + (cout-type nil) + (cout-size nil) + (output-type nil) + (output-size nil) + (output-bytes #'ill-bout)) ;; drop buffers when direction changes (when (and (fd-stream-obuf-sap fd-stream) (not output-p)) @@ -1374,7 +1374,7 @@ (setf (fd-stream-char-pos fd-stream) 0)) (when (and character-stream-p - (eq external-format :default)) + (eq external-format :default)) (/show0 "/getting default external format") (setf external-format (default-external-format)) (/show0 "cold-printing defaulted external-format:") @@ -1382,126 +1382,126 @@ (cold-print external-format) (/show0 "matching to known aliases") (dolist (entry *external-formats* - (restart-case - (error "Invalid external-format ~A" + (restart-case + (error "Invalid external-format ~A" external-format) - (use-default () + (use-default () :report "Set external format to LATIN-1" (setf external-format :latin-1)))) (/show0 "cold printing known aliases:") #!+sb-show (dolist (alias (first entry)) (cold-print alias)) (/show0 "done cold-printing known aliases") - (when (member external-format (first entry)) + (when (member external-format (first entry)) (/show0 "matched") - (return))) + (return))) (/show0 "/default external format ok")) - + (when input-p (when (or (not character-stream-p) bivalent-stream-p) - (multiple-value-setq (bin-routine bin-type bin-size read-n-characters - normalized-external-format) - (pick-input-routine (if bivalent-stream-p '(unsigned-byte 8) - target-type) - external-format)) - (unless bin-routine - (error "could not find any input routine for ~S" target-type))) + (multiple-value-setq (bin-routine bin-type bin-size read-n-characters + normalized-external-format) + (pick-input-routine (if bivalent-stream-p '(unsigned-byte 8) + target-type) + external-format)) + (unless bin-routine + (error "could not find any input routine for ~S" target-type))) (when character-stream-p - (multiple-value-setq (cin-routine cin-type cin-size read-n-characters - normalized-external-format) - (pick-input-routine target-type external-format)) - (unless cin-routine - (error "could not find any input routine for ~S" target-type))) + (multiple-value-setq (cin-routine cin-type cin-size read-n-characters + normalized-external-format) + (pick-input-routine target-type external-format)) + (unless cin-routine + (error "could not find any input routine for ~S" target-type))) (setf (fd-stream-in fd-stream) cin-routine - (fd-stream-bin fd-stream) bin-routine) + (fd-stream-bin fd-stream) bin-routine) ;; character type gets preferential treatment (setf input-size (or cin-size bin-size)) (setf input-type (or cin-type bin-type)) (when normalized-external-format - (setf (fd-stream-external-format fd-stream) - normalized-external-format)) + (setf (fd-stream-external-format fd-stream) + normalized-external-format)) (when (= (or cin-size 1) (or bin-size 1) 1) - (setf (fd-stream-n-bin fd-stream) ;XXX - (if (and character-stream-p (not bivalent-stream-p)) - read-n-characters - #'fd-stream-read-n-bytes)) - ;; Sometimes turn on fast-read-char/fast-read-byte. Switch on - ;; for character and (unsigned-byte 8) streams. In these - ;; cases, fast-read-* will read from the - ;; ansi-stream-(c)in-buffer, saving function calls. - ;; Otherwise, the various data-reading functions in the stream - ;; structure will be called. - (when (and buffer-p - (not bivalent-stream-p) - ;; temporary disable on :io streams - (not output-p)) - (cond (character-stream-p - (setf (ansi-stream-cin-buffer fd-stream) - (make-array +ansi-stream-in-buffer-length+ - :element-type 'character))) - ((equal target-type '(unsigned-byte 8)) - (setf (ansi-stream-in-buffer fd-stream) - (make-array +ansi-stream-in-buffer-length+ - :element-type '(unsigned-byte 8)))))))) + (setf (fd-stream-n-bin fd-stream) ;XXX + (if (and character-stream-p (not bivalent-stream-p)) + read-n-characters + #'fd-stream-read-n-bytes)) + ;; Sometimes turn on fast-read-char/fast-read-byte. Switch on + ;; for character and (unsigned-byte 8) streams. In these + ;; cases, fast-read-* will read from the + ;; ansi-stream-(c)in-buffer, saving function calls. + ;; Otherwise, the various data-reading functions in the stream + ;; structure will be called. + (when (and buffer-p + (not bivalent-stream-p) + ;; temporary disable on :io streams + (not output-p)) + (cond (character-stream-p + (setf (ansi-stream-cin-buffer fd-stream) + (make-array +ansi-stream-in-buffer-length+ + :element-type 'character))) + ((equal target-type '(unsigned-byte 8)) + (setf (ansi-stream-in-buffer fd-stream) + (make-array +ansi-stream-in-buffer-length+ + :element-type '(unsigned-byte 8)))))))) (when output-p (when (or (not character-stream-p) bivalent-stream-p) - (multiple-value-setq (bout-routine bout-type bout-size output-bytes - normalized-external-format) - (pick-output-routine (if bivalent-stream-p - '(unsigned-byte 8) - target-type) - (fd-stream-buffering fd-stream) - external-format)) - (unless bout-routine - (error "could not find any output routine for ~S buffered ~S" - (fd-stream-buffering fd-stream) - target-type))) + (multiple-value-setq (bout-routine bout-type bout-size output-bytes + normalized-external-format) + (pick-output-routine (if bivalent-stream-p + '(unsigned-byte 8) + target-type) + (fd-stream-buffering fd-stream) + external-format)) + (unless bout-routine + (error "could not find any output routine for ~S buffered ~S" + (fd-stream-buffering fd-stream) + target-type))) (when character-stream-p - (multiple-value-setq (cout-routine cout-type cout-size output-bytes - normalized-external-format) - (pick-output-routine target-type - (fd-stream-buffering fd-stream) - external-format)) - (unless cout-routine - (error "could not find any output routine for ~S buffered ~S" - (fd-stream-buffering fd-stream) - target-type))) + (multiple-value-setq (cout-routine cout-type cout-size output-bytes + normalized-external-format) + (pick-output-routine target-type + (fd-stream-buffering fd-stream) + external-format)) + (unless cout-routine + (error "could not find any output routine for ~S buffered ~S" + (fd-stream-buffering fd-stream) + target-type))) (when normalized-external-format - (setf (fd-stream-external-format fd-stream) - normalized-external-format)) + (setf (fd-stream-external-format fd-stream) + normalized-external-format)) (when character-stream-p - (setf (fd-stream-output-bytes fd-stream) output-bytes)) + (setf (fd-stream-output-bytes fd-stream) output-bytes)) (setf (fd-stream-out fd-stream) cout-routine - (fd-stream-bout fd-stream) bout-routine - (fd-stream-sout fd-stream) (if (eql cout-size 1) - #'fd-sout #'ill-out)) + (fd-stream-bout fd-stream) bout-routine + (fd-stream-sout fd-stream) (if (eql cout-size 1) + #'fd-sout #'ill-out)) (setf output-size (or cout-size bout-size)) (setf output-type (or cout-type bout-type))) (when (and input-size output-size - (not (eq input-size output-size))) + (not (eq input-size output-size))) (error "Element sizes for input (~S:~S) and output (~S:~S) differ?" - input-type input-size - output-type output-size)) + input-type input-size + output-type output-size)) (setf (fd-stream-element-size fd-stream) - (or input-size output-size)) + (or input-size output-size)) (setf (fd-stream-element-type fd-stream) - (cond ((equal input-type output-type) - input-type) - ((null output-type) - input-type) - ((null input-type) - output-type) - ((subtypep input-type output-type) - input-type) - ((subtypep output-type input-type) - output-type) - (t - (error "Input type (~S) and output type (~S) are unrelated?" - input-type - output-type)))))) + (cond ((equal input-type output-type) + input-type) + ((null output-type) + input-type) + ((null input-type) + output-type) + ((subtypep input-type output-type) + input-type) + ((subtypep output-type input-type) + output-type) + (t + (error "Input type (~S) and output type (~S) are unrelated?" + input-type + output-type)))))) ;;; Handle miscellaneous operations on FD-STREAM. (defun fd-stream-misc-routine (fd-stream operation &optional arg1 arg2) @@ -1509,10 +1509,10 @@ (case operation (:listen (or (not (eql (fd-stream-ibuf-head fd-stream) - (fd-stream-ibuf-tail fd-stream))) - (fd-stream-listen fd-stream) - (setf (fd-stream-listen fd-stream) - (eql (sb!unix:with-restarted-syscall () + (fd-stream-ibuf-tail fd-stream))) + (fd-stream-listen fd-stream) + (setf (fd-stream-listen fd-stream) + (eql (sb!unix:with-restarted-syscall () (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))) (sb!unix:fd-zero read-fds) @@ -1520,70 +1520,70 @@ (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream)) (sb!alien:addr read-fds) nil nil 0 0))) - 1)))) + 1)))) (:unread (setf (fd-stream-unread fd-stream) arg1) (setf (fd-stream-listen fd-stream) t)) (:close (cond (arg1 ; We got us an abort on our hands. - (when (fd-stream-handler fd-stream) - (sb!sys:remove-fd-handler (fd-stream-handler fd-stream)) - (setf (fd-stream-handler fd-stream) nil)) - ;; We can't do anything unless we know what file were - ;; dealing with, and we don't want to do anything - ;; strange unless we were writing to the file. - (when (and (fd-stream-file fd-stream) - (fd-stream-obuf-sap fd-stream)) - (if (fd-stream-original fd-stream) - ;; If the original is EQ to file we are appending - ;; and can just close the file without renaming. - (unless (eq (fd-stream-original fd-stream) - (fd-stream-file fd-stream)) - ;; We have a handle on the original, just revert. - (multiple-value-bind (okay err) - (sb!unix:unix-rename (fd-stream-original fd-stream) - (fd-stream-file fd-stream)) - (unless okay - (simple-stream-perror - "couldn't restore ~S to its original contents" - fd-stream - err)))) - ;; We can't restore the original, and aren't - ;; appending, so nuke that puppy. - ;; - ;; FIXME: This is currently the fate of superseded - ;; files, and according to the CLOSE spec this is - ;; wrong. However, there seems to be no clean way to - ;; do that that doesn't involve either copying the - ;; data (bad if the :abort resulted from a full - ;; disk), or renaming the old file temporarily - ;; (probably bad because stream opening becomes more - ;; racy). - (multiple-value-bind (okay err) - (sb!unix:unix-unlink (fd-stream-file fd-stream)) - (unless okay - (error 'simple-file-error - :pathname (fd-stream-file fd-stream) - :format-control - "~@" - :format-arguments (list (fd-stream-file fd-stream) - (strerror err)))))))) - (t - (fd-stream-misc-routine fd-stream :finish-output) - (when (and (fd-stream-original fd-stream) - (fd-stream-delete-original fd-stream)) - (multiple-value-bind (okay err) - (sb!unix:unix-unlink (fd-stream-original fd-stream)) - (unless okay - (error 'simple-file-error - :pathname (fd-stream-original fd-stream) - :format-control - "~@" + :format-arguments (list (fd-stream-file fd-stream) + (strerror err)))))))) + (t + (fd-stream-misc-routine fd-stream :finish-output) + (when (and (fd-stream-original fd-stream) + (fd-stream-delete-original fd-stream)) + (multiple-value-bind (okay err) + (sb!unix:unix-unlink (fd-stream-original fd-stream)) + (unless okay + (error 'simple-file-error + :pathname (fd-stream-original fd-stream) + :format-control + "~@" - :format-arguments - (list (fd-stream-original fd-stream) - fd-stream - (strerror err)))))))) + :format-arguments + (list (fd-stream-original fd-stream) + fd-stream + (strerror err)))))))) (when (fboundp 'cancel-finalization) (cancel-finalization fd-stream)) (sb!unix:unix-close (fd-stream-fd fd-stream)) @@ -1600,7 +1600,7 @@ (setf (fd-stream-ibuf-tail fd-stream) 0) (catch 'eof-input-catcher (loop - (let ((count (sb!unix:with-restarted-syscall () + (let ((count (sb!unix:with-restarted-syscall () (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))) (sb!unix:fd-zero read-fds) @@ -1608,18 +1608,18 @@ (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream)) (sb!alien:addr read-fds) nil nil 0 0))))) - (cond ((eql count 1) - (refill-buffer/fd fd-stream) - (setf (fd-stream-ibuf-head fd-stream) 0) - (setf (fd-stream-ibuf-tail fd-stream) 0)) - (t - (return t))))))) + (cond ((eql count 1) + (refill-buffer/fd fd-stream) + (setf (fd-stream-ibuf-head fd-stream) 0) + (setf (fd-stream-ibuf-tail fd-stream) 0)) + (t + (return t))))))) (:force-output (flush-output-buffer fd-stream)) (:finish-output (flush-output-buffer fd-stream) (do () - ((null (fd-stream-output-later fd-stream))) + ((null (fd-stream-output-later fd-stream))) (sb!sys:serve-all-events))) (:element-type (fd-stream-element-type fd-stream)) @@ -1644,17 +1644,17 @@ :format-control "~S is not a stream associated with a file." :format-arguments (list fd-stream))) (multiple-value-bind (okay dev ino mode nlink uid gid rdev size - atime mtime ctime blksize blocks) - (sb!unix:unix-fstat (fd-stream-fd fd-stream)) + atime mtime ctime blksize blocks) + (sb!unix:unix-fstat (fd-stream-fd fd-stream)) (declare (ignore ino nlink uid gid rdev - atime mtime ctime blksize blocks)) + atime mtime ctime blksize blocks)) (unless okay - (simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev)) + (simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev)) (if (zerop mode) - nil - (truncate size (fd-stream-element-size fd-stream))))) + nil + (truncate size (fd-stream-element-size fd-stream))))) ;; FIXME: I doubt this is correct in the presence of Unicode, - ;; since fd-stream FILE-POSITION is measured in bytes. + ;; since fd-stream FILE-POSITION is measured in bytes. (:file-string-length (etypecase arg1 (character 1) @@ -1664,77 +1664,77 @@ (defun fd-stream-file-position (stream &optional newpos) (declare (type fd-stream stream) - (type (or (alien sb!unix:off-t) (member nil :start :end)) newpos)) + (type (or (alien sb!unix:off-t) (member nil :start :end)) newpos)) (if (null newpos) (sb!sys:without-interrupts - ;; First, find the position of the UNIX file descriptor in the file. - (multiple-value-bind (posn errno) - (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr) - (declare (type (or (alien sb!unix:off-t) null) posn)) - (cond ((integerp posn) - ;; Adjust for buffered output: If there is any output - ;; buffered, the *real* file position will be larger - ;; than reported by lseek() because lseek() obviously - ;; cannot take into account output we have not sent - ;; yet. - (dolist (later (fd-stream-output-later stream)) - (incf posn (- (caddr later) - (cadr later)))) - (incf posn (fd-stream-obuf-tail stream)) - ;; Adjust for unread input: If there is any input - ;; read from UNIX but not supplied to the user of the - ;; stream, the *real* file position will smaller than - ;; reported, because we want to look like the unread - ;; stuff is still available. - (decf posn (- (fd-stream-ibuf-tail stream) - (fd-stream-ibuf-head stream))) - (when (fd-stream-unread stream) - (decf posn)) - ;; Divide bytes by element size. - (truncate posn (fd-stream-element-size stream))) - ((eq errno sb!unix:espipe) - nil) - (t - (sb!sys:with-interrupts - (simple-stream-perror "failure in Unix lseek() on ~S" - stream - errno)))))) + ;; First, find the position of the UNIX file descriptor in the file. + (multiple-value-bind (posn errno) + (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr) + (declare (type (or (alien sb!unix:off-t) null) posn)) + (cond ((integerp posn) + ;; Adjust for buffered output: If there is any output + ;; buffered, the *real* file position will be larger + ;; than reported by lseek() because lseek() obviously + ;; cannot take into account output we have not sent + ;; yet. + (dolist (later (fd-stream-output-later stream)) + (incf posn (- (caddr later) + (cadr later)))) + (incf posn (fd-stream-obuf-tail stream)) + ;; Adjust for unread input: If there is any input + ;; read from UNIX but not supplied to the user of the + ;; stream, the *real* file position will smaller than + ;; reported, because we want to look like the unread + ;; stuff is still available. + (decf posn (- (fd-stream-ibuf-tail stream) + (fd-stream-ibuf-head stream))) + (when (fd-stream-unread stream) + (decf posn)) + ;; Divide bytes by element size. + (truncate posn (fd-stream-element-size stream))) + ((eq errno sb!unix:espipe) + nil) + (t + (sb!sys:with-interrupts + (simple-stream-perror "failure in Unix lseek() on ~S" + stream + errno)))))) (let ((offset 0) origin) - (declare (type (alien sb!unix:off-t) offset)) - ;; Make sure we don't have any output pending, because if we - ;; move the file pointer before writing this stuff, it will be - ;; written in the wrong location. - (flush-output-buffer stream) - (do () - ((null (fd-stream-output-later stream))) - (sb!sys:serve-all-events)) - ;; Clear out any pending input to force the next read to go to - ;; the disk. - (setf (fd-stream-unread stream) nil) - (setf (fd-stream-ibuf-head stream) 0) - (setf (fd-stream-ibuf-tail stream) 0) - ;; Trash cached value for listen, so that we check next time. - (setf (fd-stream-listen stream) nil) - ;; Now move it. - (cond ((eq newpos :start) - (setf offset 0 origin sb!unix:l_set)) - ((eq newpos :end) - (setf offset 0 origin sb!unix:l_xtnd)) - ((typep newpos '(alien sb!unix:off-t)) - (setf offset (* newpos (fd-stream-element-size stream)) - origin sb!unix:l_set)) - (t - (error "invalid position given to FILE-POSITION: ~S" newpos))) - (multiple-value-bind (posn errno) - (sb!unix:unix-lseek (fd-stream-fd stream) offset origin) - (cond ((typep posn '(alien sb!unix:off-t)) - t) - ((eq errno sb!unix:espipe) - nil) - (t - (simple-stream-perror "error in Unix lseek() on ~S" - stream - errno))))))) + (declare (type (alien sb!unix:off-t) offset)) + ;; Make sure we don't have any output pending, because if we + ;; move the file pointer before writing this stuff, it will be + ;; written in the wrong location. + (flush-output-buffer stream) + (do () + ((null (fd-stream-output-later stream))) + (sb!sys:serve-all-events)) + ;; Clear out any pending input to force the next read to go to + ;; the disk. + (setf (fd-stream-unread stream) nil) + (setf (fd-stream-ibuf-head stream) 0) + (setf (fd-stream-ibuf-tail stream) 0) + ;; Trash cached value for listen, so that we check next time. + (setf (fd-stream-listen stream) nil) + ;; Now move it. + (cond ((eq newpos :start) + (setf offset 0 origin sb!unix:l_set)) + ((eq newpos :end) + (setf offset 0 origin sb!unix:l_xtnd)) + ((typep newpos '(alien sb!unix:off-t)) + (setf offset (* newpos (fd-stream-element-size stream)) + origin sb!unix:l_set)) + (t + (error "invalid position given to FILE-POSITION: ~S" newpos))) + (multiple-value-bind (posn errno) + (sb!unix:unix-lseek (fd-stream-fd stream) offset origin) + (cond ((typep posn '(alien sb!unix:off-t)) + t) + ((eq errno sb!unix:espipe) + nil) + (t + (simple-stream-perror "error in Unix lseek() on ~S" + stream + errno))))))) ;;;; creation routines (MAKE-FD-STREAM and OPEN) @@ -1756,48 +1756,48 @@ ;;; ;;; NAME is used to identify the stream when printed. (defun make-fd-stream (fd - &key - (input nil input-p) - (output nil output-p) - (element-type 'base-char) - (buffering :full) - (external-format :default) - timeout - file - original - delete-original - pathname - input-buffer-p - dual-channel-p - (name (if file - (format nil "file ~A" file) - (format nil "descriptor ~W" fd))) - auto-close) + &key + (input nil input-p) + (output nil output-p) + (element-type 'base-char) + (buffering :full) + (external-format :default) + timeout + file + original + delete-original + pathname + input-buffer-p + dual-channel-p + (name (if file + (format nil "file ~A" file) + (format nil "descriptor ~W" fd))) + auto-close) (declare (type index fd) (type (or index null) timeout) - (type (member :none :line :full) buffering)) + (type (member :none :line :full) buffering)) (cond ((not (or input-p output-p)) - (setf input t)) - ((not (or input output)) - (error "File descriptor must be opened either for input or output."))) + (setf input t)) + ((not (or input output)) + (error "File descriptor must be opened either for input or output."))) (let ((stream (%make-fd-stream :fd fd - :name name - :file file - :original original - :delete-original delete-original - :pathname pathname - :buffering buffering - :dual-channel-p dual-channel-p - :external-format external-format - :timeout timeout))) + :name name + :file file + :original original + :delete-original delete-original + :pathname pathname + :buffering buffering + :dual-channel-p dual-channel-p + :external-format external-format + :timeout timeout))) (set-fd-stream-routines stream element-type external-format - input output input-buffer-p) + input output input-buffer-p) (when (and auto-close (fboundp 'finalize)) (finalize stream - (lambda () - (sb!unix:unix-close fd) - #!+sb-show - (format *terminal-io* "** closed file descriptor ~W **~%" - fd)))) + (lambda () + (sb!unix:unix-close fd) + #!+sb-show + (format *terminal-io* "** closed file descriptor ~W **~%" + fd)))) stream)) ;;; Pick a name to use for the backup file for the :IF-EXISTS @@ -1811,10 +1811,10 @@ (defun ensure-one-of (item list what) (unless (member item list) (error 'simple-type-error - :datum item - :expected-type `(member ,@list) - :format-control "~@<~S is ~_invalid for ~S; ~_need one of~{ ~S~}~:>" - :format-arguments (list item what list)))) + :datum item + :expected-type `(member ,@list) + :format-control "~@<~S is ~_invalid for ~S; ~_need one of~{ ~S~}~:>" + :format-arguments (list item what list)))) ;;; Rename NAMESTRING to ORIGINAL. First, check whether we have write ;;; access, since we don't want to trash unwritable files even if we @@ -1824,24 +1824,24 @@ (error "~@" namestring)) (multiple-value-bind (okay err) (sb!unix:unix-rename namestring original) (if okay - t - (error 'simple-file-error - :pathname namestring - :format-control - "~@" - :format-arguments (list namestring original (strerror err)))))) + t + (error 'simple-file-error + :pathname namestring + :format-control + "~@" + :format-arguments (list namestring original (strerror err)))))) (defun open (filename - &key - (direction :input) - (element-type 'base-char) - (if-exists nil if-exists-given) - (if-does-not-exist nil if-does-not-exist-given) - (external-format :default) - &aux ; Squelch assignment warning. - (direction direction) - (if-does-not-exist if-does-not-exist) - (if-exists if-exists)) + &key + (direction :input) + (element-type 'base-char) + (if-exists nil if-exists-given) + (if-does-not-exist nil if-does-not-exist-given) + (external-format :default) + &aux ; Squelch assignment warning. + (direction direction) + (if-does-not-exist if-does-not-exist) + (if-exists if-exists)) #!+sb-doc "Return a stream which reads from or writes to FILENAME. Defined keywords: @@ -1855,154 +1855,154 @@ ;; Calculate useful stuff. (multiple-value-bind (input output mask) (case direction - (:input (values t nil sb!unix:o_rdonly)) - (:output (values nil t sb!unix:o_wronly)) - (:io (values t t sb!unix:o_rdwr)) - (:probe (values t nil sb!unix:o_rdonly))) + (:input (values t nil sb!unix:o_rdonly)) + (:output (values nil t sb!unix:o_wronly)) + (:io (values t t sb!unix:o_rdwr)) + (:probe (values t nil sb!unix:o_rdonly))) (declare (type index mask)) (let* ((pathname (merge-pathnames filename)) - (namestring - (cond ((unix-namestring pathname input)) - ((and input (eq if-does-not-exist :create)) - (unix-namestring pathname nil)) - ((and (eq direction :io) (not if-does-not-exist-given)) - (unix-namestring pathname nil))))) + (namestring + (cond ((unix-namestring pathname input)) + ((and input (eq if-does-not-exist :create)) + (unix-namestring pathname nil)) + ((and (eq direction :io) (not if-does-not-exist-given)) + (unix-namestring pathname nil))))) ;; Process if-exists argument if we are doing any output. (cond (output - (unless if-exists-given - (setf if-exists - (if (eq (pathname-version pathname) :newest) - :new-version - :error))) - (ensure-one-of if-exists - '(:error :new-version :rename - :rename-and-delete :overwrite - :append :supersede nil) - :if-exists) - (case if-exists - ((:new-version :error nil) - (setf mask (logior mask sb!unix:o_excl))) - ((:rename :rename-and-delete) - (setf mask (logior mask sb!unix:o_creat))) - ((:supersede) - (setf mask (logior mask sb!unix:o_trunc))) - (:append - (setf mask (logior mask sb!unix:o_append))))) - (t - (setf if-exists :ignore-this-arg))) + (unless if-exists-given + (setf if-exists + (if (eq (pathname-version pathname) :newest) + :new-version + :error))) + (ensure-one-of if-exists + '(:error :new-version :rename + :rename-and-delete :overwrite + :append :supersede nil) + :if-exists) + (case if-exists + ((:new-version :error nil) + (setf mask (logior mask sb!unix:o_excl))) + ((:rename :rename-and-delete) + (setf mask (logior mask sb!unix:o_creat))) + ((:supersede) + (setf mask (logior mask sb!unix:o_trunc))) + (:append + (setf mask (logior mask sb!unix:o_append))))) + (t + (setf if-exists :ignore-this-arg))) (unless if-does-not-exist-given - (setf if-does-not-exist - (cond ((eq direction :input) :error) - ((and output - (member if-exists '(:overwrite :append))) - :error) - ((eq direction :probe) - nil) - (t - :create)))) + (setf if-does-not-exist + (cond ((eq direction :input) :error) + ((and output + (member if-exists '(:overwrite :append))) + :error) + ((eq direction :probe) + nil) + (t + :create)))) (ensure-one-of if-does-not-exist - '(:error :create nil) - :if-does-not-exist) + '(:error :create nil) + :if-does-not-exist) (if (eq if-does-not-exist :create) - (setf mask (logior mask sb!unix:o_creat))) + (setf mask (logior mask sb!unix:o_creat))) (let ((original (case if-exists - ((:rename :rename-and-delete) - (pick-backup-name namestring)) - ((:append :overwrite) - ;; KLUDGE: Provent CLOSE from deleting - ;; appending streams when called with :ABORT T - namestring))) - (delete-original (eq if-exists :rename-and-delete)) - (mode #o666)) - (when (and original (not (eq original namestring))) - ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine - ;; whether the file already exists, make sure the original - ;; file is not a directory, and keep the mode. - (let ((exists - (and namestring - (multiple-value-bind (okay err/dev inode orig-mode) - (sb!unix:unix-stat namestring) - (declare (ignore inode) - (type (or index null) orig-mode)) - (cond - (okay - (when (and output (= (logand orig-mode #o170000) - #o40000)) - (error 'simple-file-error - :pathname namestring - :format-control - "can't open ~S for output: is a directory" - :format-arguments (list namestring))) - (setf mode (logand orig-mode #o777)) - t) - ((eql err/dev sb!unix:enoent) - nil) - (t - (simple-file-perror "can't find ~S" - namestring - err/dev))))))) - (unless (and exists - (rename-the-old-one namestring original)) - (setf original nil) - (setf delete-original nil) - ;; In order to use :SUPERSEDE instead, we have to make - ;; sure SB!UNIX:O_CREAT corresponds to - ;; IF-DOES-NOT-EXIST. SB!UNIX:O_CREAT was set before - ;; because of IF-EXISTS being :RENAME. - (unless (eq if-does-not-exist :create) - (setf mask - (logior (logandc2 mask sb!unix:o_creat) - sb!unix:o_trunc))) - (setf if-exists :supersede)))) - - ;; Now we can try the actual Unix open(2). - (multiple-value-bind (fd errno) - (if namestring - (sb!unix:unix-open namestring mask mode) - (values nil sb!unix:enoent)) - (labels ((open-error (format-control &rest format-arguments) - (error 'simple-file-error - :pathname pathname - :format-control format-control - :format-arguments format-arguments)) - (vanilla-open-error () - (simple-file-perror "error opening ~S" pathname errno))) - (cond ((numberp fd) - (case direction - ((:input :output :io) - (make-fd-stream fd - :input input - :output output - :element-type element-type - :external-format external-format - :file namestring - :original original - :delete-original delete-original - :pathname pathname - :dual-channel-p nil - :input-buffer-p t - :auto-close t)) - (:probe - (let ((stream - (%make-fd-stream :name namestring - :fd fd - :pathname pathname - :element-type element-type))) - (close stream) - stream)))) - ((eql errno sb!unix:enoent) - (case if-does-not-exist - (:error (vanilla-open-error)) - (:create - (open-error "~@" - pathname)) - (t nil))) - ((and (eql errno sb!unix:eexist) (null if-exists)) - nil) - (t - (vanilla-open-error))))))))) + ((:rename :rename-and-delete) + (pick-backup-name namestring)) + ((:append :overwrite) + ;; KLUDGE: Provent CLOSE from deleting + ;; appending streams when called with :ABORT T + namestring))) + (delete-original (eq if-exists :rename-and-delete)) + (mode #o666)) + (when (and original (not (eq original namestring))) + ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine + ;; whether the file already exists, make sure the original + ;; file is not a directory, and keep the mode. + (let ((exists + (and namestring + (multiple-value-bind (okay err/dev inode orig-mode) + (sb!unix:unix-stat namestring) + (declare (ignore inode) + (type (or index null) orig-mode)) + (cond + (okay + (when (and output (= (logand orig-mode #o170000) + #o40000)) + (error 'simple-file-error + :pathname namestring + :format-control + "can't open ~S for output: is a directory" + :format-arguments (list namestring))) + (setf mode (logand orig-mode #o777)) + t) + ((eql err/dev sb!unix:enoent) + nil) + (t + (simple-file-perror "can't find ~S" + namestring + err/dev))))))) + (unless (and exists + (rename-the-old-one namestring original)) + (setf original nil) + (setf delete-original nil) + ;; In order to use :SUPERSEDE instead, we have to make + ;; sure SB!UNIX:O_CREAT corresponds to + ;; IF-DOES-NOT-EXIST. SB!UNIX:O_CREAT was set before + ;; because of IF-EXISTS being :RENAME. + (unless (eq if-does-not-exist :create) + (setf mask + (logior (logandc2 mask sb!unix:o_creat) + sb!unix:o_trunc))) + (setf if-exists :supersede)))) + + ;; Now we can try the actual Unix open(2). + (multiple-value-bind (fd errno) + (if namestring + (sb!unix:unix-open namestring mask mode) + (values nil sb!unix:enoent)) + (labels ((open-error (format-control &rest format-arguments) + (error 'simple-file-error + :pathname pathname + :format-control format-control + :format-arguments format-arguments)) + (vanilla-open-error () + (simple-file-perror "error opening ~S" pathname errno))) + (cond ((numberp fd) + (case direction + ((:input :output :io) + (make-fd-stream fd + :input input + :output output + :element-type element-type + :external-format external-format + :file namestring + :original original + :delete-original delete-original + :pathname pathname + :dual-channel-p nil + :input-buffer-p t + :auto-close t)) + (:probe + (let ((stream + (%make-fd-stream :name namestring + :fd fd + :pathname pathname + :element-type element-type))) + (close stream) + stream)))) + ((eql errno sb!unix:enoent) + (case if-does-not-exist + (:error (vanilla-open-error)) + (:create + (open-error "~@" + pathname)) + (t nil))) + ((and (eql errno sb!unix:eexist) (null if-exists)) + nil) + (t + (vanilla-open-error))))))))) ;;;; initialization @@ -2035,22 +2035,22 @@ (defun stream-reinit () (setf *available-buffers* nil) (setf *stdin* - (make-fd-stream 0 :name "standard input" :input t :buffering :line)) + (make-fd-stream 0 :name "standard input" :input t :buffering :line)) (setf *stdout* - (make-fd-stream 1 :name "standard output" :output t :buffering :line)) + (make-fd-stream 1 :name "standard output" :output t :buffering :line)) (setf *stderr* - (make-fd-stream 2 :name "standard error" :output t :buffering :line)) + (make-fd-stream 2 :name "standard error" :output t :buffering :line)) (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string)) - (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666))) + (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666))) (if tty - (setf *tty* - (make-fd-stream tty - :name "the terminal" - :input t - :output t - :buffering :line - :auto-close t)) - (setf *tty* (make-two-way-stream *stdin* *stdout*)))) + (setf *tty* + (make-fd-stream tty + :name "the terminal" + :input t + :output t + :buffering :line + :auto-close t)) + (setf *tty* (make-two-way-stream *stdin* *stdout*)))) (values)) ;;;; miscellany @@ -2067,9 +2067,9 @@ (defun file-name (stream &optional new-name) (when (typep stream 'fd-stream) (cond (new-name - (setf (fd-stream-pathname stream) new-name) - (setf (fd-stream-file stream) - (unix-namestring new-name nil)) - t) - (t - (fd-stream-pathname stream))))) + (setf (fd-stream-pathname stream) new-name) + (setf (fd-stream-file stream) + (unix-namestring new-name nil)) + t) + (t + (fd-stream-pathname stream))))) diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index 59ca173..f4bd831 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -27,13 +27,13 @@ (defun fdefn-fun (fdefn) (declare (type fdefn fdefn) - (values (or function null))) + (values (or function null))) (fdefn-fun fdefn)) (defun (setf fdefn-fun) (fun fdefn) (declare (type function fun) - (type fdefn fdefn) - (values function)) + (type fdefn fdefn) + (values function)) (setf (fdefn-fun fdefn) fun)) (defun fdefn-makunbound (fdefn) @@ -57,17 +57,17 @@ (legal-fun-name-or-type-error name) (let ((fdefn (info :function :definition name))) (if (and (null fdefn) create) - (setf (info :function :definition name) (make-fdefn name)) - fdefn))) + (setf (info :function :definition name) (make-fdefn name)) + fdefn))) ;;; Return the fdefinition of NAME, including any encapsulations. -;;; The compiler emits calls to this when someone tries to FUNCALL +;;; The compiler emits calls to this when someone tries to FUNCALL ;;; something. SETFable. #!-sb-fluid (declaim (inline %coerce-name-to-fun)) (defun %coerce-name-to-fun (name) (let ((fdefn (fdefinition-object name nil))) (or (and fdefn (fdefn-fun fdefn)) - (error 'undefined-function :name name)))) + (error 'undefined-function :name name)))) (defun (setf %coerce-name-to-fun) (function name) (let ((fdefn (fdefinition-object name t))) (setf (fdefn-fun fdefn) function))) @@ -80,8 +80,8 @@ ;;;; definition encapsulation (defstruct (encapsulation-info (:constructor make-encapsulation-info - (type definition)) - (:copier nil)) + (type definition)) + (:copier nil)) ;; This is definition's encapsulation type. The encapsulated ;; definition is in the previous ENCAPSULATION-INFO element or ;; installed as the global definition of some function name. @@ -112,11 +112,11 @@ ;; an encapsulation that no longer exists. (let ((info (make-encapsulation-info type (fdefn-fun fdefn)))) (setf (fdefn-fun fdefn) - (named-lambda encapsulation (&rest arg-list) - (declare (special arg-list)) - (let ((basic-definition (encapsulation-info-definition info))) - (declare (special basic-definition)) - (eval body))))))) + (named-lambda encapsulation (&rest arg-list) + (declare (special arg-list)) + (let ((basic-definition (encapsulation-info-definition info))) + (declare (special basic-definition)) + (eval body))))))) ;;; This is like FIND-IF, except that we do it on a compiled closure's ;;; environment. @@ -125,7 +125,7 @@ (dotimes (index (1- (get-closure-length fun))) (let ((elt (%closure-index-ref fun index))) (when (funcall test elt) - (return elt))))) + (return elt))))) ;;; Find the encapsulation info that has been closed over. (defun encapsulation-info (fun) @@ -148,41 +148,41 @@ #!+sb-doc "Removes NAME's most recent encapsulation of the specified TYPE." (let* ((fdefn (fdefinition-object name nil)) - (encap-info (encapsulation-info (fdefn-fun fdefn)))) + (encap-info (encapsulation-info (fdefn-fun fdefn)))) (declare (type (or encapsulation-info null) encap-info)) (cond ((not encap-info) - ;; It disappeared on us, so don't worry about it. - ) - ((eq (encapsulation-info-type encap-info) type) - ;; It's the first one, so change the fdefn object. - (setf (fdefn-fun fdefn) - (encapsulation-info-definition encap-info))) - (t - ;; It must be an interior one, so find it. - (loop - (let ((next-info (encapsulation-info - (encapsulation-info-definition encap-info)))) - (unless next-info - ;; Not there, so don't worry about it. - (return)) - (when (eq (encapsulation-info-type next-info) type) - ;; This is it, so unlink us. - (setf (encapsulation-info-definition encap-info) - (encapsulation-info-definition next-info)) - (return)) - (setf encap-info next-info)))))) + ;; It disappeared on us, so don't worry about it. + ) + ((eq (encapsulation-info-type encap-info) type) + ;; It's the first one, so change the fdefn object. + (setf (fdefn-fun fdefn) + (encapsulation-info-definition encap-info))) + (t + ;; It must be an interior one, so find it. + (loop + (let ((next-info (encapsulation-info + (encapsulation-info-definition encap-info)))) + (unless next-info + ;; Not there, so don't worry about it. + (return)) + (when (eq (encapsulation-info-type next-info) type) + ;; This is it, so unlink us. + (setf (encapsulation-info-definition encap-info) + (encapsulation-info-definition next-info)) + (return)) + (setf encap-info next-info)))))) t) ;;; Does NAME have an encapsulation of the given TYPE? (defun encapsulated-p (name type) (let ((fdefn (fdefinition-object name nil))) (do ((encap-info (encapsulation-info (fdefn-fun fdefn)) - (encapsulation-info - (encapsulation-info-definition encap-info)))) - ((null encap-info) nil) + (encapsulation-info + (encapsulation-info-definition encap-info)))) + ((null encap-info) nil) (declare (type (or encapsulation-info null) encap-info)) (when (eq (encapsulation-info-type encap-info) type) - (return t))))) + (return t))))) ;;;; FDEFINITION @@ -222,8 +222,8 @@ (loop (let ((encap-info (encapsulation-info fun))) (if encap-info - (setf fun (encapsulation-info-definition encap-info)) - (return fun)))))) + (setf fun (encapsulation-info-definition encap-info)) + (return fun)))))) (defvar *setf-fdefinition-hook* nil #!+sb-doc @@ -239,23 +239,23 @@ ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running ;; top level forms in the kernel core startup. (when (boundp '*setf-fdefinition-hook*) - (dolist (f *setf-fdefinition-hook*) - (declare (type function f)) - (funcall f name new-value))) - + (dolist (f *setf-fdefinition-hook*) + (declare (type function f)) + (funcall f name new-value))) + (let ((encap-info (encapsulation-info (fdefn-fun fdefn)))) - (cond (encap-info - (loop - (let ((more-info - (encapsulation-info - (encapsulation-info-definition encap-info)))) - (if more-info - (setf encap-info more-info) - (return - (setf (encapsulation-info-definition encap-info) - new-value)))))) - (t - (setf (fdefn-fun fdefn) new-value))))))) + (cond (encap-info + (loop + (let ((more-info + (encapsulation-info + (encapsulation-info-definition encap-info)))) + (if more-info + (setf encap-info more-info) + (return + (setf (encapsulation-info-definition encap-info) + new-value)))))) + (t + (setf (fdefn-fun fdefn) new-value))))))) ;;;; FBOUNDP and FMAKUNBOUND @@ -268,10 +268,10 @@ (defun fmakunbound (name) #!+sb-doc "Make NAME have no global function definition." - (with-single-package-locked-error + (with-single-package-locked-error (:symbol name "removing the function or macro definition of ~A") (let ((fdefn (fdefinition-object name nil))) (when fdefn - (fdefn-makunbound fdefn))) + (fdefn-makunbound fdefn))) (sb!kernel:undefine-fun-name name) name)) diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 36810cb..f00eace 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -53,28 +53,28 @@ "Remove any occurrences of #\\ from the string because we've already checked for whatever they may have protected." (declare (type simple-base-string namestr) - (type index start end)) + (type index start end)) (let* ((result (make-string (- end start) :element-type 'base-char)) - (dst 0) - (quoted nil)) + (dst 0) + (quoted nil)) (do ((src start (1+ src))) - ((= src end)) + ((= src end)) (cond (quoted - (setf (schar result dst) (schar namestr src)) - (setf quoted nil) - (incf dst)) - (t - (let ((char (schar namestr src))) - (cond ((char= char #\\) - (setq quoted t)) - (t - (setf (schar result dst) char) - (incf dst))))))) + (setf (schar result dst) (schar namestr src)) + (setf quoted nil) + (incf dst)) + (t + (let ((char (schar namestr src))) + (cond ((char= char #\\) + (setq quoted t)) + (t + (setf (schar result dst) char) + (incf dst))))))) (when quoted (error 'namestring-parse-error - :complaint "backslash in a bad place" - :namestring namestr - :offset (1- end))) + :complaint "backslash in a bad place" + :namestring namestr + :offset (1- end))) (shrink-vector result dst))) (defvar *ignore-wildcards* nil) @@ -83,91 +83,91 @@ (defun maybe-make-pattern (namestr start end) (declare (type simple-base-string namestr) - (type index start end)) + (type index start end)) (if *ignore-wildcards* (subseq namestr start end) (collect ((pattern)) - (let ((quoted nil) - (any-quotes nil) - (last-regular-char nil) - (index start)) - (flet ((flush-pending-regulars () - (when last-regular-char - (pattern (if any-quotes - (remove-backslashes namestr - last-regular-char - index) - (subseq namestr last-regular-char index))) - (setf any-quotes nil) - (setf last-regular-char nil)))) - (loop - (when (>= index end) - (return)) - (let ((char (schar namestr index))) - (cond (quoted - (incf index) - (setf quoted nil)) - ((char= char #\\) - (setf quoted t) - (setf any-quotes t) - (unless last-regular-char - (setf last-regular-char index)) - (incf index)) - ((char= char #\?) - (flush-pending-regulars) - (pattern :single-char-wild) - (incf index)) - ((char= char #\*) - (flush-pending-regulars) - (pattern :multi-char-wild) - (incf index)) - ((char= char #\[) - (flush-pending-regulars) - (let ((close-bracket - (position #\] namestr :start index :end end))) - (unless close-bracket - (error 'namestring-parse-error - :complaint "#\\[ with no corresponding #\\]" - :namestring namestr - :offset index)) - (pattern (list :character-set - (subseq namestr - (1+ index) - close-bracket))) - (setf index (1+ close-bracket)))) - (t - (unless last-regular-char - (setf last-regular-char index)) - (incf index))))) - (flush-pending-regulars))) - (cond ((null (pattern)) - "") - ((null (cdr (pattern))) - (let ((piece (first (pattern)))) - (typecase piece - ((member :multi-char-wild) :wild) - (simple-string piece) - (t - (make-pattern (pattern)))))) - (t - (make-pattern (pattern))))))) + (let ((quoted nil) + (any-quotes nil) + (last-regular-char nil) + (index start)) + (flet ((flush-pending-regulars () + (when last-regular-char + (pattern (if any-quotes + (remove-backslashes namestr + last-regular-char + index) + (subseq namestr last-regular-char index))) + (setf any-quotes nil) + (setf last-regular-char nil)))) + (loop + (when (>= index end) + (return)) + (let ((char (schar namestr index))) + (cond (quoted + (incf index) + (setf quoted nil)) + ((char= char #\\) + (setf quoted t) + (setf any-quotes t) + (unless last-regular-char + (setf last-regular-char index)) + (incf index)) + ((char= char #\?) + (flush-pending-regulars) + (pattern :single-char-wild) + (incf index)) + ((char= char #\*) + (flush-pending-regulars) + (pattern :multi-char-wild) + (incf index)) + ((char= char #\[) + (flush-pending-regulars) + (let ((close-bracket + (position #\] namestr :start index :end end))) + (unless close-bracket + (error 'namestring-parse-error + :complaint "#\\[ with no corresponding #\\]" + :namestring namestr + :offset index)) + (pattern (list :character-set + (subseq namestr + (1+ index) + close-bracket))) + (setf index (1+ close-bracket)))) + (t + (unless last-regular-char + (setf last-regular-char index)) + (incf index))))) + (flush-pending-regulars))) + (cond ((null (pattern)) + "") + ((null (cdr (pattern))) + (let ((piece (first (pattern)))) + (typecase piece + ((member :multi-char-wild) :wild) + (simple-string piece) + (t + (make-pattern (pattern)))))) + (t + (make-pattern (pattern))))))) (/show0 "filesys.lisp 160") (defun extract-name-type-and-version (namestr start end) (declare (type simple-base-string namestr) - (type index start end)) + (type index start end)) (let* ((last-dot (position #\. namestr :start (1+ start) :end end - :from-end t))) - (cond + :from-end t))) + (cond (last-dot (values (maybe-make-pattern namestr start last-dot) - (maybe-make-pattern namestr (1+ last-dot) end) - :newest)) + (maybe-make-pattern namestr (1+ last-dot) end) + :newest)) (t (values (maybe-make-pattern namestr start end) - nil - :newest))))) + nil + :newest))))) (/show0 "filesys.lisp 200") @@ -176,19 +176,19 @@ ;;; location. (defun split-at-slashes (namestr start end) (declare (type simple-base-string namestr) - (type index start end)) + (type index start end)) (let ((absolute (and (/= start end) - (char= (schar namestr start) #\/)))) + (char= (schar namestr start) #\/)))) (when absolute (incf start)) ;; Next, split the remainder into slash-separated chunks. (collect ((pieces)) (loop - (let ((slash (position #\/ namestr :start start :end end))) - (pieces (cons start (or slash end))) - (unless slash - (return)) - (setf start (1+ slash)))) + (let ((slash (position #\/ namestr :start start :end end))) + (pieces (cons start (or slash end))) + (unless slash + (return)) + (setf start (1+ slash)))) (values absolute (pieces))))) (defun parse-unix-namestring (namestr start end) @@ -197,58 +197,58 @@ (setf namestr (coerce namestr 'simple-base-string)) (multiple-value-bind (absolute pieces) (split-at-slashes namestr start end) (multiple-value-bind (name type version) - (let* ((tail (car (last pieces))) - (tail-start (car tail)) - (tail-end (cdr tail))) - (unless (= tail-start tail-end) - (setf pieces (butlast pieces)) - (extract-name-type-and-version namestr tail-start tail-end))) + (let* ((tail (car (last pieces))) + (tail-start (car tail)) + (tail-end (cdr tail))) + (unless (= tail-start tail-end) + (setf pieces (butlast pieces)) + (extract-name-type-and-version namestr tail-start tail-end))) (when (stringp name) - (let ((position (position-if (lambda (char) - (or (char= char (code-char 0)) - (char= char #\/))) - name))) - (when position - (error 'namestring-parse-error - :complaint "can't embed #\\Nul or #\\/ in Unix namestring" - :namestring namestr - :offset position)))) + (let ((position (position-if (lambda (char) + (or (char= char (code-char 0)) + (char= char #\/))) + name))) + (when position + (error 'namestring-parse-error + :complaint "can't embed #\\Nul or #\\/ in Unix namestring" + :namestring namestr + :offset position)))) ;; Now we have everything we want. So return it. (values nil ; no host for Unix namestrings - nil ; no device for Unix namestrings - (collect ((dirs)) - (dolist (piece pieces) - (let ((piece-start (car piece)) - (piece-end (cdr piece))) - (unless (= piece-start piece-end) - (cond ((string= namestr ".." - :start1 piece-start - :end1 piece-end) - (dirs :up)) - ((string= namestr "**" - :start1 piece-start - :end1 piece-end) - (dirs :wild-inferiors)) - (t - (dirs (maybe-make-pattern namestr - piece-start - piece-end))))))) - (cond (absolute - (cons :absolute (dirs))) - ((dirs) - (cons :relative (dirs))) - (t - nil))) - name - type - version)))) + nil ; no device for Unix namestrings + (collect ((dirs)) + (dolist (piece pieces) + (let ((piece-start (car piece)) + (piece-end (cdr piece))) + (unless (= piece-start piece-end) + (cond ((string= namestr ".." + :start1 piece-start + :end1 piece-end) + (dirs :up)) + ((string= namestr "**" + :start1 piece-start + :end1 piece-end) + (dirs :wild-inferiors)) + (t + (dirs (maybe-make-pattern namestr + piece-start + piece-end))))))) + (cond (absolute + (cons :absolute (dirs))) + ((dirs) + (cons :relative (dirs))) + (t + nil))) + name + type + version)))) (/show0 "filesys.lisp 300") (defun unparse-unix-host (pathname) (declare (type pathname pathname) - (ignore pathname)) + (ignore pathname)) ;; this host designator needs to be recognized as a physical host in ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR, @@ -260,69 +260,69 @@ ((member :wild) "*") (simple-string (let* ((srclen (length thing)) - (dstlen srclen)) + (dstlen srclen)) (dotimes (i srclen) - (case (schar thing i) - ((#\* #\? #\[) - (incf dstlen)))) + (case (schar thing i) + ((#\* #\? #\[) + (incf dstlen)))) (let ((result (make-string dstlen)) - (dst 0)) - (dotimes (src srclen) - (let ((char (schar thing src))) - (case char - ((#\* #\? #\[) - (setf (schar result dst) #\\) - (incf dst))) - (setf (schar result dst) char) - (incf dst))) - result))) + (dst 0)) + (dotimes (src srclen) + (let ((char (schar thing src))) + (case char + ((#\* #\? #\[) + (setf (schar result dst) #\\) + (incf dst))) + (setf (schar result dst) char) + (incf dst))) + result))) (pattern (collect ((strings)) (dolist (piece (pattern-pieces thing)) - (etypecase piece - (simple-string - (strings piece)) - (symbol - (ecase piece - (:multi-char-wild - (strings "*")) - (:single-char-wild - (strings "?")))) - (cons - (case (car piece) - (:character-set - (strings "[") - (strings (cdr piece)) - (strings "]")) - (t - (error "invalid pattern piece: ~S" piece)))))) + (etypecase piece + (simple-string + (strings piece)) + (symbol + (ecase piece + (:multi-char-wild + (strings "*")) + (:single-char-wild + (strings "?")))) + (cons + (case (car piece) + (:character-set + (strings "[") + (strings (cdr piece)) + (strings "]")) + (t + (error "invalid pattern piece: ~S" piece)))))) (apply #'concatenate - 'simple-base-string - (strings)))))) + 'simple-base-string + (strings)))))) (defun unparse-unix-directory-list (directory) (declare (type list directory)) (collect ((pieces)) (when directory (ecase (pop directory) - (:absolute - (pieces "/")) - (:relative - ;; nothing special - )) + (:absolute + (pieces "/")) + (:relative + ;; nothing special + )) (dolist (dir directory) - (typecase dir - ((member :up) - (pieces "../")) - ((member :back) - (error ":BACK cannot be represented in namestrings.")) - ((member :wild-inferiors) - (pieces "**/")) - ((or simple-string pattern (member :wild)) - (pieces (unparse-unix-piece dir)) - (pieces "/")) - (t - (error "invalid directory component: ~S" dir))))) + (typecase dir + ((member :up) + (pieces "../")) + ((member :back) + (error ":BACK cannot be represented in namestrings.")) + ((member :wild-inferiors) + (pieces "**/")) + ((or simple-string pattern (member :wild)) + (pieces (unparse-unix-piece dir)) + (pieces "/")) + (t + (error "invalid directory component: ~S" dir))))) (apply #'concatenate 'simple-base-string (pieces)))) (defun unparse-unix-directory (pathname) @@ -333,29 +333,29 @@ (declare (type pathname pathname)) (collect ((strings)) (let* ((name (%pathname-name pathname)) - (type (%pathname-type pathname)) - (type-supplied (not (or (null type) (eq type :unspecific))))) + (type (%pathname-type pathname)) + (type-supplied (not (or (null type) (eq type :unspecific))))) ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when ;; translating logical pathnames to a filesystem without ;; versions (like Unix). (when name - (when (and (null type) - (typep name 'string) - (> (length name) 0) - (position #\. name :start 1)) - (error "too many dots in the name: ~S" pathname)) - (when (and (typep name 'string) - (string= name "")) - (error "name is of length 0: ~S" pathname)) - (strings (unparse-unix-piece name))) + (when (and (null type) + (typep name 'string) + (> (length name) 0) + (position #\. name :start 1)) + (error "too many dots in the name: ~S" pathname)) + (when (and (typep name 'string) + (string= name "")) + (error "name is of length 0: ~S" pathname)) + (strings (unparse-unix-piece name))) (when type-supplied - (unless name - (error "cannot specify the type without a file: ~S" pathname)) - (when (typep type 'simple-string) - (when (position #\. type) - (error "type component can't have a #\. inside: ~S" pathname))) - (strings ".") - (strings (unparse-unix-piece type)))) + (unless name + (error "cannot specify the type without a file: ~S" pathname)) + (when (typep type 'simple-string) + (when (position #\. type) + (error "type component can't have a #\. inside: ~S" pathname))) + (strings ".") + (strings (unparse-unix-piece type)))) (apply #'concatenate 'simple-base-string (strings)))) (/show0 "filesys.lisp 406") @@ -363,59 +363,59 @@ (defun unparse-unix-namestring (pathname) (declare (type pathname pathname)) (concatenate 'simple-base-string - (unparse-unix-directory pathname) - (unparse-unix-file pathname))) + (unparse-unix-directory pathname) + (unparse-unix-file pathname))) (defun unparse-unix-enough (pathname defaults) (declare (type pathname pathname defaults)) (flet ((lose () - (error "~S cannot be represented relative to ~S." - pathname defaults))) + (error "~S cannot be represented relative to ~S." + pathname defaults))) (collect ((strings)) (let* ((pathname-directory (%pathname-directory pathname)) - (defaults-directory (%pathname-directory defaults)) - (prefix-len (length defaults-directory)) - (result-directory - (cond ((null pathname-directory) '(:relative)) - ((eq (car pathname-directory) :relative) - pathname-directory) - ((and (> prefix-len 1) - (>= (length pathname-directory) prefix-len) - (compare-component (subseq pathname-directory - 0 prefix-len) - defaults-directory)) - ;; Pathname starts with a prefix of default. So - ;; just use a relative directory from then on out. - (cons :relative (nthcdr prefix-len pathname-directory))) - ((eq (car pathname-directory) :absolute) - ;; We are an absolute pathname, so we can just use it. - pathname-directory) - (t - (bug "Bad fallthrough in ~S" 'unparse-unix-enough))))) - (strings (unparse-unix-directory-list result-directory))) + (defaults-directory (%pathname-directory defaults)) + (prefix-len (length defaults-directory)) + (result-directory + (cond ((null pathname-directory) '(:relative)) + ((eq (car pathname-directory) :relative) + pathname-directory) + ((and (> prefix-len 1) + (>= (length pathname-directory) prefix-len) + (compare-component (subseq pathname-directory + 0 prefix-len) + defaults-directory)) + ;; Pathname starts with a prefix of default. So + ;; just use a relative directory from then on out. + (cons :relative (nthcdr prefix-len pathname-directory))) + ((eq (car pathname-directory) :absolute) + ;; We are an absolute pathname, so we can just use it. + pathname-directory) + (t + (bug "Bad fallthrough in ~S" 'unparse-unix-enough))))) + (strings (unparse-unix-directory-list result-directory))) (let* ((pathname-type (%pathname-type pathname)) - (type-needed (and pathname-type - (not (eq pathname-type :unspecific)))) - (pathname-name (%pathname-name pathname)) - (name-needed (or type-needed - (and pathname-name - (not (compare-component pathname-name - (%pathname-name - defaults))))))) - (when name-needed - (unless pathname-name (lose)) - (when (and (null pathname-type) - (position #\. pathname-name :start 1)) - (error "too many dots in the name: ~S" pathname)) - (strings (unparse-unix-piece pathname-name))) - (when type-needed - (when (or (null pathname-type) (eq pathname-type :unspecific)) - (lose)) - (when (typep pathname-type 'simple-base-string) - (when (position #\. pathname-type) - (error "type component can't have a #\. inside: ~S" pathname))) - (strings ".") - (strings (unparse-unix-piece pathname-type)))) + (type-needed (and pathname-type + (not (eq pathname-type :unspecific)))) + (pathname-name (%pathname-name pathname)) + (name-needed (or type-needed + (and pathname-name + (not (compare-component pathname-name + (%pathname-name + defaults))))))) + (when name-needed + (unless pathname-name (lose)) + (when (and (null pathname-type) + (position #\. pathname-name :start 1)) + (error "too many dots in the name: ~S" pathname)) + (strings (unparse-unix-piece pathname-name))) + (when type-needed + (when (or (null pathname-type) (eq pathname-type :unspecific)) + (lose)) + (when (typep pathname-type 'simple-base-string) + (when (position #\. pathname-type) + (error "type component can't have a #\. inside: ~S" pathname))) + (strings ".") + (strings (unparse-unix-piece pathname-type)))) (apply #'concatenate 'simple-string (strings))))) ;;;; wildcard matching stuff @@ -424,32 +424,32 @@ ;;; Unix magic "." and "..") in the directory named by DIRECTORY-NAME. (defun directory-lispy-filenames (directory-name) (with-alien ((adlf (* c-string) - (alien-funcall (extern-alien - "alloc_directory_lispy_filenames" - (function (* c-string) c-string)) - directory-name))) + (alien-funcall (extern-alien + "alloc_directory_lispy_filenames" + (function (* c-string) c-string)) + directory-name))) (if (null-alien adlf) - (error 'simple-file-error - :pathname directory-name - :format-control "~@" - :format-arguments (list directory-name (strerror))) - (unwind-protect - (c-strings->string-list adlf) - (alien-funcall (extern-alien "free_directory_lispy_filenames" - (function void (* c-string))) - adlf))))) + (error 'simple-file-error + :pathname directory-name + :format-control "~@" + :format-arguments (list directory-name (strerror))) + (unwind-protect + (c-strings->string-list adlf) + (alien-funcall (extern-alien "free_directory_lispy_filenames" + (function void (* c-string))) + adlf))))) (/show0 "filesys.lisp 498") (defmacro !enumerate-matches ((var pathname &optional result - &key (verify-existence t) - (follow-links t)) - &body body) + &key (verify-existence t) + (follow-links t)) + &body body) `(block nil (%enumerate-matches (pathname ,pathname) - ,verify-existence - ,follow-links - (lambda (,var) ,@body)) + ,verify-existence + ,follow-links + (lambda (,var) ,@body)) ,result)) (/show0 "filesys.lisp 500") @@ -461,175 +461,175 @@ (unless (pathname-name pathname) (error "cannot supply a type without a name:~% ~S" pathname))) (when (and (integerp (pathname-version pathname)) - (member (pathname-type pathname) '(nil :unspecific))) + (member (pathname-type pathname) '(nil :unspecific))) (error "cannot supply a version without a type:~% ~S" pathname)) (let ((directory (pathname-directory pathname))) (/noshow0 "computed DIRECTORY") (if directory - (ecase (first directory) - (:absolute - (/noshow0 "absolute directory") - (%enumerate-directories "/" (rest directory) pathname - verify-existence follow-links - nil function)) - (:relative - (/noshow0 "relative directory") - (%enumerate-directories "" (rest directory) pathname - verify-existence follow-links - nil function))) - (%enumerate-files "" pathname verify-existence function)))) + (ecase (first directory) + (:absolute + (/noshow0 "absolute directory") + (%enumerate-directories "/" (rest directory) pathname + verify-existence follow-links + nil function)) + (:relative + (/noshow0 "relative directory") + (%enumerate-directories "" (rest directory) pathname + verify-existence follow-links + nil function))) + (%enumerate-files "" pathname verify-existence function)))) ;;; Call FUNCTION on directories. (defun %enumerate-directories (head tail pathname verify-existence - follow-links nodes function) + follow-links nodes function) (declare (simple-string head)) (macrolet ((unix-xstat (name) - `(if follow-links - (sb!unix:unix-stat ,name) - (sb!unix:unix-lstat ,name))) - (with-directory-node-noted ((head) &body body) - `(multiple-value-bind (res dev ino mode) - (unix-xstat ,head) - (when (and res (eql (logand mode sb!unix:s-ifmt) - sb!unix:s-ifdir)) - (let ((nodes (cons (cons dev ino) nodes))) - ,@body)))) - (with-directory-node-removed ((head) &body body) - `(multiple-value-bind (res dev ino mode) - (unix-xstat ,head) - (when (and res (eql (logand mode sb!unix:s-ifmt) - sb!unix:s-ifdir)) - (let ((nodes (remove (cons dev ino) nodes :test #'equal))) - ,@body))))) + `(if follow-links + (sb!unix:unix-stat ,name) + (sb!unix:unix-lstat ,name))) + (with-directory-node-noted ((head) &body body) + `(multiple-value-bind (res dev ino mode) + (unix-xstat ,head) + (when (and res (eql (logand mode sb!unix:s-ifmt) + sb!unix:s-ifdir)) + (let ((nodes (cons (cons dev ino) nodes))) + ,@body)))) + (with-directory-node-removed ((head) &body body) + `(multiple-value-bind (res dev ino mode) + (unix-xstat ,head) + (when (and res (eql (logand mode sb!unix:s-ifmt) + sb!unix:s-ifdir)) + (let ((nodes (remove (cons dev ino) nodes :test #'equal))) + ,@body))))) (if tail - (let ((piece (car tail))) - (etypecase piece - (simple-string - (let ((head (concatenate 'base-string head piece))) - (with-directory-node-noted (head) - (%enumerate-directories (concatenate 'base-string head "/") - (cdr tail) pathname - verify-existence follow-links - nodes function)))) - ((member :wild-inferiors) - ;; now with extra error case handling from CLHS - ;; 19.2.2.4.3 -- CSR, 2004-01-24 - (when (member (cadr tail) '(:up :back)) - (error 'simple-file-error - :pathname pathname - :format-control "~@." - :format-arguments (list (cadr tail)))) - (%enumerate-directories head (rest tail) pathname - verify-existence follow-links - nodes function) - (dolist (name (ignore-errors (directory-lispy-filenames head))) - (let ((subdir (concatenate 'base-string head name))) - (multiple-value-bind (res dev ino mode) - (unix-xstat subdir) - (declare (type (or fixnum null) mode)) - (when (and res (eql (logand mode sb!unix:s-ifmt) - sb!unix:s-ifdir)) - (unless (dolist (dir nodes nil) - (when (and (eql (car dir) dev) - (eql (cdr dir) ino)) - (return t))) - (let ((nodes (cons (cons dev ino) nodes)) - (subdir (concatenate 'base-string subdir "/"))) - (%enumerate-directories subdir tail pathname - verify-existence follow-links - nodes function)))))))) - ((or pattern (member :wild)) - (dolist (name (directory-lispy-filenames head)) - (when (or (eq piece :wild) (pattern-matches piece name)) - (let ((subdir (concatenate 'base-string head name))) - (multiple-value-bind (res dev ino mode) - (unix-xstat subdir) - (declare (type (or fixnum null) mode)) - (when (and res - (eql (logand mode sb!unix:s-ifmt) - sb!unix:s-ifdir)) - (let ((nodes (cons (cons dev ino) nodes)) - (subdir (concatenate 'base-string subdir "/"))) - (%enumerate-directories subdir (rest tail) pathname - verify-existence follow-links - nodes function)))))))) - ((member :up) - (when (string= head "/") - (error 'simple-file-error - :pathname pathname - :format-control "~@")) - (with-directory-node-removed (head) - (let ((head (concatenate 'base-string head ".."))) - (with-directory-node-noted (head) - (%enumerate-directories (concatenate 'base-string head "/") - (rest tail) pathname - verify-existence follow-links - nodes function))))) - ((member :back) - ;; :WILD-INFERIORS is handled above, so the only case here - ;; should be (:ABSOLUTE :BACK) - (aver (string= head "/")) - (error 'simple-file-error - :pathname pathname - :format-control "~@")))) - (%enumerate-files head pathname verify-existence function)))) + (let ((piece (car tail))) + (etypecase piece + (simple-string + (let ((head (concatenate 'base-string head piece))) + (with-directory-node-noted (head) + (%enumerate-directories (concatenate 'base-string head "/") + (cdr tail) pathname + verify-existence follow-links + nodes function)))) + ((member :wild-inferiors) + ;; now with extra error case handling from CLHS + ;; 19.2.2.4.3 -- CSR, 2004-01-24 + (when (member (cadr tail) '(:up :back)) + (error 'simple-file-error + :pathname pathname + :format-control "~@." + :format-arguments (list (cadr tail)))) + (%enumerate-directories head (rest tail) pathname + verify-existence follow-links + nodes function) + (dolist (name (ignore-errors (directory-lispy-filenames head))) + (let ((subdir (concatenate 'base-string head name))) + (multiple-value-bind (res dev ino mode) + (unix-xstat subdir) + (declare (type (or fixnum null) mode)) + (when (and res (eql (logand mode sb!unix:s-ifmt) + sb!unix:s-ifdir)) + (unless (dolist (dir nodes nil) + (when (and (eql (car dir) dev) + (eql (cdr dir) ino)) + (return t))) + (let ((nodes (cons (cons dev ino) nodes)) + (subdir (concatenate 'base-string subdir "/"))) + (%enumerate-directories subdir tail pathname + verify-existence follow-links + nodes function)))))))) + ((or pattern (member :wild)) + (dolist (name (directory-lispy-filenames head)) + (when (or (eq piece :wild) (pattern-matches piece name)) + (let ((subdir (concatenate 'base-string head name))) + (multiple-value-bind (res dev ino mode) + (unix-xstat subdir) + (declare (type (or fixnum null) mode)) + (when (and res + (eql (logand mode sb!unix:s-ifmt) + sb!unix:s-ifdir)) + (let ((nodes (cons (cons dev ino) nodes)) + (subdir (concatenate 'base-string subdir "/"))) + (%enumerate-directories subdir (rest tail) pathname + verify-existence follow-links + nodes function)))))))) + ((member :up) + (when (string= head "/") + (error 'simple-file-error + :pathname pathname + :format-control "~@")) + (with-directory-node-removed (head) + (let ((head (concatenate 'base-string head ".."))) + (with-directory-node-noted (head) + (%enumerate-directories (concatenate 'base-string head "/") + (rest tail) pathname + verify-existence follow-links + nodes function))))) + ((member :back) + ;; :WILD-INFERIORS is handled above, so the only case here + ;; should be (:ABSOLUTE :BACK) + (aver (string= head "/")) + (error 'simple-file-error + :pathname pathname + :format-control "~@")))) + (%enumerate-files head pathname verify-existence function)))) ;;; Call FUNCTION on files. (defun %enumerate-files (directory pathname verify-existence function) (declare (simple-string directory)) (/noshow0 "entering %ENUMERATE-FILES") (let ((name (%pathname-name pathname)) - (type (%pathname-type pathname)) - (version (%pathname-version pathname))) + (type (%pathname-type pathname)) + (version (%pathname-version pathname))) (/noshow0 "computed NAME, TYPE, and VERSION") (cond ((member name '(nil :unspecific)) - (/noshow0 "UNSPECIFIC, more or less") + (/noshow0 "UNSPECIFIC, more or less") (let ((directory (coerce directory 'base-string))) (when (or (not verify-existence) (sb!unix:unix-file-kind directory)) (funcall function directory)))) - ((or (pattern-p name) - (pattern-p type) - (eq name :wild) - (eq type :wild)) - (/noshow0 "WILD, more or less") - ;; I IGNORE-ERRORS here just because the original CMU CL - ;; code did. I think the intent is that it's not an error - ;; to request matches to a wild pattern when no matches - ;; exist, but I haven't tried to figure out whether - ;; everything is kosher. (E.g. what if we try to match a - ;; wildcard but we don't have permission to read one of the - ;; relevant directories?) -- WHN 2001-04-17 - (dolist (complete-filename (ignore-errors - (directory-lispy-filenames directory))) - (multiple-value-bind - (file-name file-type file-version) - (let ((*ignore-wildcards* t)) - (extract-name-type-and-version - complete-filename 0 (length complete-filename))) - (when (and (components-match file-name name) - (components-match file-type type) - (components-match file-version version)) - (funcall function - (concatenate 'base-string - directory - complete-filename)))))) - (t - (/noshow0 "default case") - (let ((file (concatenate 'base-string directory name))) - (/noshow "computed basic FILE") - (unless (or (null type) (eq type :unspecific)) - (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case") - (setf file (concatenate 'base-string file "." type))) - (unless (member version '(nil :newest :wild :unspecific)) - (/noshow0 "tweaking FILE for more-or-less-:WILD case") - (setf file (concatenate 'base-string file "." - (quick-integer-to-string version)))) - (/noshow0 "finished possibly tweaking FILE") - (when (or (not verify-existence) - (sb!unix:unix-file-kind file t)) - (/noshow0 "calling FUNCTION on FILE") - (funcall function file))))))) + ((or (pattern-p name) + (pattern-p type) + (eq name :wild) + (eq type :wild)) + (/noshow0 "WILD, more or less") + ;; I IGNORE-ERRORS here just because the original CMU CL + ;; code did. I think the intent is that it's not an error + ;; to request matches to a wild pattern when no matches + ;; exist, but I haven't tried to figure out whether + ;; everything is kosher. (E.g. what if we try to match a + ;; wildcard but we don't have permission to read one of the + ;; relevant directories?) -- WHN 2001-04-17 + (dolist (complete-filename (ignore-errors + (directory-lispy-filenames directory))) + (multiple-value-bind + (file-name file-type file-version) + (let ((*ignore-wildcards* t)) + (extract-name-type-and-version + complete-filename 0 (length complete-filename))) + (when (and (components-match file-name name) + (components-match file-type type) + (components-match file-version version)) + (funcall function + (concatenate 'base-string + directory + complete-filename)))))) + (t + (/noshow0 "default case") + (let ((file (concatenate 'base-string directory name))) + (/noshow "computed basic FILE") + (unless (or (null type) (eq type :unspecific)) + (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case") + (setf file (concatenate 'base-string file "." type))) + (unless (member version '(nil :newest :wild :unspecific)) + (/noshow0 "tweaking FILE for more-or-less-:WILD case") + (setf file (concatenate 'base-string file "." + (quick-integer-to-string version)))) + (/noshow0 "finished possibly tweaking FILE") + (when (or (not verify-existence) + (sb!unix:unix-file-kind file t)) + (/noshow0 "calling FUNCTION on FILE") + (funcall function file))))))) (/noshow0 "filesys.lisp 603") @@ -637,43 +637,43 @@ (defun quick-integer-to-string (n) (declare (type integer n)) (cond ((not (fixnump n)) - (write-to-string n :base 10 :radix nil)) - ((zerop n) "0") - ((eql n 1) "1") - ((minusp n) - (concatenate 'simple-base-string "-" - (the simple-base-string (quick-integer-to-string (- n))))) - (t - (do* ((len (1+ (truncate (integer-length n) 3))) - (res (make-string len :element-type 'base-char)) - (i (1- len) (1- i)) - (q n) - (r 0)) - ((zerop q) - (incf i) - (replace res res :start2 i :end2 len) - (shrink-vector res (- len i))) - (declare (simple-string res) - (fixnum len i r q)) - (multiple-value-setq (q r) (truncate q 10)) - (setf (schar res i) (schar "0123456789" r)))))) + (write-to-string n :base 10 :radix nil)) + ((zerop n) "0") + ((eql n 1) "1") + ((minusp n) + (concatenate 'simple-base-string "-" + (the simple-base-string (quick-integer-to-string (- n))))) + (t + (do* ((len (1+ (truncate (integer-length n) 3))) + (res (make-string len :element-type 'base-char)) + (i (1- len) (1- i)) + (q n) + (r 0)) + ((zerop q) + (incf i) + (replace res res :start2 i :end2 len) + (shrink-vector res (- len i))) + (declare (simple-string res) + (fixnum len i r q)) + (multiple-value-setq (q r) (truncate q 10)) + (setf (schar res i) (schar "0123456789" r)))))) ;;;; UNIX-NAMESTRING (defun empty-relative-pathname-spec-p (x) (or (equal x "") (and (pathnamep x) - (or (equal (pathname-directory x) '(:relative)) - ;; KLUDGE: I'm not sure this second check should really - ;; have to be here. But on sbcl-0.6.12.7, - ;; (PATHNAME-DIRECTORY (PATHNAME "")) is NIL, and - ;; (PATHNAME "") seems to act like an empty relative - ;; pathname, so in order to work with that, I test - ;; for NIL here. -- WHN 2001-05-18 - (null (pathname-directory x))) - (null (pathname-name x)) - (null (pathname-type x))) - ;; (The ANSI definition of "pathname specifier" has + (or (equal (pathname-directory x) '(:relative)) + ;; KLUDGE: I'm not sure this second check should really + ;; have to be here. But on sbcl-0.6.12.7, + ;; (PATHNAME-DIRECTORY (PATHNAME "")) is NIL, and + ;; (PATHNAME "") seems to act like an empty relative + ;; pathname, so in order to work with that, I test + ;; for NIL here. -- WHN 2001-05-18 + (null (pathname-directory x))) + (null (pathname-name x)) + (null (pathname-type x))) + ;; (The ANSI definition of "pathname specifier" has ;; other cases, but none of them seem to admit the possibility ;; of being empty and relative.) )) @@ -682,13 +682,13 @@ ;;; calls, or return NIL if no match is found. Wild-cards are expanded. (defun unix-namestring (pathname-spec &optional (for-input t)) (let* ((namestring (physicalize-pathname (merge-pathnames pathname-spec))) - (matches nil)) ; an accumulator for actual matches + (matches nil)) ; an accumulator for actual matches (when (wild-pathname-p namestring) (error 'simple-file-error - :pathname namestring - :format-control "bad place for a wild pathname")) + :pathname namestring + :format-control "bad place for a wild pathname")) (!enumerate-matches (match namestring nil :verify-existence for-input) - (push match matches)) + (push match matches)) (case (length matches) (0 nil) (1 (first matches)) @@ -709,9 +709,9 @@ (let ((result (probe-file pathname))) (unless result (error 'simple-file-error - :pathname pathname - :format-control "The file ~S does not exist." - :format-arguments (list (namestring pathname)))) + :pathname pathname + :format-control "The file ~S does not exist." + :format-arguments (list (namestring pathname)))) result)) (defun probe-file (pathname) @@ -719,17 +719,17 @@ "Return a pathname which is the truename of the file if it exists, or NIL otherwise. An error of type FILE-ERROR is signaled if pathname is wild." (let* ((defaulted-pathname (merge-pathnames - pathname - (sane-default-pathname-defaults))) - (namestring (unix-namestring defaulted-pathname t))) + pathname + (sane-default-pathname-defaults))) + (namestring (unix-namestring defaulted-pathname t))) (when (and namestring (sb!unix:unix-file-kind namestring t)) (let ((trueishname (sb!unix:unix-resolve-links namestring))) - (when trueishname - (let* ((*ignore-wildcards* t) - (name (sb!unix:unix-simplify-pathname trueishname))) - (if (eq (sb!unix:unix-file-kind name) :directory) - (pathname (concatenate 'string name "/")) - (pathname name)))))))) + (when trueishname + (let* ((*ignore-wildcards* t) + (name (sb!unix:unix-simplify-pathname trueishname))) + (if (eq (sb!unix:unix-file-kind name) :directory) + (pathname (concatenate 'string name "/")) + (pathname name)))))))) ;;;; miscellaneous other operations @@ -740,24 +740,24 @@ "Rename FILE to have the specified NEW-NAME. If FILE is a stream open to a file, then the associated file is renamed." (let* ((original (truename file)) - (original-namestring (unix-namestring original t)) - (new-name (merge-pathnames new-name original)) - (new-namestring (unix-namestring new-name nil))) + (original-namestring (unix-namestring original t)) + (new-name (merge-pathnames new-name original)) + (new-namestring (unix-namestring new-name nil))) (unless new-namestring (error 'simple-file-error - :pathname new-name - :format-control "~S can't be created." - :format-arguments (list new-name))) + :pathname new-name + :format-control "~S can't be created." + :format-arguments (list new-name))) (multiple-value-bind (res error) - (sb!unix:unix-rename original-namestring new-namestring) + (sb!unix:unix-rename original-namestring new-namestring) (unless res - (error 'simple-file-error - :pathname new-name - :format-control "~@" - :format-arguments (list original new-name (strerror error)))) + :format-arguments (list original new-name (strerror error)))) (when (streamp file) - (file-name file new-name)) + (file-name file new-name)) (values new-name original (truename new-name))))) (defun delete-file (file) @@ -768,15 +768,15 @@ (close file :abort t)) (unless namestring (error 'simple-file-error - :pathname file - :format-control "~S doesn't exist." - :format-arguments (list file))) + :pathname file + :format-control "~S doesn't exist." + :format-arguments (list file))) (multiple-value-bind (res err) (sb!unix:unix-unlink namestring) (unless res - (simple-file-perror "couldn't delete ~A" namestring err)))) + (simple-file-perror "couldn't delete ~A" namestring err)))) t) -;;; (This is an ANSI Common Lisp function.) +;;; (This is an ANSI Common Lisp function.) (defun user-homedir-pathname (&optional host) "Return the home directory of the user as a pathname." (declare (ignore host)) @@ -789,11 +789,11 @@ (let ((name (unix-namestring file t))) (when name (multiple-value-bind - (res dev ino mode nlink uid gid rdev size atime mtime) - (sb!unix:unix-stat name) - (declare (ignore dev ino mode nlink uid gid rdev size atime)) - (when res - (+ unix-to-universal-time mtime)))))) + (res dev ino mode nlink uid gid rdev size atime mtime) + (sb!unix:unix-stat name) + (declare (ignore dev ino mode nlink uid gid rdev size atime)) + (when res + (+ unix-to-universal-time mtime)))))) (defun file-author (file) #!+sb-doc @@ -803,11 +803,11 @@ (let ((name (unix-namestring (pathname file) t))) (unless name (error 'simple-file-error - :pathname file - :format-control "~S doesn't exist." - :format-arguments (list file))) + :pathname file + :format-control "~S doesn't exist." + :format-arguments (list file))) (multiple-value-bind (winp dev ino mode nlink uid) - (sb!unix:unix-stat name) + (sb!unix:unix-stat name) (declare (ignore dev ino mode nlink)) (and winp (sb!unix:uid-username uid))))) @@ -847,51 +847,51 @@ (aver (logical-pathname-p two)) (labels ((intersect-version (one two) - (aver (typep one '(or null (member :newest :wild :unspecific) - integer))) - (aver (typep two '(or null (member :newest :wild :unspecific) - integer))) - (cond - ((eq one :wild) two) - ((eq two :wild) one) - ((or (null one) (eq one :unspecific)) two) - ((or (null two) (eq two :unspecific)) one) - ((eql one two) one) - (t nil))) + (aver (typep one '(or null (member :newest :wild :unspecific) + integer))) + (aver (typep two '(or null (member :newest :wild :unspecific) + integer))) + (cond + ((eq one :wild) two) + ((eq two :wild) one) + ((or (null one) (eq one :unspecific)) two) + ((or (null two) (eq two :unspecific)) one) + ((eql one two) one) + (t nil))) (intersect-name/type (one two) - (aver (typep one '(or null (member :wild :unspecific) string))) - (aver (typep two '(or null (member :wild :unspecific) string))) - (cond - ((eq one :wild) two) - ((eq two :wild) one) - ((or (null one) (eq one :unspecific)) two) - ((or (null two) (eq two :unspecific)) one) - ((string= one two) one) - (t nil))) + (aver (typep one '(or null (member :wild :unspecific) string))) + (aver (typep two '(or null (member :wild :unspecific) string))) + (cond + ((eq one :wild) two) + ((eq two :wild) one) + ((or (null one) (eq one :unspecific)) two) + ((or (null two) (eq two :unspecific)) one) + ((string= one two) one) + (t nil))) (intersect-directory (one two) - (aver (typep one '(or null (member :wild :unspecific) list))) - (aver (typep two '(or null (member :wild :unspecific) list))) - (cond - ((eq one :wild) two) - ((eq two :wild) one) - ((or (null one) (eq one :unspecific)) two) - ((or (null two) (eq two :unspecific)) one) - (t (aver (eq (car one) (car two))) - (mapcar - (lambda (x) (cons (car one) x)) - (intersect-directory-helper (cdr one) (cdr two))))))) + (aver (typep one '(or null (member :wild :unspecific) list))) + (aver (typep two '(or null (member :wild :unspecific) list))) + (cond + ((eq one :wild) two) + ((eq two :wild) one) + ((or (null one) (eq one :unspecific)) two) + ((or (null two) (eq two :unspecific)) one) + (t (aver (eq (car one) (car two))) + (mapcar + (lambda (x) (cons (car one) x)) + (intersect-directory-helper (cdr one) (cdr two))))))) (let ((version (intersect-version - (pathname-version one) (pathname-version two))) - (name (intersect-name/type - (pathname-name one) (pathname-name two))) - (type (intersect-name/type - (pathname-type one) (pathname-type two))) - (host (pathname-host one))) + (pathname-version one) (pathname-version two))) + (name (intersect-name/type + (pathname-name one) (pathname-name two))) + (type (intersect-name/type + (pathname-type one) (pathname-type two))) + (host (pathname-host one))) (mapcar (lambda (d) - (make-pathname :host host :name name :type type - :version version :directory d)) - (intersect-directory - (pathname-directory one) (pathname-directory two)))))) + (make-pathname :host host :name name :type type + :version version :directory d)) + (intersect-directory + (pathname-directory one) (pathname-directory two)))))) ;;; FIXME: written as its own function because I (CSR) don't ;;; understand it, so helping both debuggability and modularity. In @@ -907,55 +907,55 @@ ;;; turns out to be worth it. (defun intersect-directory-helper (one two) (flet ((simple-intersection (cone ctwo) - (cond - ((eq cone :wild) ctwo) - ((eq ctwo :wild) cone) - (t (aver (typep cone 'string)) - (aver (typep ctwo 'string)) - (if (string= cone ctwo) cone nil))))) + (cond + ((eq cone :wild) ctwo) + ((eq ctwo :wild) cone) + (t (aver (typep cone 'string)) + (aver (typep ctwo 'string)) + (if (string= cone ctwo) cone nil))))) (macrolet - ((loop-possible-wild-inferiors-matches - (lower-bound bounding-sequence order) - (let ((index (gensym)) (g2 (gensym)) (g3 (gensym)) (l (gensym))) - `(let ((,l (length ,bounding-sequence))) - (loop for ,index from ,lower-bound to ,l - append (mapcar (lambda (,g2) - (append - (butlast ,bounding-sequence (- ,l ,index)) - ,g2)) - (mapcar - (lambda (,g3) - (append - (if (eq (car (nthcdr ,index ,bounding-sequence)) - :wild-inferiors) - '(:wild-inferiors) - nil) ,g3)) - (intersect-directory-helper - ,@(if order - `((nthcdr ,index one) (cdr two)) - `((cdr one) (nthcdr ,index two))))))))))) + ((loop-possible-wild-inferiors-matches + (lower-bound bounding-sequence order) + (let ((index (gensym)) (g2 (gensym)) (g3 (gensym)) (l (gensym))) + `(let ((,l (length ,bounding-sequence))) + (loop for ,index from ,lower-bound to ,l + append (mapcar (lambda (,g2) + (append + (butlast ,bounding-sequence (- ,l ,index)) + ,g2)) + (mapcar + (lambda (,g3) + (append + (if (eq (car (nthcdr ,index ,bounding-sequence)) + :wild-inferiors) + '(:wild-inferiors) + nil) ,g3)) + (intersect-directory-helper + ,@(if order + `((nthcdr ,index one) (cdr two)) + `((cdr one) (nthcdr ,index two))))))))))) (cond - ((and (eq (car one) :wild-inferiors) - (eq (car two) :wild-inferiors)) - (delete-duplicates - (append (mapcar (lambda (x) (cons :wild-inferiors x)) - (intersect-directory-helper (cdr one) (cdr two))) - (loop-possible-wild-inferiors-matches 2 one t) - (loop-possible-wild-inferiors-matches 2 two nil)) - :test 'equal)) - ((eq (car one) :wild-inferiors) - (delete-duplicates (loop-possible-wild-inferiors-matches 0 two nil) - :test 'equal)) - ((eq (car two) :wild-inferiors) - (delete-duplicates (loop-possible-wild-inferiors-matches 0 one t) - :test 'equal)) - ((and (null one) (null two)) (list nil)) - ((null one) nil) - ((null two) nil) - (t (and (simple-intersection (car one) (car two)) - (mapcar (lambda (x) (cons (simple-intersection - (car one) (car two)) x)) - (intersect-directory-helper (cdr one) (cdr two))))))))) + ((and (eq (car one) :wild-inferiors) + (eq (car two) :wild-inferiors)) + (delete-duplicates + (append (mapcar (lambda (x) (cons :wild-inferiors x)) + (intersect-directory-helper (cdr one) (cdr two))) + (loop-possible-wild-inferiors-matches 2 one t) + (loop-possible-wild-inferiors-matches 2 two nil)) + :test 'equal)) + ((eq (car one) :wild-inferiors) + (delete-duplicates (loop-possible-wild-inferiors-matches 0 two nil) + :test 'equal)) + ((eq (car two) :wild-inferiors) + (delete-duplicates (loop-possible-wild-inferiors-matches 0 one t) + :test 'equal)) + ((and (null one) (null two)) (list nil)) + ((null one) nil) + ((null two) nil) + (t (and (simple-intersection (car one) (car two)) + (mapcar (lambda (x) (cons (simple-intersection + (car one) (car two)) x)) + (intersect-directory-helper (cdr one) (cdr two))))))))) (defun directory (pathname &key) #!+sb-doc @@ -965,63 +965,63 @@ means this function can sometimes return files which don't have the same directory as PATHNAME." (let (;; We create one entry in this hash table for each truename, - ;; as an asymptotically efficient way of removing duplicates - ;; (which can arise when e.g. multiple symlinks map to the - ;; same truename). - (truenames (make-hash-table :test #'equal)) - ;; FIXME: Possibly this MERGE-PATHNAMES call should only - ;; happen once we get a physical pathname. + ;; as an asymptotically efficient way of removing duplicates + ;; (which can arise when e.g. multiple symlinks map to the + ;; same truename). + (truenames (make-hash-table :test #'equal)) + ;; FIXME: Possibly this MERGE-PATHNAMES call should only + ;; happen once we get a physical pathname. (merged-pathname (merge-pathnames pathname))) (labels ((do-physical-directory (pathname) - (aver (not (logical-pathname-p pathname))) - (!enumerate-matches (match pathname) - (let* ((*ignore-wildcards* t) - ;; FIXME: Why not TRUENAME? As reported by - ;; Milan Zamazal sbcl-devel 2003-10-05, using - ;; TRUENAME causes a race condition whereby - ;; removal of a file during the directory - ;; operation causes an error. It's not clear - ;; what the right thing to do is, though. -- - ;; CSR, 2003-10-13 - (truename (probe-file match))) - (when truename - (setf (gethash (namestring truename) truenames) - truename))))) - (do-directory (pathname) - (if (logical-pathname-p pathname) - (let ((host (intern-logical-host (pathname-host pathname)))) - (dolist (x (logical-host-canon-transls host)) - (destructuring-bind (from to) x - (let ((intersections - (pathname-intersections pathname from))) - (dolist (p intersections) - (do-directory (translate-pathname p from to))))))) - (do-physical-directory pathname)))) + (aver (not (logical-pathname-p pathname))) + (!enumerate-matches (match pathname) + (let* ((*ignore-wildcards* t) + ;; FIXME: Why not TRUENAME? As reported by + ;; Milan Zamazal sbcl-devel 2003-10-05, using + ;; TRUENAME causes a race condition whereby + ;; removal of a file during the directory + ;; operation causes an error. It's not clear + ;; what the right thing to do is, though. -- + ;; CSR, 2003-10-13 + (truename (probe-file match))) + (when truename + (setf (gethash (namestring truename) truenames) + truename))))) + (do-directory (pathname) + (if (logical-pathname-p pathname) + (let ((host (intern-logical-host (pathname-host pathname)))) + (dolist (x (logical-host-canon-transls host)) + (destructuring-bind (from to) x + (let ((intersections + (pathname-intersections pathname from))) + (dolist (p intersections) + (do-directory (translate-pathname p from to))))))) + (do-physical-directory pathname)))) (do-directory merged-pathname)) (mapcar #'cdr - ;; Sorting isn't required by the ANSI spec, but sorting - ;; into some canonical order seems good just on the - ;; grounds that the implementation should have repeatable - ;; behavior when possible. + ;; Sorting isn't required by the ANSI spec, but sorting + ;; into some canonical order seems good just on the + ;; grounds that the implementation should have repeatable + ;; behavior when possible. (sort (loop for name being each hash-key in truenames - using (hash-value truename) + using (hash-value truename) collect (cons name truename)) #'string< - :key #'car)))) + :key #'car)))) (/show0 "filesys.lisp 899") ;;; predicate to order pathnames by; goes by name (defun pathname-order (x y) (let ((xn (%pathname-name x)) - (yn (%pathname-name y))) + (yn (%pathname-name y))) (if (and xn yn) - (let ((res (string-lessp xn yn))) - (cond ((not res) nil) - ((= res (length (the simple-string xn))) t) - ((= res (length (the simple-string yn))) nil) - (t t))) - xn))) + (let ((res (string-lessp xn yn))) + (cond ((not res) nil) + ((= res (length (the simple-string xn))) t) + ((= res (length (the simple-string yn))) nil) + (t t))) + xn))) (defun ensure-directories-exist (pathspec &key verbose (mode #o777)) #!+sb-doc @@ -1030,30 +1030,30 @@ The MODE argument is a CMUCL/SBCL-specific extension to control the Unix permission bits." (let ((pathname (physicalize-pathname (pathname pathspec))) - (created-p nil)) + (created-p nil)) (when (wild-pathname-p pathname) (error 'simple-file-error - :format-control "bad place for a wild pathname" - :pathname pathspec)) + :format-control "bad place for a wild pathname" + :pathname pathspec)) (let ((dir (pathname-directory pathname))) (loop for i from 1 upto (length dir) - do (let ((newpath (make-pathname - :host (pathname-host pathname) - :device (pathname-device pathname) - :directory (subseq dir 0 i)))) - (unless (probe-file newpath) - (let ((namestring (coerce (namestring newpath) 'base-string))) - (when verbose - (format *standard-output* - "~&creating directory: ~A~%" - namestring)) - (sb!unix:unix-mkdir namestring mode) - (unless (probe-file namestring) - (error 'simple-file-error - :pathname pathspec - :format-control "can't create directory ~A" - :format-arguments (list namestring))) - (setf created-p t))))) + do (let ((newpath (make-pathname + :host (pathname-host pathname) + :device (pathname-device pathname) + :directory (subseq dir 0 i)))) + (unless (probe-file newpath) + (let ((namestring (coerce (namestring newpath) 'base-string))) + (when verbose + (format *standard-output* + "~&creating directory: ~A~%" + namestring)) + (sb!unix:unix-mkdir namestring mode) + (unless (probe-file namestring) + (error 'simple-file-error + :pathname pathspec + :format-control "can't create directory ~A" + :format-arguments (list namestring))) + (setf created-p t))))) (values pathname created-p)))) (/show0 "filesys.lisp 1000") diff --git a/src/code/final.lisp b/src/code/final.lisp index 15a45a6..597d5d0 100644 --- a/src/code/final.lisp +++ b/src/code/final.lisp @@ -13,11 +13,11 @@ (defvar *finalizer-store* nil) -(defvar *finalizer-store-lock* +(defvar *finalizer-store-lock* (sb!thread:make-mutex :name "Finalizer store lock.")) (defun finalize (object function) - #!+sb-doc + #!+sb-doc "Arrange for the designated FUNCTION to be called when there are no more references to OBJECT, including references in FUNCTION itself. @@ -48,19 +48,19 @@ Examples: (defvar *rec* nil) (defun oops () - (when *rec* + (when *rec* (error \"recursive OOPS\")) (let ((*rec* t)) (gc))) ; or just cons enough to cause one - (progn + (progn (finalize \"oops\" #'oops) (oops)) ; causes GC and re-entry to #'oops due to the finalizer ; -> ERROR, caught, WARNING signalled" (sb!sys:without-gcing (sb!thread:with-mutex (*finalizer-store-lock*) - (push (cons (make-weak-pointer object) function) - *finalizer-store*))) + (push (cons (make-weak-pointer object) function) + *finalizer-store*))) object) (defun cancel-finalization (object) @@ -70,28 +70,28 @@ Examples: ;; run. (when object (sb!sys:without-gcing - (sb!thread:with-mutex (*finalizer-store-lock*) - (setf *finalizer-store* - (delete object *finalizer-store* - :key (lambda (pair) - (weak-pointer-value (car pair))))))) + (sb!thread:with-mutex (*finalizer-store-lock*) + (setf *finalizer-store* + (delete object *finalizer-store* + :key (lambda (pair) + (weak-pointer-value (car pair))))))) object)) (defun run-pending-finalizers () (let (pending) (sb!sys:without-gcing - (sb!thread:with-mutex (*finalizer-store-lock*) - (setf *finalizer-store* - (delete-if (lambda (pair) - (when (null (weak-pointer-value (car pair))) - (push (cdr pair) pending) - t)) - *finalizer-store*)))) + (sb!thread:with-mutex (*finalizer-store-lock*) + (setf *finalizer-store* + (delete-if (lambda (pair) + (when (null (weak-pointer-value (car pair))) + (push (cdr pair) pending) + t)) + *finalizer-store*)))) ;; We want to run the finalizer bodies outside the lock in case ;; finalization of X causes finalization to be added for Y. (dolist (fun pending) (handler-case - (funcall fun) - (error (c) - (warn "Error calling finalizer ~S:~% ~S" fun c))))) + (funcall fun) + (error (c) + (warn "Error calling finalizer ~S:~% ~S" fun c))))) nil) diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index ab89ba2..e0b2730 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -18,31 +18,31 @@ (defparameter *float-trap-alist* (list (cons :underflow float-underflow-trap-bit) - (cons :overflow float-overflow-trap-bit) - (cons :inexact float-inexact-trap-bit) - (cons :invalid float-invalid-trap-bit) - (cons :divide-by-zero float-divide-by-zero-trap-bit) - #!+x86 (cons :denormalized-operand float-denormal-trap-bit))) + (cons :overflow float-overflow-trap-bit) + (cons :inexact float-inexact-trap-bit) + (cons :invalid float-invalid-trap-bit) + (cons :divide-by-zero float-divide-by-zero-trap-bit) + #!+x86 (cons :denormalized-operand float-denormal-trap-bit))) (defparameter *rounding-mode-alist* (list (cons :nearest float-round-to-nearest) - (cons :zero float-round-to-zero) - (cons :positive-infinity float-round-to-positive) - (cons :negative-infinity float-round-to-negative))) + (cons :zero float-round-to-zero) + (cons :positive-infinity float-round-to-positive) + (cons :negative-infinity float-round-to-negative))) #!+x86 (defparameter *precision-mode-alist* (list (cons :24-bit float-precision-24-bit) - (cons :53-bit float-precision-53-bit) - (cons :64-bit float-precision-64-bit))) + (cons :53-bit float-precision-53-bit) + (cons :64-bit float-precision-64-bit))) ;;; Return a mask with all the specified float trap bits set. (defun float-trap-mask (names) (reduce #'logior - (mapcar (lambda (x) - (or (cdr (assoc x *float-trap-alist*)) - (error "unknown float trap kind: ~S" x))) - names))) + (mapcar (lambda (x) + (or (cdr (assoc x *float-trap-alist*)) + (error "unknown float trap kind: ~S" x))) + names))) ) ; EVAL-WHEN ;;; interpreter stubs for floating point modes get/setters for the @@ -50,9 +50,9 @@ ;;; in C rather than as VOPs. #!-(or alpha x86-64) (progn - (defun floating-point-modes () + (defun floating-point-modes () (floating-point-modes)) - (defun (setf floating-point-modes) (new) + (defun (setf floating-point-modes) (new) (setf (floating-point-modes) new))) ;;; This function sets options controlling the floating-point @@ -88,39 +88,39 @@ ;;; enabled traps (defun set-floating-point-modes (&key (traps nil traps-p) - (rounding-mode nil round-p) - (current-exceptions nil current-x-p) - (accrued-exceptions nil accrued-x-p) - (fast-mode nil fast-mode-p) - #!+x86 (precision nil precisionp)) + (rounding-mode nil round-p) + (current-exceptions nil current-x-p) + (accrued-exceptions nil accrued-x-p) + (fast-mode nil fast-mode-p) + #!+x86 (precision nil precisionp)) (let ((modes (floating-point-modes))) (when traps-p (setf (ldb float-traps-byte modes) (float-trap-mask traps))) (when round-p (setf (ldb float-rounding-mode modes) - (or (cdr (assoc rounding-mode *rounding-mode-alist*)) - (error "unknown rounding mode: ~S" rounding-mode)))) + (or (cdr (assoc rounding-mode *rounding-mode-alist*)) + (error "unknown rounding mode: ~S" rounding-mode)))) (when current-x-p (setf (ldb float-exceptions-byte modes) - (float-trap-mask current-exceptions))) + (float-trap-mask current-exceptions))) (when accrued-x-p (setf (ldb float-sticky-bits modes) - (float-trap-mask accrued-exceptions))) + (float-trap-mask accrued-exceptions))) (when fast-mode-p (if fast-mode - (setq modes (logior float-fast-bit modes)) - (setq modes (logand (lognot float-fast-bit) modes)))) + (setq modes (logior float-fast-bit modes)) + (setq modes (logand (lognot float-fast-bit) modes)))) #!+x86 (when precisionp (setf (ldb float-precision-control modes) - (or (cdr (assoc precision *precision-mode-alist*)) - (error "unknown precision mode: ~S" precision)))) + (or (cdr (assoc precision *precision-mode-alist*)) + (error "unknown precision mode: ~S" precision)))) ;; FIXME: This apparently doesn't work on Darwin #!-darwin (setf (floating-point-modes) modes)) (values)) -;;; This function returns a list representing the state of the floating +;;; This function returns a list representing the state of the floating ;;; point modes. The list is in the same format as the &KEY arguments to ;;; SET-FLOATING-POINT-MODES, i.e. ;;; (apply #'set-floating-point-modes (get-floating-point-modes)) @@ -128,56 +128,56 @@ ;;; no-op). (defun get-floating-point-modes () (flet ((exc-keys (bits) - (macrolet ((frob () - `(collect ((res)) - ,@(mapcar (lambda (x) - `(when (logtest bits ,(cdr x)) - (res ',(car x)))) - *float-trap-alist*) - (res)))) - (frob)))) + (macrolet ((frob () + `(collect ((res)) + ,@(mapcar (lambda (x) + `(when (logtest bits ,(cdr x)) + (res ',(car x)))) + *float-trap-alist*) + (res)))) + (frob)))) (let ((modes (floating-point-modes))) `(:traps ,(exc-keys (ldb float-traps-byte modes)) - :rounding-mode ,(car (rassoc (ldb float-rounding-mode modes) - *rounding-mode-alist*)) - :current-exceptions ,(exc-keys (ldb float-exceptions-byte modes)) - :accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes)) - :fast-mode ,(logtest float-fast-bit modes) - #!+x86 :precision - #!+x86 ,(car (rassoc (ldb float-precision-control modes) - *precision-mode-alist*)))))) + :rounding-mode ,(car (rassoc (ldb float-rounding-mode modes) + *rounding-mode-alist*)) + :current-exceptions ,(exc-keys (ldb float-exceptions-byte modes)) + :accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes)) + :fast-mode ,(logtest float-fast-bit modes) + #!+x86 :precision + #!+x86 ,(car (rassoc (ldb float-precision-control modes) + *precision-mode-alist*)))))) ;;; Return true if any of the named traps are currently trapped, false ;;; otherwise. (defmacro current-float-trap (&rest traps) `(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0) - (floating-point-modes))))) + (floating-point-modes))))) ;;; Signal the appropriate condition when we get a floating-point error. (defun sigfpe-handler (signal info context) (declare (ignore signal info)) (declare (type system-area-pointer context)) (let* ((modes (context-floating-point-modes - (sb!alien:sap-alien context (* os-context-t)))) - (traps (logand (ldb float-exceptions-byte modes) - (ldb float-traps-byte modes)))) + (sb!alien:sap-alien context (* os-context-t)))) + (traps (logand (ldb float-exceptions-byte modes) + (ldb float-traps-byte modes)))) (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps))) - (error 'division-by-zero)) - ((not (zerop (logand float-invalid-trap-bit traps))) - (error 'floating-point-invalid-operation)) - ((not (zerop (logand float-overflow-trap-bit traps))) - (error 'floating-point-overflow)) - ((not (zerop (logand float-underflow-trap-bit traps))) - (error 'floating-point-underflow)) - ((not (zerop (logand float-inexact-trap-bit traps))) - (error 'floating-point-inexact)) - #!+freebsd - ((zerop (ldb float-exceptions-byte modes)) - ;; I can't tell what caused the exception!! - (error 'floating-point-exception - :traps (getf (get-floating-point-modes) :traps))) - (t - (error 'floating-point-exception))))) + (error 'division-by-zero)) + ((not (zerop (logand float-invalid-trap-bit traps))) + (error 'floating-point-invalid-operation)) + ((not (zerop (logand float-overflow-trap-bit traps))) + (error 'floating-point-overflow)) + ((not (zerop (logand float-underflow-trap-bit traps))) + (error 'floating-point-underflow)) + ((not (zerop (logand float-inexact-trap-bit traps))) + (error 'floating-point-inexact)) + #!+freebsd + ((zerop (ldb float-exceptions-byte modes)) + ;; I can't tell what caused the exception!! + (error 'floating-point-exception + :traps (getf (get-floating-point-modes) :traps))) + (t + (error 'floating-point-exception))))) ;;; Execute BODY with the floating point exceptions listed in TRAPS ;;; masked (disabled). TRAPS should be a list of possible exceptions @@ -187,20 +187,20 @@ ;;; to support their testing within, and restored on exit. (defmacro with-float-traps-masked (traps &body body) (let ((traps (dpb (float-trap-mask traps) float-traps-byte 0)) - (exceptions (dpb (float-trap-mask traps) float-sticky-bits 0)) - (trap-mask (dpb (lognot (float-trap-mask traps)) - float-traps-byte #xffffffff)) - (exception-mask (dpb (lognot (float-trap-mask traps)) - float-sticky-bits #xffffffff)) + (exceptions (dpb (float-trap-mask traps) float-sticky-bits 0)) + (trap-mask (dpb (lognot (float-trap-mask traps)) + float-traps-byte #xffffffff)) + (exception-mask (dpb (lognot (float-trap-mask traps)) + float-sticky-bits #xffffffff)) (orig-modes (gensym))) `(let ((,orig-modes (floating-point-modes))) (unwind-protect - (progn - (setf (floating-point-modes) - (logand ,orig-modes ,(logand trap-mask exception-mask))) - ,@body) - ;; Restore the original traps and exceptions. - (setf (floating-point-modes) - (logior (logand ,orig-modes ,(logior traps exceptions)) - (logand (floating-point-modes) - ,(logand trap-mask exception-mask)))))))) + (progn + (setf (floating-point-modes) + (logand ,orig-modes ,(logand trap-mask exception-mask))) + ,@body) + ;; Restore the original traps and exceptions. + (setf (floating-point-modes) + (logior (logand ,orig-modes ,(logior traps exceptions)) + (logand (floating-point-modes) + ,(logand trap-mask exception-mask)))))))) diff --git a/src/code/float.lisp b/src/code/float.lisp index 29cefa3..9e8ae74 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -19,7 +19,7 @@ #!-sb-fluid (declaim (maybe-inline float-denormalized-p float-infinity-p float-nan-p - float-trapping-nan-p)) + float-trapping-nan-p)) (defun float-denormalized-p (x) #!+sb-doc @@ -27,15 +27,15 @@ (number-dispatch ((x float)) ((single-float) (and (zerop (ldb sb!vm:single-float-exponent-byte (single-float-bits x))) - (not (zerop x)))) + (not (zerop x)))) ((double-float) (and (zerop (ldb sb!vm:double-float-exponent-byte - (double-float-high-bits x))) - (not (zerop x)))) + (double-float-high-bits x))) + (not (zerop x)))) #!+(and long-float x86) ((long-float) (and (zerop (ldb sb!vm:long-float-exponent-byte (long-float-exp-bits x))) - (not (zerop x)))))) + (not (zerop x)))))) (defmacro !define-float-dispatching-function (name doc single double #!+(and long-float x86) long) @@ -44,25 +44,25 @@ (number-dispatch ((x float)) ((single-float) (let ((bits (single-float-bits x))) - (and (> (ldb sb!vm:single-float-exponent-byte bits) - sb!vm:single-float-normal-exponent-max) - ,single))) + (and (> (ldb sb!vm:single-float-exponent-byte bits) + sb!vm:single-float-normal-exponent-max) + ,single))) ((double-float) (let ((hi (double-float-high-bits x)) - (lo (double-float-low-bits x))) - (declare (ignorable lo)) - (and (> (ldb sb!vm:double-float-exponent-byte hi) - sb!vm:double-float-normal-exponent-max) - ,double))) + (lo (double-float-low-bits x))) + (declare (ignorable lo)) + (and (> (ldb sb!vm:double-float-exponent-byte hi) + sb!vm:double-float-normal-exponent-max) + ,double))) #!+(and long-float x86) ((long-float) (let ((exp (long-float-exp-bits x)) - (hi (long-float-high-bits x)) - (lo (long-float-low-bits x))) - (declare (ignorable lo)) - (and (> (ldb sb!vm:long-float-exponent-byte exp) - sb!vm:long-float-normal-exponent-max) - ,long)))))) + (hi (long-float-high-bits x)) + (lo (long-float-low-bits x))) + (declare (ignorable lo)) + (and (> (ldb sb!vm:long-float-exponent-byte exp) + sb!vm:long-float-normal-exponent-max) + ,long)))))) (!define-float-dispatching-function float-infinity-p "Return true if the float X is an infinity (+ or -)." @@ -85,12 +85,12 @@ (!define-float-dispatching-function float-trapping-nan-p "Return true if the float X is a trapping NaN (Not a Number)." (zerop (logand (ldb sb!vm:single-float-significand-byte bits) - sb!vm:single-float-trapping-nan-bit)) + sb!vm:single-float-trapping-nan-bit)) (zerop (logand (ldb sb!vm:double-float-significand-byte hi) - sb!vm:double-float-trapping-nan-bit)) + sb!vm:double-float-trapping-nan-bit)) #!+(and long-float x86) (zerop (logand (ldb sb!vm:long-float-significand-byte hi) - sb!vm:long-float-trapping-nan-bit))) + sb!vm:long-float-trapping-nan-bit))) ;;; If denormalized, use a subfunction from INTEGER-DECODE-FLOAT to find the ;;; actual exponent (and hence how denormalized it is), otherwise we just @@ -101,25 +101,25 @@ "Return a non-negative number of significant digits in its float argument. Will be less than FLOAT-DIGITS if denormalized or zero." (macrolet ((frob (digits bias decode) - `(cond ((zerop f) 0) - ((float-denormalized-p f) - (multiple-value-bind (ignore exp) (,decode f) - (declare (ignore ignore)) - (truly-the fixnum - (+ ,digits (1- ,digits) ,bias exp)))) - (t - ,digits)))) + `(cond ((zerop f) 0) + ((float-denormalized-p f) + (multiple-value-bind (ignore exp) (,decode f) + (declare (ignore ignore)) + (truly-the fixnum + (+ ,digits (1- ,digits) ,bias exp)))) + (t + ,digits)))) (number-dispatch ((f float)) ((single-float) (frob sb!vm:single-float-digits sb!vm:single-float-bias - integer-decode-single-denorm)) + integer-decode-single-denorm)) ((double-float) (frob sb!vm:double-float-digits sb!vm:double-float-bias - integer-decode-double-denorm)) + integer-decode-double-denorm)) #!+long-float ((long-float) (frob sb!vm:long-float-digits sb!vm:long-float-bias - integer-decode-long-denorm))))) + integer-decode-long-denorm))))) (defun float-sign (float1 &optional (float2 (float 1 float1))) #!+sb-doc @@ -128,12 +128,12 @@ as FLOAT2." (declare (float float1 float2)) (* (if (etypecase float1 - (single-float (minusp (single-float-bits float1))) - (double-float (minusp (double-float-high-bits float1))) - #!+long-float - (long-float (minusp (long-float-exp-bits float1)))) - (float -1 float1) - (float 1 float1)) + (single-float (minusp (single-float-bits float1))) + (double-float (minusp (double-float-high-bits float1))) + #!+long-float + (long-float (minusp (long-float-exp-bits float1)))) + (float -1 float1) + (float 1 float1)) (abs float2))) (defun float-format-digits (format) @@ -162,153 +162,153 @@ #!-sb-fluid (declaim (maybe-inline integer-decode-single-float - integer-decode-double-float)) + integer-decode-double-float)) ;;; Handle the denormalized case of INTEGER-DECODE-FLOAT for SINGLE-FLOAT. (defun integer-decode-single-denorm (x) (declare (type single-float x)) (let* ((bits (single-float-bits (abs x))) - (sig (ash (ldb sb!vm:single-float-significand-byte bits) 1)) - (extra-bias 0)) + (sig (ash (ldb sb!vm:single-float-significand-byte bits) 1)) + (extra-bias 0)) (declare (type (unsigned-byte 24) sig) - (type (integer 0 23) extra-bias)) + (type (integer 0 23) extra-bias)) (loop (unless (zerop (logand sig sb!vm:single-float-hidden-bit)) - (return)) + (return)) (setq sig (ash sig 1)) (incf extra-bias)) (values sig - (- (- sb!vm:single-float-bias) - sb!vm:single-float-digits - extra-bias) - (if (minusp (float-sign x)) -1 1)))) + (- (- sb!vm:single-float-bias) + sb!vm:single-float-digits + extra-bias) + (if (minusp (float-sign x)) -1 1)))) ;;; Handle the single-float case of INTEGER-DECODE-FLOAT. If an infinity or ;;; NaN, error. If a denorm, call i-d-s-DENORM to handle it. (defun integer-decode-single-float (x) (declare (single-float x)) (let* ((bits (single-float-bits (abs x))) - (exp (ldb sb!vm:single-float-exponent-byte bits)) - (sig (ldb sb!vm:single-float-significand-byte bits)) - (sign (if (minusp (float-sign x)) -1 1)) - (biased (- exp sb!vm:single-float-bias sb!vm:single-float-digits))) + (exp (ldb sb!vm:single-float-exponent-byte bits)) + (sig (ldb sb!vm:single-float-significand-byte bits)) + (sign (if (minusp (float-sign x)) -1 1)) + (biased (- exp sb!vm:single-float-bias sb!vm:single-float-digits))) (declare (fixnum biased)) (unless (<= exp sb!vm:single-float-normal-exponent-max) (error "can't decode NaN or infinity: ~S" x)) (cond ((and (zerop exp) (zerop sig)) - (values 0 biased sign)) - ((< exp sb!vm:single-float-normal-exponent-min) - (integer-decode-single-denorm x)) - (t - (values (logior sig sb!vm:single-float-hidden-bit) biased sign))))) + (values 0 biased sign)) + ((< exp sb!vm:single-float-normal-exponent-min) + (integer-decode-single-denorm x)) + (t + (values (logior sig sb!vm:single-float-hidden-bit) biased sign))))) ;;; like INTEGER-DECODE-SINGLE-DENORM, only doubly so (defun integer-decode-double-denorm (x) (declare (type double-float x)) (let* ((high-bits (double-float-high-bits (abs x))) - (sig-high (ldb sb!vm:double-float-significand-byte high-bits)) - (low-bits (double-float-low-bits x)) - (sign (if (minusp (float-sign x)) -1 1)) - (biased (- (- sb!vm:double-float-bias) sb!vm:double-float-digits))) + (sig-high (ldb sb!vm:double-float-significand-byte high-bits)) + (low-bits (double-float-low-bits x)) + (sign (if (minusp (float-sign x)) -1 1)) + (biased (- (- sb!vm:double-float-bias) sb!vm:double-float-digits))) (if (zerop sig-high) - (let ((sig low-bits) - (extra-bias (- sb!vm:double-float-digits 33)) - (bit (ash 1 31))) - (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) - (loop - (unless (zerop (logand sig bit)) (return)) - (setq sig (ash sig 1)) - (incf extra-bias)) - (values (ash sig (- sb!vm:double-float-digits 32)) - (truly-the fixnum (- biased extra-bias)) - sign)) - (let ((sig (ash sig-high 1)) - (extra-bias 0)) - (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) - (loop - (unless (zerop (logand sig sb!vm:double-float-hidden-bit)) - (return)) - (setq sig (ash sig 1)) - (incf extra-bias)) - (values (logior (ash sig 32) (ash low-bits (1- extra-bias))) - (truly-the fixnum (- biased extra-bias)) - sign))))) + (let ((sig low-bits) + (extra-bias (- sb!vm:double-float-digits 33)) + (bit (ash 1 31))) + (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) + (loop + (unless (zerop (logand sig bit)) (return)) + (setq sig (ash sig 1)) + (incf extra-bias)) + (values (ash sig (- sb!vm:double-float-digits 32)) + (truly-the fixnum (- biased extra-bias)) + sign)) + (let ((sig (ash sig-high 1)) + (extra-bias 0)) + (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) + (loop + (unless (zerop (logand sig sb!vm:double-float-hidden-bit)) + (return)) + (setq sig (ash sig 1)) + (incf extra-bias)) + (values (logior (ash sig 32) (ash low-bits (1- extra-bias))) + (truly-the fixnum (- biased extra-bias)) + sign))))) ;;; like INTEGER-DECODE-SINGLE-FLOAT, only doubly so (defun integer-decode-double-float (x) (declare (double-float x)) (let* ((abs (abs x)) - (hi (double-float-high-bits abs)) - (lo (double-float-low-bits abs)) - (exp (ldb sb!vm:double-float-exponent-byte hi)) - (sig (ldb sb!vm:double-float-significand-byte hi)) - (sign (if (minusp (float-sign x)) -1 1)) - (biased (- exp sb!vm:double-float-bias sb!vm:double-float-digits))) + (hi (double-float-high-bits abs)) + (lo (double-float-low-bits abs)) + (exp (ldb sb!vm:double-float-exponent-byte hi)) + (sig (ldb sb!vm:double-float-significand-byte hi)) + (sign (if (minusp (float-sign x)) -1 1)) + (biased (- exp sb!vm:double-float-bias sb!vm:double-float-digits))) (declare (fixnum biased)) (unless (<= exp sb!vm:double-float-normal-exponent-max) (error "Can't decode NaN or infinity: ~S." x)) (cond ((and (zerop exp) (zerop sig) (zerop lo)) - (values 0 biased sign)) - ((< exp sb!vm:double-float-normal-exponent-min) - (integer-decode-double-denorm x)) - (t - (values - (logior (ash (logior (ldb sb!vm:double-float-significand-byte hi) - sb!vm:double-float-hidden-bit) - 32) - lo) - biased sign))))) + (values 0 biased sign)) + ((< exp sb!vm:double-float-normal-exponent-min) + (integer-decode-double-denorm x)) + (t + (values + (logior (ash (logior (ldb sb!vm:double-float-significand-byte hi) + sb!vm:double-float-hidden-bit) + 32) + lo) + biased sign))))) #!+(and long-float x86) (defun integer-decode-long-denorm (x) (declare (type long-float x)) (let* ((high-bits (long-float-high-bits (abs x))) - (sig-high (ldb sb!vm:long-float-significand-byte high-bits)) - (low-bits (long-float-low-bits x)) - (sign (if (minusp (float-sign x)) -1 1)) - (biased (- (- sb!vm:long-float-bias) sb!vm:long-float-digits))) + (sig-high (ldb sb!vm:long-float-significand-byte high-bits)) + (low-bits (long-float-low-bits x)) + (sign (if (minusp (float-sign x)) -1 1)) + (biased (- (- sb!vm:long-float-bias) sb!vm:long-float-digits))) (if (zerop sig-high) - (let ((sig low-bits) - (extra-bias (- sb!vm:long-float-digits 33)) - (bit (ash 1 31))) - (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) - (loop - (unless (zerop (logand sig bit)) (return)) - (setq sig (ash sig 1)) - (incf extra-bias)) - (values (ash sig (- sb!vm:long-float-digits 32)) - (truly-the fixnum (- biased extra-bias)) - sign)) - (let ((sig (ash sig-high 1)) - (extra-bias 0)) - (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) - (loop - (unless (zerop (logand sig sb!vm:long-float-hidden-bit)) - (return)) - (setq sig (ash sig 1)) - (incf extra-bias)) - (values (logior (ash sig 32) (ash low-bits (1- extra-bias))) - (truly-the fixnum (- biased extra-bias)) - sign))))) + (let ((sig low-bits) + (extra-bias (- sb!vm:long-float-digits 33)) + (bit (ash 1 31))) + (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) + (loop + (unless (zerop (logand sig bit)) (return)) + (setq sig (ash sig 1)) + (incf extra-bias)) + (values (ash sig (- sb!vm:long-float-digits 32)) + (truly-the fixnum (- biased extra-bias)) + sign)) + (let ((sig (ash sig-high 1)) + (extra-bias 0)) + (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) + (loop + (unless (zerop (logand sig sb!vm:long-float-hidden-bit)) + (return)) + (setq sig (ash sig 1)) + (incf extra-bias)) + (values (logior (ash sig 32) (ash low-bits (1- extra-bias))) + (truly-the fixnum (- biased extra-bias)) + sign))))) #!+(and long-float x86) (defun integer-decode-long-float (x) (declare (long-float x)) (let* ((hi (long-float-high-bits x)) - (lo (long-float-low-bits x)) - (exp-bits (long-float-exp-bits x)) - (exp (ldb sb!vm:long-float-exponent-byte exp-bits)) - (sign (if (minusp exp-bits) -1 1)) - (biased (- exp sb!vm:long-float-bias sb!vm:long-float-digits))) + (lo (long-float-low-bits x)) + (exp-bits (long-float-exp-bits x)) + (exp (ldb sb!vm:long-float-exponent-byte exp-bits)) + (sign (if (minusp exp-bits) -1 1)) + (biased (- exp sb!vm:long-float-bias sb!vm:long-float-digits))) (declare (fixnum biased)) (unless (<= exp sb!vm:long-float-normal-exponent-max) (error "can't decode NaN or infinity: ~S" x)) (cond ((and (zerop exp) (zerop hi) (zerop lo)) - (values 0 biased sign)) - ((< exp sb!vm:long-float-normal-exponent-min) - (integer-decode-long-denorm x)) - (t - (values (logior (ash hi 32) lo) biased sign))))) + (values 0 biased sign)) + ((< exp sb!vm:long-float-normal-exponent-min) + (integer-decode-long-denorm x)) + (t + (values (logior (ash hi 32) lo) biased sign))))) ;;; Dispatch to the correct type-specific i-d-f function. (defun integer-decode-float (x) @@ -337,103 +337,103 @@ (declare (type single-float x)) (multiple-value-bind (sig exp sign) (integer-decode-single-denorm x) (values (make-single-float - (dpb sig sb!vm:single-float-significand-byte - (dpb sb!vm:single-float-bias - sb!vm:single-float-exponent-byte - 0))) - (truly-the fixnum (+ exp sb!vm:single-float-digits)) - (float sign x)))) + (dpb sig sb!vm:single-float-significand-byte + (dpb sb!vm:single-float-bias + sb!vm:single-float-exponent-byte + 0))) + (truly-the fixnum (+ exp sb!vm:single-float-digits)) + (float sign x)))) ;;; Handle the single-float case of DECODE-FLOAT. If an infinity or NaN, ;;; error. If a denorm, call d-s-DENORM to handle it. (defun decode-single-float (x) (declare (single-float x)) (let* ((bits (single-float-bits (abs x))) - (exp (ldb sb!vm:single-float-exponent-byte bits)) - (sign (float-sign x)) - (biased (truly-the single-float-exponent - (- exp sb!vm:single-float-bias)))) + (exp (ldb sb!vm:single-float-exponent-byte bits)) + (sign (float-sign x)) + (biased (truly-the single-float-exponent + (- exp sb!vm:single-float-bias)))) (unless (<= exp sb!vm:single-float-normal-exponent-max) (error "can't decode NaN or infinity: ~S" x)) (cond ((zerop x) - (values 0.0f0 biased sign)) - ((< exp sb!vm:single-float-normal-exponent-min) - (decode-single-denorm x)) - (t - (values (make-single-float - (dpb sb!vm:single-float-bias - sb!vm:single-float-exponent-byte - bits)) - biased sign))))) + (values 0.0f0 biased sign)) + ((< exp sb!vm:single-float-normal-exponent-min) + (decode-single-denorm x)) + (t + (values (make-single-float + (dpb sb!vm:single-float-bias + sb!vm:single-float-exponent-byte + bits)) + biased sign))))) ;;; like DECODE-SINGLE-DENORM, only doubly so (defun decode-double-denorm (x) (declare (double-float x)) (multiple-value-bind (sig exp sign) (integer-decode-double-denorm x) (values (make-double-float - (dpb (logand (ash sig -32) (lognot sb!vm:double-float-hidden-bit)) - sb!vm:double-float-significand-byte - (dpb sb!vm:double-float-bias - sb!vm:double-float-exponent-byte 0)) - (ldb (byte 32 0) sig)) - (truly-the fixnum (+ exp sb!vm:double-float-digits)) - (float sign x)))) + (dpb (logand (ash sig -32) (lognot sb!vm:double-float-hidden-bit)) + sb!vm:double-float-significand-byte + (dpb sb!vm:double-float-bias + sb!vm:double-float-exponent-byte 0)) + (ldb (byte 32 0) sig)) + (truly-the fixnum (+ exp sb!vm:double-float-digits)) + (float sign x)))) ;;; like DECODE-SINGLE-FLOAT, only doubly so (defun decode-double-float (x) (declare (double-float x)) (let* ((abs (abs x)) - (hi (double-float-high-bits abs)) - (lo (double-float-low-bits abs)) - (exp (ldb sb!vm:double-float-exponent-byte hi)) - (sign (float-sign x)) - (biased (truly-the double-float-exponent - (- exp sb!vm:double-float-bias)))) + (hi (double-float-high-bits abs)) + (lo (double-float-low-bits abs)) + (exp (ldb sb!vm:double-float-exponent-byte hi)) + (sign (float-sign x)) + (biased (truly-the double-float-exponent + (- exp sb!vm:double-float-bias)))) (unless (<= exp sb!vm:double-float-normal-exponent-max) (error "can't decode NaN or infinity: ~S" x)) (cond ((zerop x) - (values 0.0d0 biased sign)) - ((< exp sb!vm:double-float-normal-exponent-min) - (decode-double-denorm x)) - (t - (values (make-double-float - (dpb sb!vm:double-float-bias - sb!vm:double-float-exponent-byte hi) - lo) - biased sign))))) + (values 0.0d0 biased sign)) + ((< exp sb!vm:double-float-normal-exponent-min) + (decode-double-denorm x)) + (t + (values (make-double-float + (dpb sb!vm:double-float-bias + sb!vm:double-float-exponent-byte hi) + lo) + biased sign))))) #!+(and long-float x86) (defun decode-long-denorm (x) (declare (long-float x)) (multiple-value-bind (sig exp sign) (integer-decode-long-denorm x) (values (make-long-float sb!vm:long-float-bias (ash sig -32) - (ldb (byte 32 0) sig)) - (truly-the fixnum (+ exp sb!vm:long-float-digits)) - (float sign x)))) + (ldb (byte 32 0) sig)) + (truly-the fixnum (+ exp sb!vm:long-float-digits)) + (float sign x)))) #!+(and long-float x86) (defun decode-long-float (x) (declare (long-float x)) (let* ((hi (long-float-high-bits x)) - (lo (long-float-low-bits x)) - (exp-bits (long-float-exp-bits x)) - (exp (ldb sb!vm:long-float-exponent-byte exp-bits)) - (sign (if (minusp exp-bits) -1l0 1l0)) - (biased (truly-the long-float-exponent - (- exp sb!vm:long-float-bias)))) + (lo (long-float-low-bits x)) + (exp-bits (long-float-exp-bits x)) + (exp (ldb sb!vm:long-float-exponent-byte exp-bits)) + (sign (if (minusp exp-bits) -1l0 1l0)) + (biased (truly-the long-float-exponent + (- exp sb!vm:long-float-bias)))) (unless (<= exp sb!vm:long-float-normal-exponent-max) (error "can't decode NaN or infinity: ~S" x)) (cond ((zerop x) - (values 0.0l0 biased sign)) - ((< exp sb!vm:long-float-normal-exponent-min) - (decode-long-denorm x)) - (t - (values (make-long-float - (dpb sb!vm:long-float-bias sb!vm:long-float-exponent-byte - exp-bits) - hi - lo) - biased sign))))) + (values 0.0l0 biased sign)) + ((< exp sb!vm:long-float-normal-exponent-min) + (decode-long-denorm x)) + (t + (values (make-long-float + (dpb sb!vm:long-float-bias sb!vm:long-float-exponent-byte + exp-bits) + hi + lo) + biased sign))))) ;;; Dispatch to the appropriate type-specific function. (defun decode-float (f) @@ -461,32 +461,32 @@ (defun scale-float-maybe-underflow (x exp) (multiple-value-bind (sig old-exp) (integer-decode-float x) (let* ((digits (float-digits x)) - (new-exp (+ exp old-exp digits - (etypecase x - (single-float sb!vm:single-float-bias) - (double-float sb!vm:double-float-bias)))) - (sign (if (minusp (float-sign x)) 1 0))) + (new-exp (+ exp old-exp digits + (etypecase x + (single-float sb!vm:single-float-bias) + (double-float sb!vm:double-float-bias)))) + (sign (if (minusp (float-sign x)) 1 0))) (cond ((< new-exp - (etypecase x - (single-float sb!vm:single-float-normal-exponent-min) - (double-float sb!vm:double-float-normal-exponent-min))) - (when (sb!vm:current-float-trap :inexact) - (error 'floating-point-inexact :operation 'scale-float - :operands (list x exp))) - (when (sb!vm:current-float-trap :underflow) - (error 'floating-point-underflow :operation 'scale-float - :operands (list x exp))) - (let ((shift (1- new-exp))) - (if (< shift (- (1- digits))) - (float-sign x 0.0) - (etypecase x - (single-float (single-from-bits sign 0 (ash sig shift))) - (double-float (double-from-bits sign 0 (ash sig shift))))))) + (etypecase x + (single-float sb!vm:single-float-normal-exponent-min) + (double-float sb!vm:double-float-normal-exponent-min))) + (when (sb!vm:current-float-trap :inexact) + (error 'floating-point-inexact :operation 'scale-float + :operands (list x exp))) + (when (sb!vm:current-float-trap :underflow) + (error 'floating-point-underflow :operation 'scale-float + :operands (list x exp))) + (let ((shift (1- new-exp))) + (if (< shift (- (1- digits))) + (float-sign x 0.0) + (etypecase x + (single-float (single-from-bits sign 0 (ash sig shift))) + (double-float (double-from-bits sign 0 (ash sig shift))))))) (t - (etypecase x - (single-float (single-from-bits sign new-exp sig)) - (double-float (double-from-bits sign new-exp sig)))))))) + (etypecase x + (single-float (single-from-bits sign new-exp sig)) + (double-float (double-from-bits sign new-exp sig)))))))) ;;; Called when scaling a float overflows, or the original float was a ;;; NaN or infinity. If overflow errors are trapped, then error, @@ -499,25 +499,25 @@ x) ((float-nan-p x) (when (and (float-trapping-nan-p x) - (sb!vm:current-float-trap :invalid)) + (sb!vm:current-float-trap :invalid)) (error 'floating-point-invalid-operation :operation 'scale-float - :operands (list x exp))) + :operands (list x exp))) x) (t (when (sb!vm:current-float-trap :overflow) (error 'floating-point-overflow :operation 'scale-float - :operands (list x exp))) + :operands (list x exp))) (when (sb!vm:current-float-trap :inexact) (error 'floating-point-inexact :operation 'scale-float - :operands (list x exp))) + :operands (list x exp))) (* (float-sign x) (etypecase x - (single-float - ;; SINGLE-FLOAT-POSITIVE-INFINITY - (single-from-bits 0 (1+ sb!vm:single-float-normal-exponent-max) 0)) - (double-float - ;; DOUBLE-FLOAT-POSITIVE-INFINITY - (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0))))))) + (single-float + ;; SINGLE-FLOAT-POSITIVE-INFINITY + (single-from-bits 0 (1+ sb!vm:single-float-normal-exponent-max) 0)) + (double-float + ;; DOUBLE-FLOAT-POSITIVE-INFINITY + (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0))))))) ;;; Scale a single or double float, calling the correct over/underflow ;;; functions. @@ -526,20 +526,20 @@ (etypecase exp (fixnum (let* ((bits (single-float-bits x)) - (old-exp (ldb sb!vm:single-float-exponent-byte bits)) - (new-exp (+ old-exp exp))) + (old-exp (ldb sb!vm:single-float-exponent-byte bits)) + (new-exp (+ old-exp exp))) (cond - ((zerop x) x) - ((or (< old-exp sb!vm:single-float-normal-exponent-min) - (< new-exp sb!vm:single-float-normal-exponent-min)) - (scale-float-maybe-underflow x exp)) - ((or (> old-exp sb!vm:single-float-normal-exponent-max) - (> new-exp sb!vm:single-float-normal-exponent-max)) - (scale-float-maybe-overflow x exp)) - (t - (make-single-float (dpb new-exp - sb!vm:single-float-exponent-byte - bits)))))) + ((zerop x) x) + ((or (< old-exp sb!vm:single-float-normal-exponent-min) + (< new-exp sb!vm:single-float-normal-exponent-min)) + (scale-float-maybe-underflow x exp)) + ((or (> old-exp sb!vm:single-float-normal-exponent-max) + (> new-exp sb!vm:single-float-normal-exponent-max)) + (scale-float-maybe-overflow x exp)) + (t + (make-single-float (dpb new-exp + sb!vm:single-float-exponent-byte + bits)))))) (unsigned-byte (scale-float-maybe-overflow x exp)) ((integer * 0) (scale-float-maybe-underflow x exp)))) (defun scale-double-float (x exp) @@ -547,20 +547,20 @@ (etypecase exp (fixnum (let* ((hi (double-float-high-bits x)) - (lo (double-float-low-bits x)) - (old-exp (ldb sb!vm:double-float-exponent-byte hi)) - (new-exp (+ old-exp exp))) + (lo (double-float-low-bits x)) + (old-exp (ldb sb!vm:double-float-exponent-byte hi)) + (new-exp (+ old-exp exp))) (cond - ((zerop x) x) - ((or (< old-exp sb!vm:double-float-normal-exponent-min) - (< new-exp sb!vm:double-float-normal-exponent-min)) - (scale-float-maybe-underflow x exp)) - ((or (> old-exp sb!vm:double-float-normal-exponent-max) - (> new-exp sb!vm:double-float-normal-exponent-max)) - (scale-float-maybe-overflow x exp)) - (t - (make-double-float (dpb new-exp sb!vm:double-float-exponent-byte hi) - lo))))) + ((zerop x) x) + ((or (< old-exp sb!vm:double-float-normal-exponent-min) + (< new-exp sb!vm:double-float-normal-exponent-min)) + (scale-float-maybe-underflow x exp)) + ((or (> old-exp sb!vm:double-float-normal-exponent-max) + (> new-exp sb!vm:double-float-normal-exponent-max)) + (scale-float-maybe-overflow x exp)) + (t + (make-double-float (dpb new-exp sb!vm:double-float-exponent-byte hi) + lo))))) (unsigned-byte (scale-float-maybe-overflow x exp)) ((integer * 0) (scale-float-maybe-underflow x exp)))) @@ -592,23 +592,23 @@ result is the same float format as OTHER." (if otherp (number-dispatch ((number real) (other float)) - (((foreach rational single-float double-float #!+long-float long-float) - (foreach single-float double-float #!+long-float long-float)) - (coerce number '(dispatch-type other)))) + (((foreach rational single-float double-float #!+long-float long-float) + (foreach single-float double-float #!+long-float long-float)) + (coerce number '(dispatch-type other)))) (if (floatp number) - number - (coerce number 'single-float)))) + number + (coerce number 'single-float)))) (macrolet ((frob (name type) - `(defun ,name (x) - (number-dispatch ((x real)) - (((foreach single-float double-float #!+long-float long-float - fixnum)) - (coerce x ',type)) - ((bignum) - (bignum-to-float x ',type)) - ((ratio) - (float-ratio x ',type)))))) + `(defun ,name (x) + (number-dispatch ((x real)) + (((foreach single-float double-float #!+long-float long-float + fixnum)) + (coerce x ',type)) + ((bignum) + (bignum-to-float x ',type)) + ((ratio) + (float-ratio x ',type)))))) (frob %single-float single-float) (frob %double-float double-float) #!+long-float @@ -621,11 +621,11 @@ ;;; desired number of fraction bits, then do round-to-nearest. (defun float-ratio (x format) (let* ((signed-num (numerator x)) - (plusp (plusp signed-num)) - (num (if plusp signed-num (- signed-num))) - (den (denominator x)) - (digits (float-format-digits format)) - (scale 0)) + (plusp (plusp signed-num)) + (num (if plusp signed-num (- signed-num))) + (den (denominator x)) + (digits (float-format-digits format)) + (scale 0)) (declare (fixnum digits scale)) ;; Strip any trailing zeros from the denominator and move it into the scale ;; factor (to minimize the size of the operands.) @@ -636,49 +636,49 @@ ;; Guess how much we need to scale by from the magnitudes of the numerator ;; and denominator. We want one extra bit for a guard bit. (let* ((num-len (integer-length num)) - (den-len (integer-length den)) - (delta (- den-len num-len)) - (shift (1+ (the fixnum (+ delta digits)))) - (shifted-num (ash num shift))) + (den-len (integer-length den)) + (delta (- den-len num-len)) + (shift (1+ (the fixnum (+ delta digits)))) + (shifted-num (ash num shift))) (declare (fixnum delta shift)) (decf scale delta) (labels ((float-and-scale (bits) - (let* ((bits (ash bits -1)) - (len (integer-length bits))) - (cond ((> len digits) - (aver (= len (the fixnum (1+ digits)))) - (scale-float (floatit (ash bits -1)) (1+ scale))) - (t - (scale-float (floatit bits) scale))))) - (floatit (bits) - (let ((sign (if plusp 0 1))) - (case format - (single-float - (single-from-bits sign sb!vm:single-float-bias bits)) - (double-float - (double-from-bits sign sb!vm:double-float-bias bits)) - #!+long-float - (long-float - (long-from-bits sign sb!vm:long-float-bias bits)))))) - (loop - (multiple-value-bind (fraction-and-guard rem) - (truncate shifted-num den) - (let ((extra (- (integer-length fraction-and-guard) digits))) - (declare (fixnum extra)) - (cond ((/= extra 1) - (aver (> extra 1))) - ((oddp fraction-and-guard) - (return - (if (zerop rem) - (float-and-scale - (if (zerop (logand fraction-and-guard 2)) - fraction-and-guard - (1+ fraction-and-guard))) - (float-and-scale (1+ fraction-and-guard))))) - (t - (return (float-and-scale fraction-and-guard))))) - (setq shifted-num (ash shifted-num -1)) - (incf scale))))))) + (let* ((bits (ash bits -1)) + (len (integer-length bits))) + (cond ((> len digits) + (aver (= len (the fixnum (1+ digits)))) + (scale-float (floatit (ash bits -1)) (1+ scale))) + (t + (scale-float (floatit bits) scale))))) + (floatit (bits) + (let ((sign (if plusp 0 1))) + (case format + (single-float + (single-from-bits sign sb!vm:single-float-bias bits)) + (double-float + (double-from-bits sign sb!vm:double-float-bias bits)) + #!+long-float + (long-float + (long-from-bits sign sb!vm:long-float-bias bits)))))) + (loop + (multiple-value-bind (fraction-and-guard rem) + (truncate shifted-num den) + (let ((extra (- (integer-length fraction-and-guard) digits))) + (declare (fixnum extra)) + (cond ((/= extra 1) + (aver (> extra 1))) + ((oddp fraction-and-guard) + (return + (if (zerop rem) + (float-and-scale + (if (zerop (logand fraction-and-guard 2)) + fraction-and-guard + (1+ fraction-and-guard))) + (float-and-scale (1+ fraction-and-guard))))) + (t + (return (float-and-scale fraction-and-guard))))) + (setq shifted-num (ash shifted-num -1)) + (incf scale))))))) #| These might be useful if we ever have a machine without float/integer @@ -692,47 +692,47 @@ uninterruptibly frob the rounding modes & do ieee round-to-integer. (declare (single-float x) (values fixnum)) (locally (declare (optimize (speed 3) (safety 0))) (let* ((bits (single-float-bits x)) - (exp (ldb sb!vm:single-float-exponent-byte bits)) - (frac (logior (ldb sb!vm:single-float-significand-byte bits) - sb!vm:single-float-hidden-bit)) - (shift (- exp sb!vm:single-float-digits sb!vm:single-float-bias))) + (exp (ldb sb!vm:single-float-exponent-byte bits)) + (frac (logior (ldb sb!vm:single-float-significand-byte bits) + sb!vm:single-float-hidden-bit)) + (shift (- exp sb!vm:single-float-digits sb!vm:single-float-bias))) (when (> exp sb!vm:single-float-normal-exponent-max) - (error 'floating-point-invalid-operation :operator 'truncate - :operands (list x))) + (error 'floating-point-invalid-operation :operator 'truncate + :operands (list x))) (if (<= shift (- sb!vm:single-float-digits)) - 0 - (let ((res (ash frac shift))) - (declare (type (unsigned-byte 31) res)) - (if (minusp bits) - (- res) - res)))))) + 0 + (let ((res (ash frac shift))) + (declare (type (unsigned-byte 31) res)) + (if (minusp bits) + (- res) + res)))))) ;;; Double-float version of this operation (see above single op). (defun %unary-truncate-double-float/fixnum (x) (declare (double-float x) (values fixnum)) (locally (declare (optimize (speed 3) (safety 0))) (let* ((hi-bits (double-float-high-bits x)) - (exp (ldb sb!vm:double-float-exponent-byte hi-bits)) - (frac (logior (ldb sb!vm:double-float-significand-byte hi-bits) - sb!vm:double-float-hidden-bit)) - (shift (- exp (- sb!vm:double-float-digits sb!vm:n-word-bits) - sb!vm:double-float-bias))) + (exp (ldb sb!vm:double-float-exponent-byte hi-bits)) + (frac (logior (ldb sb!vm:double-float-significand-byte hi-bits) + sb!vm:double-float-hidden-bit)) + (shift (- exp (- sb!vm:double-float-digits sb!vm:n-word-bits) + sb!vm:double-float-bias))) (when (> exp sb!vm:double-float-normal-exponent-max) - (error 'floating-point-invalid-operation :operator 'truncate - :operands (list x))) + (error 'floating-point-invalid-operation :operator 'truncate + :operands (list x))) (if (<= shift (- sb!vm:n-word-bits sb!vm:double-float-digits)) - 0 - (let* ((res-hi (ash frac shift)) - (res (if (plusp shift) - (logior res-hi - (the fixnum - (ash (double-float-low-bits x) - (- shift sb!vm:n-word-bits)))) - res-hi))) - (declare (type (unsigned-byte 31) res-hi res)) - (if (minusp hi-bits) - (- res) - res)))))) + 0 + (let* ((res-hi (ash frac shift)) + (res (if (plusp shift) + (logior res-hi + (the fixnum + (ash (double-float-low-bits x) + (- shift sb!vm:n-word-bits)))) + res-hi))) + (declare (type (unsigned-byte 31) res-hi res)) + (if (minusp hi-bits) + (- res) + res)))))) |# ;;; This function is called when we are doing a truncate without any funky @@ -750,14 +750,14 @@ uninterruptibly frob the rounding modes & do ieee round-to-integer. ((ratio) (values (truncate (numerator number) (denominator number)))) (((foreach single-float double-float #!+long-float long-float)) (if (< (float most-negative-fixnum number) - number - (float most-positive-fixnum number)) - (truly-the fixnum (%unary-truncate number)) - (multiple-value-bind (bits exp) (integer-decode-float number) - (let ((res (ash bits exp))) - (if (minusp number) - (- res) - res))))))) + number + (float most-positive-fixnum number)) + (truly-the fixnum (%unary-truncate number)) + (multiple-value-bind (bits exp) (integer-decode-float number) + (let ((res (ash bits exp))) + (if (minusp number) + (- res) + res))))))) ;;; Similar to %UNARY-TRUNCATE, but rounds to the nearest integer. If we ;;; can't use the round primitive, then we do our own round-to-nearest on the @@ -771,21 +771,21 @@ uninterruptibly frob the rounding modes & do ieee round-to-integer. ((ratio) (values (round (numerator number) (denominator number)))) (((foreach single-float double-float #!+long-float long-float)) (if (< (float most-negative-fixnum number) - number - (float most-positive-fixnum number)) - (truly-the fixnum (%unary-round number)) - (multiple-value-bind (bits exp) (integer-decode-float number) - (let* ((shifted (ash bits exp)) - (rounded (if (and (minusp exp) - (oddp shifted) - (eql (logand bits - (lognot (ash -1 (- exp)))) - (ash 1 (- -1 exp)))) - (1+ shifted) - shifted))) - (if (minusp number) - (- rounded) - rounded))))))) + number + (float most-positive-fixnum number)) + (truly-the fixnum (%unary-round number)) + (multiple-value-bind (bits exp) (integer-decode-float number) + (let* ((shifted (ash bits exp)) + (rounded (if (and (minusp exp) + (oddp shifted) + (eql (logand bits + (lognot (ash -1 (- exp)))) + (ash 1 (- -1 exp)))) + (1+ shifted) + shifted))) + (if (minusp number) + (- rounded) + rounded))))))) (defun %unary-ftruncate (number) (number-dispatch ((number real)) @@ -803,13 +803,13 @@ uninterruptibly frob the rounding modes & do ieee round-to-integer. (((foreach single-float double-float #!+long-float long-float)) (multiple-value-bind (bits exp) (integer-decode-float x) (if (eql bits 0) - 0 - (let* ((int (if (minusp x) (- bits) bits)) - (digits (float-digits x)) - (ex (+ exp digits))) - (if (minusp ex) - (integer-/-integer int (ash 1 (+ digits (- ex)))) - (integer-/-integer (ash int ex) (ash 1 digits))))))) + 0 + (let* ((int (if (minusp x) (- bits) bits)) + (digits (float-digits x)) + (ex (+ exp digits))) + (if (minusp ex) + (integer-/-integer int (ash 1 (+ digits (- ex)))) + (integer-/-integer (ash int ex) (ash 1 digits))))))) ((rational) x))) ;;; This algorithm for RATIONALIZE, due to Bruno Haible, is included @@ -884,36 +884,36 @@ uninterruptibly frob the rounding modes & do ieee round-to-integer. ;; This is a fairly straigtforward implementation of the ;; iterative algorithm above. (multiple-value-bind (frac expo sign) - (integer-decode-float x) + (integer-decode-float x) (cond ((or (zerop frac) (>= expo 0)) - (if (minusp sign) - (- (ash frac expo)) - (ash frac expo))) - (t - ;; expo < 0 and (2*m-1) and (2*m+1) are coprime to 2^(1-e), - ;; so build the fraction up immediately, without having to do - ;; a gcd. - (let ((a (build-ratio (- (* 2 frac) 1) (ash 1 (- 1 expo)))) - (b (build-ratio (+ (* 2 frac) 1) (ash 1 (- 1 expo)))) - (p0 0) - (q0 1) - (p1 1) - (q1 0)) - (do ((c (ceiling a) (ceiling a))) - ((< c b) - (let ((top (+ (* c p1) p0)) - (bot (+ (* c q1) q0))) - (build-ratio (if (minusp sign) - (- top) - top) - bot))) - (let* ((k (- c 1)) - (p2 (+ (* k p1) p0)) - (q2 (+ (* k q1) q0))) - (psetf a (/ (- b k)) - b (/ (- a k))) - (setf p0 p1 - q0 q1 - p1 p2 - q1 q2)))))))) + (if (minusp sign) + (- (ash frac expo)) + (ash frac expo))) + (t + ;; expo < 0 and (2*m-1) and (2*m+1) are coprime to 2^(1-e), + ;; so build the fraction up immediately, without having to do + ;; a gcd. + (let ((a (build-ratio (- (* 2 frac) 1) (ash 1 (- 1 expo)))) + (b (build-ratio (+ (* 2 frac) 1) (ash 1 (- 1 expo)))) + (p0 0) + (q0 1) + (p1 1) + (q1 0)) + (do ((c (ceiling a) (ceiling a))) + ((< c b) + (let ((top (+ (* c p1) p0)) + (bot (+ (* c q1) q0))) + (build-ratio (if (minusp sign) + (- top) + top) + bot))) + (let* ((k (- c 1)) + (p2 (+ (* k p1) p0)) + (q2 (+ (* k q1) q0))) + (psetf a (/ (- b k)) + b (/ (- a k))) + (setf p0 p1 + q0 q1 + p1 p2 + q1 q2)))))))) ((rational) x))) diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 6a3506b..712e082 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -5,7 +5,7 @@ ;;; Define NAME as a fasl operation, with op-code FOP-CODE. PUSHP ;;; describes what the body does to the fop stack: ;;; T -;;; The body might pop the fop stack. The result of the body is +;;; The body might pop the fop stack. The result of the body is ;;; pushed on the fop stack. ;;; NIL ;;; The body might pop the fop stack. The result of the body is @@ -31,8 +31,8 @@ (when (and ocode (/= ocode code)) (error "multiple codes for fop name ~S: ~D and ~D" name code ocode))) (setf (svref *fop-names* code) name - (get name 'fop-code) code - (svref *fop-funs* code) (symbol-function name)) + (get name 'fop-code) code + (svref *fop-funs* code) (symbol-function name)) (values)) ;;; Define a pair of fops which are identical except that one reads @@ -43,14 +43,14 @@ ;;; value ranges went with which fop variant, and chose the correct ;;; fop code to use. Currently, since such logic isn't encapsulated, ;;; we see callers doing stuff like -;;; (cond ((and (< num-consts #x100) (< total-length #x10000)) -;;; (dump-fop 'sb!impl::fop-small-code file) -;;; (dump-byte num-consts file) -;;; (dump-integer-as-n-bytes total-length 2 file)) -;;; (t -;;; (dump-fop 'sb!impl::fop-code file) -;;; (dump-word num-consts file) -;;; (dump-word total-length file)))) +;;; (cond ((and (< num-consts #x100) (< total-length #x10000)) +;;; (dump-fop 'sb!impl::fop-small-code file) +;;; (dump-byte num-consts file) +;;; (dump-integer-as-n-bytes total-length 2 file)) +;;; (t +;;; (dump-fop 'sb!impl::fop-code file) +;;; (dump-word num-consts file) +;;; (dump-word total-length file)))) ;;; in several places. It would be cleaner if this could be replaced with ;;; something like ;;; (dump-fop file fop-code num-consts total-length) @@ -58,7 +58,7 @@ ;;; caller to know that it's a 1-byte-arg/4-byte-arg cloned fop pair, and to ;;; know both the 1-byte-arg and the 4-byte-arg fop names. -- WHN 19990902 (defmacro define-cloned-fops ((name code &key (pushp t) (stackp t)) - (small-name small-code) &rest forms) + (small-name small-code) &rest forms) (aver (member pushp '(nil t))) (aver (member stackp '(nil t))) `(progn @@ -76,7 +76,7 @@ (defun read-string-as-bytes (stream string &optional (length (length string))) (dotimes (i length) (setf (aref string i) - (sb!xc:code-char (read-byte stream)))) + (sb!xc:code-char (read-byte stream)))) ;; FIXME: The classic CMU CL code to do this was ;; (READ-N-BYTES FILE STRING START END). ;; It was changed for SBCL because we needed a portable version for @@ -89,11 +89,11 @@ #+sb-xc-host (bug "READ-STRING-AS-WORDS called") (dotimes (i length) (setf (aref string i) - (let ((code 0)) - ;; FIXME: is this the same as READ-WORD-ARG? - (dotimes (k sb!vm:n-word-bytes (sb!xc:code-char code)) - (setf code (logior code (ash (read-byte stream) - (* k sb!vm:n-byte-bits)))))))) + (let ((code 0)) + ;; FIXME: is this the same as READ-WORD-ARG? + (dotimes (k sb!vm:n-word-bytes (sb!xc:code-char code)) + (setf code (logior code (ash (read-byte stream) + (* k sb!vm:n-byte-bits)))))))) (values)) ;;;; miscellaneous fops @@ -140,26 +140,26 @@ (define-cloned-fops (fop-struct 48) (fop-small-struct 49) (let* ((size (clone-arg)) - (res (%make-instance size))) + (res (%make-instance size))) (declare (type index size)) (let* ((layout (pop-stack)) - (nuntagged (layout-n-untagged-slots layout)) - (ntagged (- size nuntagged))) + (nuntagged (layout-n-untagged-slots layout)) + (ntagged (- size nuntagged))) (setf (%instance-ref res 0) layout) (dotimes (n (1- ntagged)) - (declare (type index n)) - (setf (%instance-ref res (1+ n)) (pop-stack))) + (declare (type index n)) + (setf (%instance-ref res (1+ n)) (pop-stack))) (dotimes (n nuntagged) - (declare (type index n)) - (setf (%raw-instance-ref/word res (- nuntagged n 1)) (pop-stack)))) + (declare (type index n)) + (setf (%raw-instance-ref/word res (- nuntagged n 1)) (pop-stack)))) res)) (define-fop (fop-layout 45) (let ((nuntagged (pop-stack)) - (length (pop-stack)) - (depthoid (pop-stack)) - (inherits (pop-stack)) - (name (pop-stack))) + (length (pop-stack)) + (depthoid (pop-stack)) + (inherits (pop-stack)) + (name (pop-stack))) (find-and-init-or-check-layout name length inherits depthoid nuntagged))) (define-fop (fop-end-group 64 :stackp nil) @@ -183,36 +183,36 @@ ;;;; fops for loading symbols (macrolet (;; FIXME: Should all this code really be duplicated inside - ;; each fop? Perhaps it would be better for this shared - ;; code to live in FLET FROB1 and FLET FROB4 (for the - ;; two different sizes of counts). - (frob (name code name-size package) - (let ((n-package (gensym)) - (n-size (gensym)) - (n-buffer (gensym))) - `(define-fop (,name ,code) - (prepare-for-fast-read-byte *fasl-input-stream* - (let ((,n-package ,package) - (,n-size (fast-read-u-integer ,name-size))) - (when (> ,n-size (length *fasl-symbol-buffer*)) - (setq *fasl-symbol-buffer* - (make-string (* ,n-size 2)))) - (done-with-fast-read-byte) - (let ((,n-buffer *fasl-symbol-buffer*)) + ;; each fop? Perhaps it would be better for this shared + ;; code to live in FLET FROB1 and FLET FROB4 (for the + ;; two different sizes of counts). + (frob (name code name-size package) + (let ((n-package (gensym)) + (n-size (gensym)) + (n-buffer (gensym))) + `(define-fop (,name ,code) + (prepare-for-fast-read-byte *fasl-input-stream* + (let ((,n-package ,package) + (,n-size (fast-read-u-integer ,name-size))) + (when (> ,n-size (length *fasl-symbol-buffer*)) + (setq *fasl-symbol-buffer* + (make-string (* ,n-size 2)))) + (done-with-fast-read-byte) + (let ((,n-buffer *fasl-symbol-buffer*)) #+sb-xc-host - (read-string-as-bytes *fasl-input-stream* - ,n-buffer - ,n-size) + (read-string-as-bytes *fasl-input-stream* + ,n-buffer + ,n-size) #-sb-xc-host - (#!+sb-unicode read-string-as-words + (#!+sb-unicode read-string-as-words #!-sb-unicode read-string-as-bytes *fasl-input-stream* ,n-buffer ,n-size) - (push-fop-table (without-package-locks - (intern* ,n-buffer - ,n-size - ,n-package)))))))))) + (push-fop-table (without-package-locks + (intern* ,n-buffer + ,n-size + ,n-package)))))))))) ;; Note: CMU CL had FOP-SYMBOL-SAVE and FOP-SMALL-SYMBOL-SAVE, but ;; since they made the behavior of the fasloader depend on the @@ -229,10 +229,10 @@ ;; (SETF *PACKAGE* (FIND-PACKAGE :CL))) ;; which in CMU CL 2.4.9 defines a variable CL-USER::*FOO* instead of ;; defining CL::*FOO*. Therefore, we don't use those fops in SBCL. - ;;(frob fop-symbol-save 6 4 *package*) - ;;(frob fop-small-symbol-save 7 1 *package*) + ;;(frob fop-symbol-save 6 4 *package*) + ;;(frob fop-small-symbol-save 7 1 *package*) - (frob fop-lisp-symbol-save 75 #.sb!vm:n-word-bytes *cl-package*) + (frob fop-lisp-symbol-save 75 #.sb!vm:n-word-bytes *cl-package*) (frob fop-lisp-small-symbol-save 76 1 *cl-package*) (frob fop-keyword-symbol-save 77 #.sb!vm:n-word-bytes *keyword-package*) (frob fop-keyword-small-symbol-save 78 1 *keyword-package*) @@ -252,9 +252,9 @@ (svref *current-fop-table* (fast-read-u-integer 1)))) (define-cloned-fops (fop-uninterned-symbol-save 12) - (fop-uninterned-small-symbol-save 13) + (fop-uninterned-small-symbol-save 13) (let* ((arg (clone-arg)) - (res (make-string arg))) + (res (make-string arg))) #!-sb-unicode (read-string-as-bytes *fasl-input-stream* res) #!+sb-unicode @@ -271,13 +271,13 @@ (declare (fixnum length)) ;; #+cmu (declare (optimize (inhibit-warnings 2))) (do* ((index length (1- index)) - (byte 0 (read-byte *fasl-input-stream*)) - (result 0 (+ result (ash byte bits))) - (bits 0 (+ bits 8))) + (byte 0 (read-byte *fasl-input-stream*)) + (result 0 (+ result (ash byte bits))) + (bits 0 (+ bits 8))) ((= index 0) - (if (logbitp 7 byte) ; look at sign bit - (- result (ash 1 bits)) - result)) + (if (logbitp 7 byte) ; look at sign bit + (- result (ash 1 bits)) + result)) (declare (fixnum index byte bits)))) (define-cloned-fops (fop-integer 33) (fop-small-integer 34) @@ -347,8 +347,8 @@ (declare (type index n)))) (macrolet ((frob (name op fun n) - `(define-fop (,name ,op) - (call-with-popped-args ,fun ,n)))) + `(define-fop (,name ,op) + (call-with-popped-args ,fun ,n)))) (frob fop-list-1 17 list 1) (frob fop-list-2 18 list 2) @@ -372,7 +372,7 @@ (define-cloned-fops (fop-base-string 37) (fop-small-base-string 38) (let* ((arg (clone-arg)) - (res (make-string arg :element-type 'base-char))) + (res (make-string arg :element-type 'base-char))) (read-string-as-bytes *fasl-input-stream* res) res)) @@ -391,49 +391,49 @@ (define-cloned-fops (fop-vector 39) (fop-small-vector 40) (let* ((size (clone-arg)) - (res (make-array size))) + (res (make-array size))) (declare (fixnum size)) (do ((n (1- size) (1- n))) - ((minusp n)) + ((minusp n)) (setf (svref res n) (pop-stack))) res)) (define-fop (fop-array 83) (let* ((rank (read-word-arg)) - (vec (pop-stack)) - (length (length vec)) - (res (make-array-header sb!vm:simple-array-widetag rank))) + (vec (pop-stack)) + (length (length vec)) + (res (make-array-header sb!vm:simple-array-widetag rank))) (declare (simple-array vec) - (type (unsigned-byte #.(- sb!vm:n-word-bits sb!vm:n-widetag-bits)) rank)) + (type (unsigned-byte #.(- sb!vm:n-word-bits sb!vm:n-widetag-bits)) rank)) (set-array-header res vec length nil 0 - (do ((i rank (1- i)) - (dimensions () (cons (pop-stack) dimensions))) - ((zerop i) dimensions) - (declare (type index i))) - nil) + (do ((i rank (1- i)) + (dimensions () (cons (pop-stack) dimensions))) + ((zerop i) dimensions) + (declare (type index i))) + nil) res)) (define-fop (fop-single-float-vector 84) (let* ((length (read-word-arg)) - (result (make-array length :element-type 'single-float))) + (result (make-array length :element-type 'single-float))) (read-n-bytes *fasl-input-stream* result 0 (* length 4)) result)) (define-fop (fop-double-float-vector 85) (let* ((length (read-word-arg)) - (result (make-array length :element-type 'double-float))) + (result (make-array length :element-type 'double-float))) (read-n-bytes *fasl-input-stream* result 0 (* length 8)) result)) (define-fop (fop-complex-single-float-vector 86) (let* ((length (read-word-arg)) - (result (make-array length :element-type '(complex single-float)))) + (result (make-array length :element-type '(complex single-float)))) (read-n-bytes *fasl-input-stream* result 0 (* length 8)) result)) (define-fop (fop-complex-double-float-vector 87) (let* ((length (read-word-arg)) - (result (make-array length :element-type '(complex double-float)))) + (result (make-array length :element-type '(complex double-float)))) (read-n-bytes *fasl-input-stream* result 0 (* length 16)) result)) @@ -445,32 +445,32 @@ (define-fop (fop-int-vector 43) (prepare-for-fast-read-byte *fasl-input-stream* (let* ((len (fast-read-u-integer #.sb!vm:n-word-bytes)) - (size (fast-read-byte)) - (res (case size - (0 (make-array len :element-type 'nil)) - (1 (make-array len :element-type 'bit)) - (2 (make-array len :element-type '(unsigned-byte 2))) - (4 (make-array len :element-type '(unsigned-byte 4))) - (7 (prog1 (make-array len :element-type '(unsigned-byte 7)) - (setf size 8))) - (8 (make-array len :element-type '(unsigned-byte 8))) - (15 (prog1 (make-array len :element-type '(unsigned-byte 15)) - (setf size 16))) - (16 (make-array len :element-type '(unsigned-byte 16))) - (31 (prog1 (make-array len :element-type '(unsigned-byte 31)) - (setf size 32))) - (32 (make-array len :element-type '(unsigned-byte 32))) + (size (fast-read-byte)) + (res (case size + (0 (make-array len :element-type 'nil)) + (1 (make-array len :element-type 'bit)) + (2 (make-array len :element-type '(unsigned-byte 2))) + (4 (make-array len :element-type '(unsigned-byte 4))) + (7 (prog1 (make-array len :element-type '(unsigned-byte 7)) + (setf size 8))) + (8 (make-array len :element-type '(unsigned-byte 8))) + (15 (prog1 (make-array len :element-type '(unsigned-byte 15)) + (setf size 16))) + (16 (make-array len :element-type '(unsigned-byte 16))) + (31 (prog1 (make-array len :element-type '(unsigned-byte 31)) + (setf size 32))) + (32 (make-array len :element-type '(unsigned-byte 32))) #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) (63 (prog1 (make-array len :element-type '(unsigned-byte 63)) (setf size 64))) (64 (make-array len :element-type '(unsigned-byte 64))) - (t (bug "losing i-vector element size: ~S" size))))) + (t (bug "losing i-vector element size: ~S" size))))) (declare (type index len)) (done-with-fast-read-byte) (read-n-bytes *fasl-input-stream* - res - 0 - (ceiling (the index (* size len)) sb!vm:n-byte-bits)) + res + 0 + (ceiling (the index (* size len)) sb!vm:n-byte-bits)) res))) ;;; This is the same as FOP-INT-VECTOR, except this is for signed @@ -478,17 +478,17 @@ (define-fop (fop-signed-int-vector 50) (prepare-for-fast-read-byte *fasl-input-stream* (let* ((len (fast-read-u-integer #.sb!vm:n-word-bytes)) - (size (fast-read-byte)) - (res (case size - (8 (make-array len :element-type '(signed-byte 8))) - (16 (make-array len :element-type '(signed-byte 16))) + (size (fast-read-byte)) + (res (case size + (8 (make-array len :element-type '(signed-byte 8))) + (16 (make-array len :element-type '(signed-byte 16))) #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) - (29 (prog1 (make-array len :element-type '(unsigned-byte 29)) + (29 (prog1 (make-array len :element-type '(unsigned-byte 29)) (setf size 32))) #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) - (30 (prog1 (make-array len :element-type '(signed-byte 30)) + (30 (prog1 (make-array len :element-type '(signed-byte 30)) (setf size 32))) - (32 (make-array len :element-type '(signed-byte 32))) + (32 (make-array len :element-type '(signed-byte 32))) #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) (60 (prog1 (make-array len :element-type '(unsigned-byte 60)) (setf size 64))) @@ -497,13 +497,13 @@ (setf size 64))) #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) (64 (make-array len :element-type '(signed-byte 64))) - (t (bug "losing si-vector element size: ~S" size))))) + (t (bug "losing si-vector element size: ~S" size))))) (declare (type index len)) (done-with-fast-read-byte) (read-n-bytes *fasl-input-stream* - res - 0 - (ceiling (the index (* size len)) sb!vm:n-byte-bits)) + res + 0 + (ceiling (the index (* size len)) sb!vm:n-byte-bits)) res))) (define-fop (fop-eval 53) @@ -523,55 +523,55 @@ ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL. (declare (ignore result)) #+nil (when *load-print* - (load-fresh-line) - (prin1 result) - (terpri)))) + (load-fresh-line) + (prin1 result) + (terpri)))) (define-fop (fop-funcall 55) (let ((arg (read-byte-arg))) (if (zerop arg) - (funcall (pop-stack)) - (do ((args () (cons (pop-stack) args)) - (n arg (1- n))) - ((zerop n) (apply (pop-stack) args)) - (declare (type index n)))))) + (funcall (pop-stack)) + (do ((args () (cons (pop-stack) args)) + (n arg (1- n))) + ((zerop n) (apply (pop-stack) args)) + (declare (type index n)))))) (define-fop (fop-funcall-for-effect 56 :pushp nil) (let ((arg (read-byte-arg))) (if (zerop arg) - (funcall (pop-stack)) - (do ((args () (cons (pop-stack) args)) - (n arg (1- n))) - ((zerop n) (apply (pop-stack) args)) - (declare (type index n)))))) + (funcall (pop-stack)) + (do ((args () (cons (pop-stack) args)) + (n arg (1- n))) + ((zerop n) (apply (pop-stack) args)) + (declare (type index n)))))) ;;;; fops for fixing up circularities (define-fop (fop-rplaca 200 :pushp nil) (let ((obj (svref *current-fop-table* (read-word-arg))) - (idx (read-word-arg)) - (val (pop-stack))) + (idx (read-word-arg)) + (val (pop-stack))) (setf (car (nthcdr idx obj)) val))) (define-fop (fop-rplacd 201 :pushp nil) (let ((obj (svref *current-fop-table* (read-word-arg))) - (idx (read-word-arg)) - (val (pop-stack))) + (idx (read-word-arg)) + (val (pop-stack))) (setf (cdr (nthcdr idx obj)) val))) (define-fop (fop-svset 202 :pushp nil) (let* ((obi (read-word-arg)) - (obj (svref *current-fop-table* obi)) - (idx (read-word-arg)) - (val (pop-stack))) + (obj (svref *current-fop-table* obi)) + (idx (read-word-arg)) + (val (pop-stack))) (if (typep obj 'instance) - (setf (%instance-ref obj idx) val) - (setf (svref obj idx) val)))) + (setf (%instance-ref obj idx) val) + (setf (svref obj idx) val)))) (define-fop (fop-structset 204 :pushp nil) (setf (%instance-ref (svref *current-fop-table* (read-word-arg)) - (read-word-arg)) - (pop-stack))) + (read-word-arg)) + (pop-stack))) ;;; In the original CMUCL code, this actually explicitly declared PUSHP ;;; to be T, even though that's what it defaults to in DEFINE-FOP. @@ -619,13 +619,13 @@ bug.~:@>") ;; depend more strongly than in CMU CL on FOP-FSET actually doing ;; something.) (let ((fn (pop-stack)) - (name (pop-stack))) + (name (pop-stack))) (setf (fdefinition name) fn))) ;;; Modify a slot in a CONSTANTS object. (define-cloned-fops (fop-alter-code 140 :pushp nil) (fop-byte-alter-code 141) (let ((value (pop-stack)) - (code (pop-stack))) + (code (pop-stack))) (setf (code-header-ref code (clone-arg)) value) (values))) @@ -634,10 +634,10 @@ bug.~:@>") (error "FOP-FUN-ENTRY can't be defined without %PRIMITIVE.") #-sb-xc-host (let ((type (pop-stack)) - (arglist (pop-stack)) - (name (pop-stack)) - (code-object (pop-stack)) - (offset (read-word-arg))) + (arglist (pop-stack)) + (name (pop-stack)) + (code-object (pop-stack)) + (offset (read-word-arg))) (declare (type index offset)) (unless (zerop (logand offset sb!vm:lowtag-mask)) (bug "unaligned function object, offset = #X~X" offset)) @@ -650,8 +650,8 @@ bug.~:@>") (setf (%simple-fun-type fun) type) ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL. #+nil (when *load-print* - (load-fresh-line) - (format t "~S defined~%" fun)) + (load-fresh-line) + (format t "~S defined~%" fun)) fun))) ;;;; Some Dylan FOPs used to live here. By 1 November 1998 the code @@ -676,45 +676,45 @@ bug.~:@>") (define-fop (fop-foreign-fixup 147) (let* ((kind (pop-stack)) - (code-object (pop-stack)) - (len (read-byte-arg)) - (sym (make-string len :element-type 'base-char))) + (code-object (pop-stack)) + (len (read-byte-arg)) + (sym (make-string len :element-type 'base-char))) (read-n-bytes *fasl-input-stream* sym 0 len) (sb!vm:fixup-code-object code-object - (read-word-arg) - (foreign-symbol-address sym) - kind) + (read-word-arg) + (foreign-symbol-address sym) + kind) code-object)) (define-fop (fop-assembler-fixup 148) (let ((routine (pop-stack)) - (kind (pop-stack)) - (code-object (pop-stack))) + (kind (pop-stack)) + (code-object (pop-stack))) (multiple-value-bind (value found) (gethash routine *assembler-routines*) (unless found - (error "undefined assembler routine: ~S" routine)) + (error "undefined assembler routine: ~S" routine)) (sb!vm:fixup-code-object code-object (read-word-arg) value kind)) code-object)) (define-fop (fop-code-object-fixup 149) (let ((kind (pop-stack)) - (code-object (pop-stack))) + (code-object (pop-stack))) ;; Note: We don't have to worry about GC moving the code-object after ;; the GET-LISP-OBJ-ADDRESS and before that value is deposited, because ;; we can only use code-object fixups when code-objects don't move. (sb!vm:fixup-code-object code-object (read-word-arg) - (get-lisp-obj-address code-object) kind) + (get-lisp-obj-address code-object) kind) code-object)) #!+linkage-table (define-fop (fop-foreign-dataref-fixup 150) (let* ((kind (pop-stack)) - (code-object (pop-stack)) - (len (read-byte-arg)) - (sym (make-string len :element-type 'base-char))) + (code-object (pop-stack)) + (len (read-byte-arg)) + (sym (make-string len :element-type 'base-char))) (read-n-bytes *fasl-input-stream* sym 0 len) (sb!vm:fixup-code-object code-object - (read-word-arg) - (foreign-symbol-address sym t) - kind) + (read-word-arg) + (foreign-symbol-address sym t) + kind) code-object)) diff --git a/src/code/force-delayed-defbangmethods.lisp b/src/code/force-delayed-defbangmethods.lisp index 11eada3..5142087 100644 --- a/src/code/force-delayed-defbangmethods.lisp +++ b/src/code/force-delayed-defbangmethods.lisp @@ -10,20 +10,20 @@ (in-package "SB-IMPL") ;(SB-IMPL, not SB!IMPL, since we're built in warm load.) (macrolet ((force-delayed-def!methods () - `(progn - ,@(mapcar (lambda (args) - `(progn - #+sb-show - (format t - "~&/about to do ~S~%" - '(defmethod ,@args)) - (defmethod ,@args) - #+sb-show - (format t - "~&/done with DEFMETHOD ~S~%" - ',(first args)))) - *delayed-def!method-args*) - (defmacro def!method (&rest args) `(defmethod ,@args)) - ;; We're no longer needed, ordinary DEFMETHOD is enough now. - (makunbound '*delayed-def!method-args*)))) + `(progn + ,@(mapcar (lambda (args) + `(progn + #+sb-show + (format t + "~&/about to do ~S~%" + '(defmethod ,@args)) + (defmethod ,@args) + #+sb-show + (format t + "~&/done with DEFMETHOD ~S~%" + ',(first args)))) + *delayed-def!method-args*) + (defmacro def!method (&rest args) `(defmethod ,@args)) + ;; We're no longer needed, ordinary DEFMETHOD is enough now. + (makunbound '*delayed-def!method-args*)))) (force-delayed-def!methods)) diff --git a/src/code/foreign-load.lisp b/src/code/foreign-load.lisp index 197a3a7..74ce213 100644 --- a/src/code/foreign-load.lisp +++ b/src/code/foreign-load.lisp @@ -19,9 +19,9 @@ (define-unsupported-fun load-foreign "Unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT." - "~S is unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT." + "~S is unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT." (load-foreign)) - + (define-unsupported-fun load-1-foreign "Unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT." "~S is unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT." @@ -106,28 +106,28 @@ SB-EXT:SAVE-LISP-AND-DIE for details." (declare (type shared-object obj)) (tagbody :dlopen (restart-case - (dlopen-or-lose obj) + (dlopen-or-lose obj) (continue () - :report "Skip this shared object and continue." - (setf (shared-object-sap obj) nil)) + :report "Skip this shared object and continue." + (setf (shared-object-sap obj) nil)) (retry () - :report "Retry loading this shared object." - (go :dlopen)) + :report "Retry loading this shared object." + (go :dlopen)) (load-other () - :report "Specify an alternate shared object file to load." - (setf (shared-object-file obj) - (tagbody :query - (format *query-io* "~&Enter pathname (evaluated):~%") - (force-output *query-io*) - (let ((pathname (ignore-errors (pathname (read *query-io*))))) - (unless (pathnamep pathname) - (format *query-io* "~&Error: invalid pathname.~%") - (go :query)) - (unix-namestring pathname))))))) + :report "Specify an alternate shared object file to load." + (setf (shared-object-file obj) + (tagbody :query + (format *query-io* "~&Enter pathname (evaluated):~%") + (force-output *query-io*) + (let ((pathname (ignore-errors (pathname (read *query-io*))))) + (unless (pathnamep pathname) + (format *query-io* "~&Error: invalid pathname.~%") + (go :query)) + (unix-namestring pathname))))))) obj) ;;; Open libraries in *SHARED-OBJECTS* and the runtime. Called during -;;; initialization. +;;; initialization. (defun reopen-shared-objects () ;; Ensure that the runtime is open (setf *runtime-dlhandle* (dlopen-or-lose) @@ -140,23 +140,23 @@ SB-EXT:SAVE-LISP-AND-DIE for details." (dlclose-or-lose)) (defun find-dynamic-foreign-symbol-address (symbol) - (dlerror) ; clear old errors + (dlerror) ; clear old errors (unless *runtime-dlhandle* (bug "Cannot resolve foreign symbol: lost *runtime-dlhandle*")) ;; On real ELF & dlsym platforms the EXTERN-ALIEN-NAME is a no-op, ;; but on platforms where dlsym is simulated we use the mangled name. (let* ((extern (extern-alien-name symbol)) - (result (sap-int (dlsym *runtime-dlhandle* extern))) - (err (dlerror))) + (result (sap-int (dlsym *runtime-dlhandle* extern))) + (err (dlerror))) (if (or (not (zerop result)) (not err)) - result - (dolist (obj *shared-objects*) - (let ((sap (shared-object-sap obj))) - (when sap - (setf result (sap-int (dlsym sap extern)) - err (dlerror)) - (when (or (not (zerop result)) (not err)) - (return result)))))))) + result + (dolist (obj *shared-objects*) + (let ((sap (shared-object-sap obj))) + (when sap + (setf result (sap-int (dlsym sap extern)) + err (dlerror)) + (when (or (not (zerop result)) (not err)) + (return result)))))))) (let ((symbols (make-hash-table :test #'equal)) (undefineds (make-hash-table :test #'equal))) @@ -169,19 +169,19 @@ is never in the linkage-table." (declare (ignorable datap)) (let ((addr (find-dynamic-foreign-symbol-address symbol))) (cond #!-linkage-table - ((not addr) - (error 'undefined-alien-error :name symbol)) - #!+linkage-table - ((not addr) - (style-warn "Undefined alien: ~S" symbol) - (setf (gethash symbol undefineds) t) - (remhash symbol symbols) - (if datap - undefined-alien-address - (foreign-symbol-address "undefined_alien_function"))) + ((not addr) + (error 'undefined-alien-error :name symbol)) + #!+linkage-table + ((not addr) + (style-warn "Undefined alien: ~S" symbol) + (setf (gethash symbol undefineds) t) + (remhash symbol symbols) + (if datap + undefined-alien-address + (foreign-symbol-address "undefined_alien_function"))) (addr - (setf (gethash symbol symbols) t) - (remhash symbol undefineds) + (setf (gethash symbol symbols) t) + (remhash symbol undefineds) addr)))) (defun undefined-foreign-symbols-p () (plusp (hash-table-count undefineds))) @@ -189,5 +189,5 @@ is never in the linkage-table." (plusp (hash-table-count symbols))) (defun list-dynamic-foreign-symbols () (loop for symbol being each hash-key in symbols - collect symbol))) + collect symbol))) diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp index 86b9752..7503bda 100644 --- a/src/code/foreign.lisp +++ b/src/code/foreign.lisp @@ -28,13 +28,13 @@ (declaim (type hash-table *static-foreign-symbols*)) (defvar *static-foreign-symbols* (make-hash-table :test 'equal)) -(declaim +(declaim (ftype (sfunction (string hash-table) (or integer null)) find-foreign-symbol-in-table)) (defun find-foreign-symbol-in-table (name table) (let ((extern (extern-alien-name name))) - (values + (values (or (gethash extern table) - (gethash (concatenate 'base-string "ldso_stub__" extern) table))))) + (gethash (concatenate 'base-string "ldso_stub__" extern) table))))) (defun find-foreign-symbol-address (name) "Returns the address of the foreign symbol NAME, or NIL. Does not enter the @@ -56,19 +56,19 @@ On non-linkage-table ports signals an error if the symbol isn't found." (declare (ignorable datap)) (let ((static (find-foreign-symbol-in-table name *static-foreign-symbols*))) (if static - (values static nil) - #!+os-provides-dlopen - (progn - #-sb-xc-host - (values #!-linkage-table - (ensure-dynamic-foreign-symbol-address name) - #!+linkage-table - (ensure-foreign-symbol-linkage name datap) - t) - #+sb-xc-host - (error 'undefined-alien-error :name name)) - #!-os-provides-dlopen - (error 'undefined-alien-error :name name)))) + (values static nil) + #!+os-provides-dlopen + (progn + #-sb-xc-host + (values #!-linkage-table + (ensure-dynamic-foreign-symbol-address name) + #!+linkage-table + (ensure-foreign-symbol-linkage name datap) + t) + #+sb-xc-host + (error 'undefined-alien-error :name name)) + #!-os-provides-dlopen + (error 'undefined-alien-error :name name)))) (defun foreign-symbol-sap (symbol &optional datap) "Returns a SAP corresponding to the foreign symbol. DATAP must be true if the @@ -87,8 +87,8 @@ if the symbol isn't found." ;; we need to do a bit of juggling. It is not the address of the ;; variable, but the address where the real address is stored. (if (and sharedp datap) - (int-sap (sap-ref-word (int-sap addr) 0)) - (int-sap addr)))) + (int-sap (sap-ref-word (int-sap addr) 0)) + (int-sap addr)))) #-sb-xc-host (defun foreign-reinit () @@ -119,27 +119,27 @@ if the symbol isn't found." (declare (ignorable addr)) #!+linkage-table (when (<= sb!vm:linkage-table-space-start - addr - sb!vm:linkage-table-space-end) + addr + sb!vm:linkage-table-space-end) (maphash (lambda (name-and-datap info) - (let ((table-addr (linkage-info-address info))) - (when (<= table-addr - addr - (+ table-addr sb!vm:linkage-table-entry-size)) - (return-from sap-foreign-symbol (car name-and-datap))))) - *linkage-info*)) + (let ((table-addr (linkage-info-address info))) + (when (<= table-addr + addr + (+ table-addr sb!vm:linkage-table-entry-size)) + (return-from sap-foreign-symbol (car name-and-datap))))) + *linkage-info*)) #!+os-provides-dladdr (with-alien ((info (struct dl-info - (filename c-string) - (base unsigned) - (symbol c-string) - (symbol-address unsigned))) - (dladdr (function unsigned unsigned (* (struct dl-info))) - :extern "dladdr")) + (filename c-string) + (base unsigned) + (symbol c-string) + (symbol-address unsigned))) + (dladdr (function unsigned unsigned (* (struct dl-info))) + :extern "dladdr")) (let ((err (alien-funcall dladdr addr (addr info)))) - (if (zerop err) - nil - (slot info 'symbol)))) + (if (zerop err) + nil + (slot info 'symbol)))) ;; FIXME: Even in the absence of dladdr we could search the ;; static foreign symbols (and *linkage-info*, for that matter). )) diff --git a/src/code/format-time.lisp b/src/code/format-time.lisp index 9736122..147c15f 100644 --- a/src/code/format-time.lisp +++ b/src/code/format-time.lisp @@ -38,7 +38,7 @@ (eq destination t) (streamp destination) (and (stringp destination) - (array-has-fill-pointer-p destination)))) + (array-has-fill-pointer-p destination)))) ;;; CMU CL made the default style :SHORT here. I've changed that to :LONG, on ;;; the theory that since the 8/7/1999 style is hard to decode unambiguously, @@ -46,7 +46,7 @@ ;;; it sorts properly.:-) -- WHN 19990831 ;;; ;;; FIXME: On the CMU CL mailing list 30 Jan 2000, Pierre Mai suggested -;;; OTOH it probably wouldn't be a major problem to change compile-file to +;;; OTOH it probably wouldn't be a major problem to change compile-file to ;;; use for example :long, so that the output would be Month DD, YYYY, or ;;; even better to extend format-universal-time with a flag to output ISO ;;; 8601 formats (like e.g. :iso-8601 and :iso-8601-short) and migrate @@ -54,14 +54,14 @@ ;;; The :ISO-8601 and :ISO-8601-SHORT options sound sensible to me. Maybe ;;; someone will do them for CMU CL and we can steal them for SBCL. (defun format-universal-time (destination universal-time - &key - (timezone nil) - (style :long) - (date-first t) - (print-seconds t) - (print-meridian t) - (print-timezone t) - (print-weekday t)) + &key + (timezone nil) + (style :long) + (date-first t) + (print-seconds t) + (print-meridian t) + (print-timezone t) + (print-weekday t)) #!+sb-doc "Format-Universal-Time formats a string containing the time and date given by universal-time in a common manner. The destination is any @@ -85,84 +85,84 @@ (multiple-value-bind (secs mins hours day month year dow dst tz) (if timezone - (decode-universal-time universal-time timezone) - (decode-universal-time universal-time)) + (decode-universal-time universal-time timezone) + (decode-universal-time universal-time)) (declare (fixnum secs mins hours day month year dow)) (let ((time-string "~2,'0D:~2,'0D") - (date-string - (case style - (:short "~D/~D/~D") ;; MM/DD/Y - ((:abbreviated :long) "~A ~D, ~D") ;; Month DD, Y - (:government "~2,'0D ~:@(~A~) ~D") ;; DD MON Y - (t - (error "~A: Unrecognized :style keyword value." style)))) - (time-args - (list mins (max (mod hours 12) (1+ (mod (1- hours) 12))))) - (date-args (case style - (:short - (list month day year)) - (:abbreviated - (list (svref *abbrev-month-table* (1- month)) day year)) - (:long - (list (svref *long-month-table* (1- month)) day year)) - (:government - (list day (svref *abbrev-month-table* (1- month)) - year))))) + (date-string + (case style + (:short "~D/~D/~D") ;; MM/DD/Y + ((:abbreviated :long) "~A ~D, ~D") ;; Month DD, Y + (:government "~2,'0D ~:@(~A~) ~D") ;; DD MON Y + (t + (error "~A: Unrecognized :style keyword value." style)))) + (time-args + (list mins (max (mod hours 12) (1+ (mod (1- hours) 12))))) + (date-args (case style + (:short + (list month day year)) + (:abbreviated + (list (svref *abbrev-month-table* (1- month)) day year)) + (:long + (list (svref *long-month-table* (1- month)) day year)) + (:government + (list day (svref *abbrev-month-table* (1- month)) + year))))) (declare (simple-string time-string date-string)) (when print-weekday - (push (case style - ((:short :long) (svref *long-weekday-table* dow)) - (:abbreviated (svref *abbrev-weekday-table* dow)) - (:government (svref *abbrev-weekday-table* dow))) - date-args) - (setq date-string - (concatenate 'simple-string "~A, " date-string))) + (push (case style + ((:short :long) (svref *long-weekday-table* dow)) + (:abbreviated (svref *abbrev-weekday-table* dow)) + (:government (svref *abbrev-weekday-table* dow))) + date-args) + (setq date-string + (concatenate 'simple-string "~A, " date-string))) (when (or print-seconds (eq style :government)) - (push secs time-args) - (setq time-string - (concatenate 'simple-string time-string ":~2,'0D"))) + (push secs time-args) + (setq time-string + (concatenate 'simple-string time-string ":~2,'0D"))) (when print-meridian - (push (signum (floor hours 12)) time-args) - (setq time-string - (concatenate 'simple-string time-string " ~[AM~;PM~]"))) + (push (signum (floor hours 12)) time-args) + (setq time-string + (concatenate 'simple-string time-string " ~[AM~;PM~]"))) (apply #'format destination - (if date-first - (concatenate 'simple-string date-string " " time-string - (if print-timezone " ~A")) - (concatenate 'simple-string time-string " " date-string - (if print-timezone " ~A"))) - (if date-first - (nconc date-args (nreverse time-args) - (if print-timezone - (list (timezone-name dst tz)))) - (nconc (nreverse time-args) date-args - (if print-timezone - (list (timezone-name dst tz))))))))) + (if date-first + (concatenate 'simple-string date-string " " time-string + (if print-timezone " ~A")) + (concatenate 'simple-string time-string " " date-string + (if print-timezone " ~A"))) + (if date-first + (nconc date-args (nreverse time-args) + (if print-timezone + (list (timezone-name dst tz)))) + (nconc (nreverse time-args) date-args + (if print-timezone + (list (timezone-name dst tz))))))))) (defun timezone-name (dst tz) (if (and (integerp tz) - (or (and dst (= tz 0)) - (<= 5 tz 8))) + (or (and dst (= tz 0)) + (<= 5 tz 8))) (svref (if dst *daylight-table* *timezone-table*) tz) (multiple-value-bind (rest seconds) (truncate (* tz 60 60) 60) - (multiple-value-bind (hours minutes) (truncate rest 60) - (format nil "[~C~D~@[~*:~2,'0D~@[~*:~2,'0D~]~]]" - (if (minusp tz) #\- #\+) - (abs hours) - (not (and (zerop minutes) (zerop seconds))) - (abs minutes) - (not (zerop seconds)) - (abs seconds)))))) + (multiple-value-bind (hours minutes) (truncate rest 60) + (format nil "[~C~D~@[~*:~2,'0D~@[~*:~2,'0D~]~]]" + (if (minusp tz) #\- #\+) + (abs hours) + (not (and (zerop minutes) (zerop seconds))) + (abs minutes) + (not (zerop seconds)) + (abs seconds)))))) (defun format-decoded-time (destination seconds minutes hours - day month year - &key (timezone nil) - (style :short) - (date-first t) - (print-seconds t) - (print-meridian t) - (print-timezone t) - (print-weekday t)) + day month year + &key (timezone nil) + (style :short) + (date-first t) + (print-seconds t) + (print-meridian t) + (print-timezone t) + (print-weekday t)) #!+sb-doc "FORMAT-DECODED-TIME formats a string containing decoded time expressed in a humanly-readable manner. The destination is any @@ -191,7 +191,7 @@ (when timezone (unless (and (integerp timezone) (<= 0 timezone 32)) (error "~A: Timezone should be an integer between 0 and 32." - timezone))) + timezone))) (format-universal-time destination (encode-universal-time seconds minutes hours day month year) :timezone timezone :style style :date-first date-first diff --git a/src/code/function-names.lisp b/src/code/function-names.lisp index 0f0f743..029b795 100644 --- a/src/code/function-names.lisp +++ b/src/code/function-names.lisp @@ -6,9 +6,9 @@ (defun %define-fun-name-syntax (symbol checker) (let ((found (assoc symbol *valid-fun-names-alist* :test #'eq))) (if found - (setf (cdr found) checker) - (setq *valid-fun-names-alist* - (acons symbol checker *valid-fun-names-alist*))))) + (setf (cdr found) checker) + (setq *valid-fun-names-alist* + (acons symbol checker *valid-fun-names-alist*))))) (defmacro define-function-name-syntax (symbol (var) &body body) #!+sb-doc @@ -45,16 +45,16 @@ use as a BLOCK name in the function in question." (define-function-name-syntax setf (name) (when (and (cdr name) - (consp (cdr name))) + (consp (cdr name))) (destructuring-bind (fun &rest rest) (cdr name) (when (null rest) - (typecase fun - ;; ordinary (SETF FOO) case - (symbol (values t fun)) - ;; reasonable (SETF (QUUX BAZ)) case [but not (SETF (SETF - ;; FOO))] - (cons (unless (eq (car fun) 'setf) - (valid-function-name-p fun)))))))) + (typecase fun + ;; ordinary (SETF FOO) case + (symbol (values t fun)) + ;; reasonable (SETF (QUUX BAZ)) case [but not (SETF (SETF + ;; FOO))] + (cons (unless (eq (car fun) 'setf) + (valid-function-name-p fun)))))))) #-sb-xc-host (defun !function-names-cold-init () diff --git a/src/code/funutils.lisp b/src/code/funutils.lisp index ab85f44..456128f 100644 --- a/src/code/funutils.lisp +++ b/src/code/funutils.lisp @@ -22,12 +22,12 @@ "Return a new function that returns T whenever FUNCTION returns NIL and NIL whenever FUNCTION returns non-NIL." (lambda (&optional (arg0 nil arg0-p) (arg1 nil arg1-p) (arg2 nil arg2-p) - &rest more-args) + &rest more-args) (not (cond (more-args (apply function arg0 arg1 arg2 more-args)) - (arg2-p (funcall function arg0 arg1 arg2)) - (arg1-p (funcall function arg0 arg1)) - (arg0-p (funcall function arg0)) - (t (funcall function)))))) + (arg2-p (funcall function arg0 arg1 arg2)) + (arg1-p (funcall function arg0 arg1)) + (arg0-p (funcall function arg0)) + (t (funcall function)))))) (defun constantly (value) #!+sb-doc diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 1acfa9c..a41dec0 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -14,7 +14,7 @@ ;;;; DYNAMIC-USAGE and friends (declaim (special sb!vm:*read-only-space-free-pointer* - sb!vm:*static-space-free-pointer*)) + sb!vm:*static-space-free-pointer*)) (eval-when (:compile-toplevel :execute) (sb!xc:defmacro def-c-var-fun (lisp-fun c-var-name) @@ -67,17 +67,17 @@ (format t "Control stack usage is: ~10:D bytes.~%" (control-stack-usage)) (format t "Binding stack usage is: ~10:D bytes.~%" (binding-stack-usage)) #!+sb-thread - (format t - "Control and binding stack usage is for the current thread only.~%") + (format t + "Control and binding stack usage is for the current thread only.~%") (format t "Garbage collection is currently ~:[enabled~;DISABLED~].~%" - (> *gc-inhibit* 0))) + (> *gc-inhibit* 0))) (defun room-intermediate-info () (room-minimal-info) (sb!vm:memory-usage :count-spaces '(:dynamic) - :print-spaces t - :cutoff 0.05f0 - :print-summary nil)) + :print-spaces t + :cutoff 0.05f0 + :print-summary nil)) (defun room-maximal-info () ;; FIXME: SB!VM:INSTANCE-USAGE calls suppressed until bug 344 is fixed @@ -168,8 +168,8 @@ environment these hooks may run in any thread.") (declaim (type (or index null) *gc-trigger*)) (defvar *gc-trigger* nil) -;;; When T, indicates that a GC should have happened but did not due to -;;; *GC-INHIBIT*. +;;; When T, indicates that a GC should have happened but did not due to +;;; *GC-INHIBIT*. (defvar *need-to-collect-garbage* nil) ; initialized in cold init ;;;; internal GC @@ -190,7 +190,7 @@ environment these hooks may run in any thread.") ;;;; SUB-GC ;;; SUB-GC does a garbage collection. This is called from three places: -;;; (1) The C runtime will call here when it detects that we've consed +;;; (1) The C runtime will call here when it detects that we've consed ;;; enough to exceed the gc trigger threshold. This is done in ;;; alloc() for gencgc or interrupt_maybe_gc() for cheneygc ;;; (2) The user may request a collection using GC, below @@ -204,7 +204,7 @@ environment these hooks may run in any thread.") ;;; For GENCGC all generations < GEN will be GC'ed. -(defvar *already-in-gc* +(defvar *already-in-gc* (sb!thread:make-mutex :name "GC lock") "ID of thread running SUB-GC") (defun sub-gc (&key (gen 0)) @@ -216,35 +216,35 @@ environment these hooks may run in any thread.") (setf *need-to-collect-garbage* t) (when (zerop *gc-inhibit*) (sb!thread:with-mutex (*already-in-gc*) - (let ((old-usage (dynamic-usage)) - (new-usage 0)) - (unsafe-clear-roots) - ;; We need to disable interrupts for GC, but we also want - ;; to run as little as possible without them. - (without-interrupts - (gc-stop-the-world) - (collect-garbage gen) - (setf *need-to-collect-garbage* nil - new-usage (dynamic-usage)) - (gc-start-the-world)) - ;; Interrupts re-enabled, but still inside the mutex. - ;; In a multithreaded environment the other threads will - ;; see *n-b-f-o-p* change a little late, but that's OK. - (let ((freed (- old-usage new-usage))) - ;; GENCGC occasionally reports negative here, but the - ;; current belief is that it is part of the normal order - ;; of things and not a bug. - (when (plusp freed) - (incf *n-bytes-freed-or-purified* freed))))) + (let ((old-usage (dynamic-usage)) + (new-usage 0)) + (unsafe-clear-roots) + ;; We need to disable interrupts for GC, but we also want + ;; to run as little as possible without them. + (without-interrupts + (gc-stop-the-world) + (collect-garbage gen) + (setf *need-to-collect-garbage* nil + new-usage (dynamic-usage)) + (gc-start-the-world)) + ;; Interrupts re-enabled, but still inside the mutex. + ;; In a multithreaded environment the other threads will + ;; see *n-b-f-o-p* change a little late, but that's OK. + (let ((freed (- old-usage new-usage))) + ;; GENCGC occasionally reports negative here, but the + ;; current belief is that it is part of the normal order + ;; of things and not a bug. + (when (plusp freed) + (incf *n-bytes-freed-or-purified* freed))))) ;; Outside the mutex, these may cause another GC. FIXME: it can ;; potentially exceed maximum interrupt nesting by triggering ;; GCs. (run-pending-finalizers) (dolist (hook *after-gc-hooks*) - (handler-case - (funcall hook) - (error (c) - (warn "Error calling after GC hook ~S:~% ~S" hook c))))))) + (handler-case + (funcall hook) + (error (c) + (warn "Error calling after GC hook ~S:~% ~S" hook c))))))) ;;; This is the user-advertised garbage collection function. (defun gc (&key (gen 0) (full nil) &allow-other-keys) @@ -273,13 +273,13 @@ environment these hooks may run in any thread.") "Return the amount of memory that will be allocated before the next garbage collection is initiated. This can be set with SETF." (sb!alien:extern-alien "bytes_consed_between_gcs" - (sb!alien:unsigned 32))) + (sb!alien:unsigned 32))) (defun (setf bytes-consed-between-gcs) (val) (declare (type index val)) (setf (sb!alien:extern-alien "bytes_consed_between_gcs" - (sb!alien:unsigned 32)) - val)) + (sb!alien:unsigned 32)) + val)) ;;; FIXME: Aren't these utterly wrong if called inside WITHOUT-GCING? ;;; Unless something that works there too can be deviced this fact diff --git a/src/code/globals.lisp b/src/code/globals.lisp index 3fa2a75..6ce764e 100644 --- a/src/code/globals.lisp +++ b/src/code/globals.lisp @@ -16,29 +16,29 @@ (in-package "SB!IMPL") (declaim (special *keyword-package* *cl-package* - original-lisp-environment - *standard-readtable* - sb!debug:*in-the-debugger* - sb!debug:*stack-top-hint* - *handler-clusters* - *restart-clusters* - *gc-inhibit* *need-to-collect-garbage* - *software-interrupt-vector* *load-verbose* - *load-print-stuff* *in-compilation-unit* - *aborted-compilation-unit-count* *char-name-alist* - *posix-argv*)) + original-lisp-environment + *standard-readtable* + sb!debug:*in-the-debugger* + sb!debug:*stack-top-hint* + *handler-clusters* + *restart-clusters* + *gc-inhibit* *need-to-collect-garbage* + *software-interrupt-vector* *load-verbose* + *load-print-stuff* *in-compilation-unit* + *aborted-compilation-unit-count* *char-name-alist* + *posix-argv*)) (declaim (ftype (function * *) - find-keyword keyword-test assert-error - assert-prompt check-type-error case-body-error print-object - describe-object sb!pcl::check-wrapper-validity)) + find-keyword keyword-test assert-error + assert-prompt check-type-error case-body-error print-object + describe-object sb!pcl::check-wrapper-validity)) ;;; Gray streams functions not defined until after PCL is loaded (declaim (ftype (function * *) - stream-advance-to-column stream-clear-input - stream-clear-output stream-finish-output stream-force-output - stream-fresh-line stream-line-column stream-line-length - stream-listen stream-peek-char stream-read-byte - stream-read-char stream-read-char-no-hang stream-read-line - stream-start-line-p stream-terpri stream-unread-char - stream-write-byte stream-write-char stream-write-string)) + stream-advance-to-column stream-clear-input + stream-clear-output stream-finish-output stream-force-output + stream-fresh-line stream-line-column stream-line-length + stream-listen stream-peek-char stream-read-byte + stream-read-char stream-read-char-no-hang stream-read-line + stream-start-line-p stream-terpri stream-unread-char + stream-write-byte stream-write-char stream-write-string)) diff --git a/src/code/hash-table.lisp b/src/code/hash-table.lisp index 8a79e0e..db58433 100644 --- a/src/code/hash-table.lisp +++ b/src/code/hash-table.lisp @@ -28,7 +28,7 @@ ;; then add that amount. If a floating point number, then multiply ;; it by that. (rehash-size (missing-arg) :type (or index (single-float (1.0))) - :read-only t) + :read-only t) ;; how full the hash table has to get before we rehash (rehash-threshold (missing-arg) :type (single-float (0.0) 1.0) :read-only t) ;; The number of entries before a rehash, just one less than the @@ -54,19 +54,19 @@ ;; The index vector. This may be larger than the hash size to help ;; reduce collisions. (index-vector (missing-arg) - :type (simple-array (unsigned-byte #.sb!vm:n-word-bits) (*))) + :type (simple-array (unsigned-byte #.sb!vm:n-word-bits) (*))) ;; This table parallels the KV vector, and is used to chain together ;; the hash buckets, the free list, and the values needing rehash, a ;; slot will only ever be in one of these lists. (next-vector (missing-arg) - :type (simple-array (unsigned-byte #.sb!vm:n-word-bits) (*))) + :type (simple-array (unsigned-byte #.sb!vm:n-word-bits) (*))) ;; This table parallels the KV table, and can be used to store the ;; hash associated with the key, saving recalculation. Could be ;; useful for EQL, and EQUAL hash tables. This table is not needed ;; for EQ hash tables, and when present the value of #x80000000 ;; represents EQ-based hashing on the respective key. (hash-vector nil :type (or null (simple-array (unsigned-byte - #.sb!vm:n-word-bits) (*))))) + #.sb!vm:n-word-bits) (*))))) (defmacro-mundanely with-hash-table-iterator ((function hash-table) &body body) #!+sb-doc @@ -78,23 +78,23 @@ the second and third values are the key and the value of the next object." (let ((n-function (gensym "WITH-HASH-TABLE-ITERATOR-"))) `(let ((,n-function - (let* ((table ,hash-table) - (length (length (hash-table-next-vector table))) - (index 1)) - (declare (type (mod #.(floor most-positive-fixnum 2)) index)) - (labels - ((,function () - ;; (We grab the table again on each iteration just in - ;; case it was rehashed by a PUTHASH.) - (let ((kv-vector (hash-table-table table))) - (do () - ((>= index length) (values nil)) - (let ((key (aref kv-vector (* 2 index))) - (value (aref kv-vector (1+ (* 2 index))))) - (incf index) - (unless (and (eq key +empty-ht-slot+) - (eq value +empty-ht-slot+)) - (return (values t key value)))))))) - #',function)))) + (let* ((table ,hash-table) + (length (length (hash-table-next-vector table))) + (index 1)) + (declare (type (mod #.(floor most-positive-fixnum 2)) index)) + (labels + ((,function () + ;; (We grab the table again on each iteration just in + ;; case it was rehashed by a PUTHASH.) + (let ((kv-vector (hash-table-table table))) + (do () + ((>= index length) (values nil)) + (let ((key (aref kv-vector (* 2 index))) + (value (aref kv-vector (1+ (* 2 index))))) + (incf index) + (unless (and (eq key +empty-ht-slot+) + (eq value +empty-ht-slot+)) + (return (values t key value)))))))) + #',function)))) (macrolet ((,function () '(funcall ,n-function))) - ,@body)))) + ,@body)))) diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 9c343d5..56e743d 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -22,11 +22,11 @@ (defun guess-alignment (bits) (cond ((null bits) nil) - #!-(or x86 (and ppc darwin)) ((> bits 32) 64) - ((> bits 16) 32) - ((> bits 8) 16) - ((> bits 1) 8) - (t 1))) + #!-(or x86 (and ppc darwin)) ((> bits 32) 64) + ((> bits 16) 32) + ((> bits 8) 16) + ((> bits 1) 8) + (t 1))) ;;;; ALIEN-TYPE-INFO stuff @@ -57,11 +57,11 @@ (defun create-alien-type-class-if-necessary (name include) (let ((old (gethash name *alien-type-classes*)) - (include (and include (alien-type-class-or-lose include)))) + (include (and include (alien-type-class-or-lose include)))) (if old - (setf (alien-type-class-include old) include) - (setf (gethash name *alien-type-classes*) - (make-alien-type-class :name name :include include))))) + (setf (alien-type-class-include old) include) + (setf (gethash name *alien-type-classes*) + (make-alien-type-class :name name :include include))))) (defparameter *method-slot-alist* '((:unparse . alien-type-class-unparse) @@ -79,67 +79,67 @@ (defun method-slot (method) (cdr (or (assoc method *method-slot-alist*) - (error "no method ~S" method)))) + (error "no method ~S" method)))) ) ; EVAL-WHEN ;;; We define a keyword "BOA" constructor so that we can reference the ;;; slot names in init forms. (def!macro define-alien-type-class ((name &key include include-args) - &rest slots) + &rest slots) (let ((defstruct-name (symbolicate "ALIEN-" name "-TYPE"))) (multiple-value-bind (include include-defstruct overrides) - (etypecase include - (null - (values nil 'alien-type nil)) - (symbol - (values - include - (symbolicate "ALIEN-" include "-TYPE") - nil)) - (list - (values - (car include) - (symbolicate "ALIEN-" (car include) "-TYPE") - (cdr include)))) + (etypecase include + (null + (values nil 'alien-type nil)) + (symbol + (values + include + (symbolicate "ALIEN-" include "-TYPE") + nil)) + (list + (values + (car include) + (symbolicate "ALIEN-" (car include) "-TYPE") + (cdr include)))) `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (create-alien-type-class-if-necessary ',name ',(or include 'root))) - (def!struct (,defstruct-name - (:include ,include-defstruct - (class ',name) - ,@overrides) - (:constructor - ,(symbolicate "MAKE-" defstruct-name) - (&key class bits alignment - ,@(mapcar (lambda (x) - (if (atom x) x (car x))) - slots) - ,@include-args - ;; KLUDGE - &aux (alignment (or alignment (guess-alignment bits)))))) - ,@slots))))) + (eval-when (:compile-toplevel :load-toplevel :execute) + (create-alien-type-class-if-necessary ',name ',(or include 'root))) + (def!struct (,defstruct-name + (:include ,include-defstruct + (class ',name) + ,@overrides) + (:constructor + ,(symbolicate "MAKE-" defstruct-name) + (&key class bits alignment + ,@(mapcar (lambda (x) + (if (atom x) x (car x))) + slots) + ,@include-args + ;; KLUDGE + &aux (alignment (or alignment (guess-alignment bits)))))) + ,@slots))))) (def!macro define-alien-type-method ((class method) lambda-list &rest body) (let ((defun-name (symbolicate class "-" method "-METHOD"))) `(progn (defun ,defun-name ,lambda-list - ,@body) + ,@body) (setf (,(method-slot method) (alien-type-class-or-lose ',class)) - #',defun-name)))) + #',defun-name)))) (def!macro invoke-alien-type-method (method type &rest args) (let ((slot (method-slot method))) (once-only ((type type)) `(funcall (do ((class (alien-type-class-or-lose (alien-type-class ,type)) - (alien-type-class-include class))) - ((null class) - (error "method ~S not defined for ~S" - ',method (alien-type-class ,type))) - (let ((fn (,slot class))) - (when fn - (return fn)))) - ,type ,@args)))) + (alien-type-class-include class))) + ((null class) + (error "method ~S not defined for ~S" + ',method (alien-type-class ,type))) + (let ((fn (,slot class))) + (when fn + (return fn)))) + ,type ,@args)))) ;;;; type parsing and unparsing @@ -150,21 +150,21 @@ (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun auxiliary-type-definitions (env) (multiple-value-bind (result expanded-p) - (sb!xc:macroexpand '&auxiliary-type-definitions& env) + (sb!xc:macroexpand '&auxiliary-type-definitions& env) (if expanded-p - result - ;; This is like having the global symbol-macro definition be - ;; NIL, but global symbol-macros make me vaguely queasy, so - ;; I do it this way instead. - nil)))) + result + ;; This is like having the global symbol-macro definition be + ;; NIL, but global symbol-macros make me vaguely queasy, so + ;; I do it this way instead. + nil)))) ;;; Process stuff in a new scope. (def!macro with-auxiliary-alien-types (env &body body) ``(symbol-macrolet ((&auxiliary-type-definitions& - ,(append *new-auxiliary-types* - (auxiliary-type-definitions ,env)))) + ,(append *new-auxiliary-types* + (auxiliary-type-definitions ,env)))) ,(let ((*new-auxiliary-types* nil)) - ,@body))) + ,@body))) ;;; Parse TYPE as an alien type specifier and return the resultant ;;; ALIEN-TYPE structure. @@ -172,42 +172,42 @@ (declare (type (or sb!kernel:lexenv null) env)) (if (consp type) (let ((translator (info :alien-type :translator (car type)))) - (unless translator - (error "unknown alien type: ~S" type)) - (funcall translator type env)) + (unless translator + (error "unknown alien type: ~S" type)) + (funcall translator type env)) (ecase (info :alien-type :kind type) - (:primitive - (let ((translator (info :alien-type :translator type))) - (unless translator - (error "no translator for primitive alien type ~S" type)) - (funcall translator (list type) env))) - (:defined - (or (info :alien-type :definition type) - (error "no definition for alien type ~S" type))) - (:unknown - (error "unknown alien type: ~S" type))))) + (:primitive + (let ((translator (info :alien-type :translator type))) + (unless translator + (error "no translator for primitive alien type ~S" type)) + (funcall translator (list type) env))) + (:defined + (or (info :alien-type :definition type) + (error "no definition for alien type ~S" type))) + (:unknown + (error "unknown alien type: ~S" type))))) (defun auxiliary-alien-type (kind name env) (declare (type (or sb!kernel:lexenv null) env)) (flet ((aux-defn-matches (x) - (and (eq (first x) kind) (eq (second x) name)))) + (and (eq (first x) kind) (eq (second x) name)))) (let ((in-auxiliaries - (or (find-if #'aux-defn-matches *new-auxiliary-types*) - (find-if #'aux-defn-matches (auxiliary-type-definitions env))))) + (or (find-if #'aux-defn-matches *new-auxiliary-types*) + (find-if #'aux-defn-matches (auxiliary-type-definitions env))))) (if in-auxiliaries - (values (third in-auxiliaries) t) - (ecase kind - (:struct - (info :alien-type :struct name)) - (:union - (info :alien-type :union name)) - (:enum - (info :alien-type :enum name))))))) + (values (third in-auxiliaries) t) + (ecase kind + (:struct + (info :alien-type :struct name)) + (:union + (info :alien-type :union name)) + (:enum + (info :alien-type :enum name))))))) (defun (setf auxiliary-alien-type) (new-value kind name env) (declare (type (or sb!kernel:lexenv null) env)) (flet ((aux-defn-matches (x) - (and (eq (first x) kind) (eq (second x) name)))) + (and (eq (first x) kind) (eq (second x) name)))) (when (find-if #'aux-defn-matches *new-auxiliary-types*) (error "attempt to multiply define ~A ~S" kind name)) (when (find-if #'aux-defn-matches (auxiliary-type-definitions env)) @@ -220,13 +220,13 @@ (destructuring-bind (kind name defn) info (declare (ignore defn)) (when (ecase kind - (:struct - (info :alien-type :struct name)) - (:union - (info :alien-type :union name)) - (:enum - (info :alien-type :enum name))) - (error "attempt to shadow definition of ~A ~S" kind name))))) + (:struct + (info :alien-type :struct name)) + (:union + (info :alien-type :union name)) + (:enum + (info :alien-type :enum name))) + (error "attempt to shadow definition of ~A ~S" kind name))))) (defun unparse-alien-type (type) #!+sb-doc @@ -248,16 +248,16 @@ (with-unique-names (whole env) (let ((defun-name (symbolicate "ALIEN-" name "-TYPE-TRANSLATOR"))) (multiple-value-bind (body decls docs) - (sb!kernel:parse-defmacro lambda-list whole body name - 'define-alien-type-translator - :environment env) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defun ,defun-name (,whole ,env) - (declare (ignorable ,env)) - ,@decls - (block ,name - ,body)) - (%define-alien-type-translator ',name #',defun-name ,docs)))))) + (sb!kernel:parse-defmacro lambda-list whole body name + 'define-alien-type-translator + :environment env) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defun ,defun-name (,whole ,env) + (declare (ignorable ,env)) + ,@decls + (block ,name + ,body)) + (%define-alien-type-translator ',name #',defun-name ,docs)))))) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun %define-alien-type-translator (name translator docs) @@ -277,10 +277,10 @@ (with-auxiliary-alien-types env (let ((alien-type (parse-alien-type type env))) `(eval-when (:compile-toplevel :load-toplevel :execute) - ,@(when *new-auxiliary-types* - `((%def-auxiliary-alien-types ',*new-auxiliary-types*))) - ,@(when name - `((%define-alien-type ',name ',alien-type))))))) + ,@(when *new-auxiliary-types* + `((%def-auxiliary-alien-types ',*new-auxiliary-types*))) + ,@(when name + `((%define-alien-type ',name ',alien-type))))))) (def!macro def-alien-type (&rest rest) (deprecation-warning 'def-alien-type 'define-alien-type) `(define-alien-type ,@rest)) @@ -293,33 +293,33 @@ ;; Unless this is done we never actually get back the full type ;; from INFO, since the *new-auxiliary-types* have precendence. (setf *new-auxiliary-types* - (remove info *new-auxiliary-types* - :test (lambda (a b) - (and (eq (first a) (first b)) - (eq (second a) (second b)))))) + (remove info *new-auxiliary-types* + :test (lambda (a b) + (and (eq (first a) (first b)) + (eq (second a) (second b)))))) (destructuring-bind (kind name defn) info - (macrolet ((frob (kind) - `(let ((old (info :alien-type ,kind name))) - (unless (or (null old) (alien-type-= old defn)) - (warn - "redefining ~A ~S to be:~% ~S,~%was:~% ~S" - kind name defn old)) - (setf (info :alien-type ,kind name) defn)))) - (ecase kind - (:struct (frob :struct)) - (:union (frob :union)) - (:enum (frob :enum))))))) + (macrolet ((frob (kind) + `(let ((old (info :alien-type ,kind name))) + (unless (or (null old) (alien-type-= old defn)) + (warn + "redefining ~A ~S to be:~% ~S,~%was:~% ~S" + kind name defn old)) + (setf (info :alien-type ,kind name) defn)))) + (ecase kind + (:struct (frob :struct)) + (:union (frob :union)) + (:enum (frob :enum))))))) (defun %define-alien-type (name new) (ecase (info :alien-type :kind name) (:primitive (error "~S is a built-in alien type." name)) (:defined (let ((old (info :alien-type :definition name))) - (unless (or (null old) (alien-type-= new old)) - (warn "redefining ~S to be:~% ~S,~%was~% ~S" - name - (unparse-alien-type new) - (unparse-alien-type old))))) + (unless (or (null old) (alien-type-= new old)) + (warn "redefining ~S to be:~% ~S,~%was~% ~S" + name + (unparse-alien-type new) + (unparse-alien-type old))))) (:unknown)) (setf (info :alien-type :definition name) new) (setf (info :alien-type :kind name) :defined) @@ -331,9 +331,9 @@ (create-alien-type-class-if-necessary 'root nil)) (def!struct (alien-type - (:make-load-form-fun sb!kernel:just-dump-it-normally) - (:constructor make-alien-type (&key class bits alignment - &aux (alignment (or alignment (guess-alignment bits)))))) + (:make-load-form-fun sb!kernel:just-dump-it-normally) + (:constructor make-alien-type (&key class bits alignment + &aux (alignment (or alignment (guess-alignment bits)))))) (class 'root :type symbol) (bits nil :type (or null unsigned-byte)) (alignment nil :type (or null unsigned-byte))) @@ -394,7 +394,7 @@ ;;; ;;; Information describing a heap-allocated alien. (def!struct (heap-alien-info - (:make-load-form-fun sb!kernel:just-dump-it-normally)) + (:make-load-form-fun sb!kernel:just-dump-it-normally)) ;; The type of this alien. (type (missing-arg) :type alien-type) ;; The form to evaluate to produce the SAP pointing to where in the heap @@ -403,9 +403,9 @@ (def!method print-object ((info heap-alien-info) stream) (print-unreadable-object (info stream :type t) (funcall (formatter "~S ~S") - stream - (heap-alien-info-sap-form info) - (unparse-alien-type (heap-alien-info-type info))))) + stream + (heap-alien-info-sap-form info) + (unparse-alien-type (heap-alien-info-type info))))) ;;;; Interfaces to the different methods @@ -414,8 +414,8 @@ "Return T iff TYPE1 and TYPE2 describe equivalent alien types." (or (eq type1 type2) (and (eq (alien-type-class type1) - (alien-type-class type2)) - (invoke-alien-type-method :type= type1 type2)))) + (alien-type-class type2)) + (invoke-alien-type-method :type= type1 type2)))) (defun alien-subtype-p (type1 type2) #!+sb-doc @@ -439,26 +439,26 @@ (invoke-alien-type-method :deport-gen type 'value) `(lambda (value ignore) (declare (type ,(or value-type - (compute-lisp-rep-type type) - `(alien ,type)) - value) - (ignore ignore)) + (compute-lisp-rep-type type) + `(alien ,type)) + value) + (ignore ignore)) ,form))) (defun compute-extract-lambda (type) `(lambda (sap offset ignore) (declare (type system-area-pointer sap) - (type unsigned-byte offset) - (ignore ignore)) + (type unsigned-byte offset) + (ignore ignore)) (naturalize ,(invoke-alien-type-method :extract-gen type 'sap 'offset) - ',type))) + ',type))) (defun compute-deposit-lambda (type) (declare (type alien-type type)) `(lambda (sap offset ignore value) (declare (type system-area-pointer sap) - (type unsigned-byte offset) - (ignore ignore)) + (type unsigned-byte offset) + (ignore ignore)) (let ((value (deport value ',type))) ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value) ;; Note: the reason we don't just return the pre-deported value @@ -512,12 +512,12 @@ (define-alien-type-method (root :arg-tn) (type state) (declare (ignore state)) (error "Aliens of type ~S cannot be passed as arguments to CALL-OUT." - (unparse-alien-type type))) + (unparse-alien-type type))) (define-alien-type-method (root :result-tn) (type state) (declare (ignore state)) (error "Aliens of type ~S cannot be returned from CALL-OUT." - (unparse-alien-type type))) + (unparse-alien-type type))) ;;;; the INTEGER type @@ -535,21 +535,21 @@ (define-alien-type-method (integer :unparse) (type) (list (if (alien-integer-type-signed type) 'signed 'unsigned) - (alien-integer-type-bits type))) + (alien-integer-type-bits type))) (define-alien-type-method (integer :type=) (type1 type2) (and (eq (alien-integer-type-signed type1) - (alien-integer-type-signed type2)) + (alien-integer-type-signed type2)) (= (alien-integer-type-bits type1) - (alien-integer-type-bits type2)))) + (alien-integer-type-bits type2)))) (define-alien-type-method (integer :lisp-rep) (type) (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) - (alien-integer-type-bits type))) + (alien-integer-type-bits type))) (define-alien-type-method (integer :alien-rep) (type) (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) - (alien-integer-type-bits type))) + (alien-integer-type-bits type))) (define-alien-type-method (integer :naturalize-gen) (type alien) (declare (ignore type)) @@ -562,21 +562,21 @@ (define-alien-type-method (integer :extract-gen) (type sap offset) (declare (type alien-integer-type type)) (let ((ref-fun - (if (alien-integer-type-signed type) - (case (alien-integer-type-bits type) - (8 'signed-sap-ref-8) - (16 'signed-sap-ref-16) - (32 'signed-sap-ref-32) - (64 'signed-sap-ref-64)) - (case (alien-integer-type-bits type) - (8 'sap-ref-8) - (16 'sap-ref-16) - (32 'sap-ref-32) - (64 'sap-ref-64))))) + (if (alien-integer-type-signed type) + (case (alien-integer-type-bits type) + (8 'signed-sap-ref-8) + (16 'signed-sap-ref-16) + (32 'signed-sap-ref-32) + (64 'signed-sap-ref-64)) + (case (alien-integer-type-bits type) + (8 'sap-ref-8) + (16 'sap-ref-16) + (32 'sap-ref-32) + (64 'sap-ref-64))))) (if ref-fun - `(,ref-fun ,sap (/ ,offset sb!vm:n-byte-bits)) - (error "cannot extract ~W-bit integers" - (alien-integer-type-bits type))))) + `(,ref-fun ,sap (/ ,offset sb!vm:n-byte-bits)) + (error "cannot extract ~W-bit integers" + (alien-integer-type-bits type))))) ;;;; the BOOLEAN type @@ -605,107 +605,107 @@ ;;;; the ENUM type (define-alien-type-class (enum :include (integer (bits 32)) - :include-args (signed)) - name ; name of this enum (if any) - from ; alist from symbols to integers - to ; alist or vector from integers to symbols - kind ; kind of from mapping, :VECTOR or :ALIST - offset) ; offset to add to value for :VECTOR from mapping + :include-args (signed)) + name ; name of this enum (if any) + from ; alist from symbols to integers + to ; alist or vector from integers to symbols + kind ; kind of from mapping, :VECTOR or :ALIST + offset) ; offset to add to value for :VECTOR from mapping (define-alien-type-translator enum (&whole - type name - &rest mappings - &environment env) + type name + &rest mappings + &environment env) (cond (mappings - (let ((result (parse-enum name mappings))) - (when name - (multiple-value-bind (old old-p) - (auxiliary-alien-type :enum name env) - (when old-p - (unless (alien-type-= result old) - (warn "redefining alien enum ~S" name)))) - (setf (auxiliary-alien-type :enum name env) result)) - result)) - (name - (multiple-value-bind (result found) - (auxiliary-alien-type :enum name env) - (unless found - (error "unknown enum type: ~S" name)) - result)) - (t - (error "empty enum type: ~S" type)))) + (let ((result (parse-enum name mappings))) + (when name + (multiple-value-bind (old old-p) + (auxiliary-alien-type :enum name env) + (when old-p + (unless (alien-type-= result old) + (warn "redefining alien enum ~S" name)))) + (setf (auxiliary-alien-type :enum name env) result)) + result)) + (name + (multiple-value-bind (result found) + (auxiliary-alien-type :enum name env) + (unless found + (error "unknown enum type: ~S" name)) + result)) + (t + (error "empty enum type: ~S" type)))) (defun parse-enum (name elements) (when (null elements) (error "An enumeration must contain at least one element.")) (let ((min nil) - (max nil) - (from-alist ()) - (prev -1)) + (max nil) + (from-alist ()) + (prev -1)) (declare (list from-alist)) (dolist (el elements) (multiple-value-bind (sym val) - (if (listp el) - (values (first el) (second el)) - (values el (1+ prev))) - (setf prev val) - (unless (symbolp sym) - (error "The enumeration element ~S is not a symbol." sym)) - (unless (integerp val) - (error "The element value ~S is not an integer." val)) - (unless (and max (> max val)) (setq max val)) - (unless (and min (< min val)) (setq min val)) - (when (rassoc val from-alist) - (error "The element value ~S is used more than once." val)) - (when (assoc sym from-alist :test #'eq) - (error "The enumeration element ~S is used more than once." sym)) - (push (cons sym val) from-alist))) + (if (listp el) + (values (first el) (second el)) + (values el (1+ prev))) + (setf prev val) + (unless (symbolp sym) + (error "The enumeration element ~S is not a symbol." sym)) + (unless (integerp val) + (error "The element value ~S is not an integer." val)) + (unless (and max (> max val)) (setq max val)) + (unless (and min (< min val)) (setq min val)) + (when (rassoc val from-alist) + (error "The element value ~S is used more than once." val)) + (when (assoc sym from-alist :test #'eq) + (error "The enumeration element ~S is used more than once." sym)) + (push (cons sym val) from-alist))) (let* ((signed (minusp min)) - (min-bits (if signed - (1+ (max (integer-length min) - (integer-length max))) - (integer-length max)))) + (min-bits (if signed + (1+ (max (integer-length min) + (integer-length max))) + (integer-length max)))) (when (> min-bits 32) - (error "can't represent enums needing more than 32 bits")) + (error "can't represent enums needing more than 32 bits")) (setf from-alist (sort from-alist #'< :key #'cdr)) (cond ;; If range is at least 20% dense, use vector mapping. Crossover ;; point solely on basis of space would be 25%. Vector mapping ;; is always faster, so give the benefit of the doubt. ((< 0.2 (/ (float (length from-alist)) (float (1+ (- max min))))) - ;; If offset is small and ignorable, ignore it to save time. - (when (< 0 min 10) (setq min 0)) - (let ((to (make-array (1+ (- max min))))) - (dolist (el from-alist) - (setf (svref to (- (cdr el) min)) (car el))) - (make-alien-enum-type :name name :signed signed - :from from-alist :to to :kind - :vector :offset (- min)))) + ;; If offset is small and ignorable, ignore it to save time. + (when (< 0 min 10) (setq min 0)) + (let ((to (make-array (1+ (- max min))))) + (dolist (el from-alist) + (setf (svref to (- (cdr el) min)) (car el))) + (make-alien-enum-type :name name :signed signed + :from from-alist :to to :kind + :vector :offset (- min)))) (t - (make-alien-enum-type :name name :signed signed - :from from-alist - :to (mapcar (lambda (x) (cons (cdr x) (car x))) - from-alist) - :kind :alist)))))) + (make-alien-enum-type :name name :signed signed + :from from-alist + :to (mapcar (lambda (x) (cons (cdr x) (car x))) + from-alist) + :kind :alist)))))) (define-alien-type-method (enum :unparse) (type) `(enum ,(alien-enum-type-name type) - ,@(let ((prev -1)) - (mapcar (lambda (mapping) - (let ((sym (car mapping)) - (value (cdr mapping))) - (prog1 - (if (= (1+ prev) value) - sym - `(,sym ,value)) - (setf prev value)))) - (alien-enum-type-from type))))) + ,@(let ((prev -1)) + (mapcar (lambda (mapping) + (let ((sym (car mapping)) + (value (cdr mapping))) + (prog1 + (if (= (1+ prev) value) + sym + `(,sym ,value)) + (setf prev value)))) + (alien-enum-type-from type))))) (define-alien-type-method (enum :type=) (type1 type2) (and (eq (alien-enum-type-name type1) - (alien-enum-type-name type2)) + (alien-enum-type-name type2)) (equal (alien-enum-type-from type1) - (alien-enum-type-from type2)))) + (alien-enum-type-from type2)))) (define-alien-type-method (enum :lisp-rep) (type) `(member ,@(mapcar #'car (alien-enum-type-from type)))) @@ -714,18 +714,18 @@ (ecase (alien-enum-type-kind type) (:vector `(svref ',(alien-enum-type-to type) - (+ ,alien ,(alien-enum-type-offset type)))) + (+ ,alien ,(alien-enum-type-offset type)))) (:alist `(ecase ,alien - ,@(mapcar (lambda (mapping) - `(,(car mapping) ',(cdr mapping))) - (alien-enum-type-to type)))))) + ,@(mapcar (lambda (mapping) + `(,(car mapping) ',(cdr mapping))) + (alien-enum-type-to type)))))) (define-alien-type-method (enum :deport-gen) (type value) `(ecase ,value ,@(mapcar (lambda (mapping) - `(,(car mapping) ,(cdr mapping))) - (alien-enum-type-from type)))) + `(,(car mapping) ,(cdr mapping))) + (alien-enum-type-from type)))) ;;;; the FLOAT types @@ -750,7 +750,7 @@ value) (define-alien-type-class (single-float :include (float (bits 32)) - :include-args (type))) + :include-args (type))) (define-alien-type-translator single-float () (make-alien-single-float-type :type 'single-float)) @@ -760,7 +760,7 @@ `(sap-ref-single ,sap (/ ,offset sb!vm:n-byte-bits))) (define-alien-type-class (double-float :include (float (bits 64)) - :include-args (type))) + :include-args (type))) (define-alien-type-translator double-float () (make-alien-double-float-type :type 'double-float)) @@ -773,9 +773,9 @@ ;;;; the POINTER type (define-alien-type-class (pointer :include (alien-value (bits - #!-alpha - sb!vm:n-word-bits - #!+alpha 64))) + #!-alpha + sb!vm:n-word-bits + #!+alpha 64))) (to nil :type (or alien-type null))) (define-alien-type-translator * (to &environment env) @@ -784,27 +784,27 @@ (define-alien-type-method (pointer :unparse) (type) (let ((to (alien-pointer-type-to type))) `(* ,(if to - (%unparse-alien-type to) - t)))) + (%unparse-alien-type to) + t)))) (define-alien-type-method (pointer :type=) (type1 type2) (let ((to1 (alien-pointer-type-to type1)) - (to2 (alien-pointer-type-to type2))) + (to2 (alien-pointer-type-to type2))) (if to1 - (if to2 - (alien-type-= to1 to2) - nil) - (null to2)))) + (if to2 + (alien-type-= to1 to2) + nil) + (null to2)))) (define-alien-type-method (pointer :subtypep) (type1 type2) (and (alien-pointer-type-p type2) (let ((to1 (alien-pointer-type-to type1)) - (to2 (alien-pointer-type-to type2))) - (if to1 - (if to2 - (alien-subtype-p to1 to2) - t) - (null to2))))) + (to2 (alien-pointer-type-to type2))) + (if to1 + (if to2 + (alien-subtype-p to1 to2) + t) + (null to2))))) (define-alien-type-method (pointer :deport-gen) (type value) (/noshow "doing alien type method POINTER :DEPORT-GEN" type value) @@ -853,49 +853,49 @@ (when dims (unless (typep (first dims) '(or index null)) (error "The first dimension is not a non-negative fixnum or NIL: ~S" - (first dims))) + (first dims))) (let ((loser (find-if-not (lambda (x) (typep x 'index)) - (rest dims)))) + (rest dims)))) (when loser - (error "A dimension is not a non-negative fixnum: ~S" loser)))) - + (error "A dimension is not a non-negative fixnum: ~S" loser)))) + (let ((parsed-ele-type (parse-alien-type ele-type env))) (make-alien-array-type :element-type parsed-ele-type :dimensions dims :alignment (alien-type-alignment parsed-ele-type) :bits (if (and (alien-type-bits parsed-ele-type) - (every #'integerp dims)) - (* (align-offset (alien-type-bits parsed-ele-type) - (alien-type-alignment parsed-ele-type)) - (reduce #'* dims)))))) + (every #'integerp dims)) + (* (align-offset (alien-type-bits parsed-ele-type) + (alien-type-alignment parsed-ele-type)) + (reduce #'* dims)))))) (define-alien-type-method (array :unparse) (type) `(array ,(%unparse-alien-type (alien-array-type-element-type type)) - ,@(alien-array-type-dimensions type))) + ,@(alien-array-type-dimensions type))) (define-alien-type-method (array :type=) (type1 type2) (and (equal (alien-array-type-dimensions type1) - (alien-array-type-dimensions type2)) + (alien-array-type-dimensions type2)) (alien-type-= (alien-array-type-element-type type1) - (alien-array-type-element-type type2)))) + (alien-array-type-element-type type2)))) (define-alien-type-method (array :subtypep) (type1 type2) (and (alien-array-type-p type2) (let ((dim1 (alien-array-type-dimensions type1)) - (dim2 (alien-array-type-dimensions type2))) - (and (= (length dim1) (length dim2)) - (or (and dim2 - (null (car dim2)) - (equal (cdr dim1) (cdr dim2))) - (equal dim1 dim2)) - (alien-subtype-p (alien-array-type-element-type type1) - (alien-array-type-element-type type2)))))) + (dim2 (alien-array-type-dimensions type2))) + (and (= (length dim1) (length dim2)) + (or (and dim2 + (null (car dim2)) + (equal (cdr dim1) (cdr dim2))) + (equal dim1 dim2)) + (alien-subtype-p (alien-array-type-element-type type1) + (alien-array-type-element-type type2)))))) ;;;; the RECORD type (def!struct (alien-record-field - (:make-load-form-fun sb!kernel:just-dump-it-normally)) + (:make-load-form-fun sb!kernel:just-dump-it-normally)) (name (missing-arg) :type symbol) (type (missing-arg) :type alien-type) (bits nil :type (or unsigned-byte null)) @@ -903,10 +903,10 @@ (def!method print-object ((field alien-record-field) stream) (print-unreadable-object (field stream :type t) (format stream - "~S ~S~@[:~D~]" - (alien-record-field-type field) - (alien-record-field-name field) - (alien-record-field-bits field)))) + "~S ~S~@[:~D~]" + (alien-record-field-type field) + (alien-record-field-name field) + (alien-record-field-bits field)))) (define-alien-type-class (record :include mem-block) (kind :struct :type (member :struct :union)) @@ -928,70 +928,70 @@ (defun parse-alien-record-type (kind name fields env) (declare (type (or sb!kernel:lexenv null) env)) (cond (fields - (let* ((old (and name (auxiliary-alien-type kind name env))) - (old-fields (and old (alien-record-type-fields old)))) - ;; KLUDGE: We can't easily compare the new fields - ;; against the old fields, since the old fields have - ;; already been parsed into an internal - ;; representation, so we just punt, assuming that - ;; they're consistent. -- WHN 200000505 - #| - (unless (equal fields old-fields) - ;; FIXME: Perhaps this should be a warning, and we - ;; should overwrite the old definition and proceed? - (error "mismatch in fields for ~S~% old ~S~% new ~S" - name old-fields fields)) - |# - (if old-fields - old - (let ((type (or old (make-alien-record-type :name name :kind kind)))) - (when (and name (not old)) - (setf (auxiliary-alien-type kind name env) type)) - (parse-alien-record-fields type fields env) - type)))) - (name - (or (auxiliary-alien-type kind name env) - (setf (auxiliary-alien-type kind name env) - (make-alien-record-type :name name :kind kind)))) - (t - (make-alien-record-type :kind kind)))) + (let* ((old (and name (auxiliary-alien-type kind name env))) + (old-fields (and old (alien-record-type-fields old)))) + ;; KLUDGE: We can't easily compare the new fields + ;; against the old fields, since the old fields have + ;; already been parsed into an internal + ;; representation, so we just punt, assuming that + ;; they're consistent. -- WHN 200000505 + #| + (unless (equal fields old-fields) + ;; FIXME: Perhaps this should be a warning, and we + ;; should overwrite the old definition and proceed? + (error "mismatch in fields for ~S~% old ~S~% new ~S" + name old-fields fields)) + |# + (if old-fields + old + (let ((type (or old (make-alien-record-type :name name :kind kind)))) + (when (and name (not old)) + (setf (auxiliary-alien-type kind name env) type)) + (parse-alien-record-fields type fields env) + type)))) + (name + (or (auxiliary-alien-type kind name env) + (setf (auxiliary-alien-type kind name env) + (make-alien-record-type :name name :kind kind)))) + (t + (make-alien-record-type :kind kind)))) ;;; This is used by PARSE-ALIEN-TYPE to parse the fields of struct and ;;; union types. RESULT holds the record type we are paring the fields ;;; of, and FIELDS is the list of field specifications. (defun parse-alien-record-fields (result fields env) (declare (type alien-record-type result) - (type list fields)) + (type list fields)) (let ((total-bits 0) - (overall-alignment 1) - (parsed-fields nil)) + (overall-alignment 1) + (parsed-fields nil)) (dolist (field fields) (destructuring-bind (var type &optional bits) field - (declare (ignore bits)) - (let* ((field-type (parse-alien-type type env)) - (bits (alien-type-bits field-type)) - (alignment (alien-type-alignment field-type)) - (parsed-field - (make-alien-record-field :type field-type - :name var))) - (push parsed-field parsed-fields) - (when (null bits) - (error "unknown size: ~S" (unparse-alien-type field-type))) - (when (null alignment) - (error "unknown alignment: ~S" (unparse-alien-type field-type))) - (setf overall-alignment (max overall-alignment alignment)) - (ecase (alien-record-type-kind result) - (:struct - (let ((offset (align-offset total-bits alignment))) - (setf (alien-record-field-offset parsed-field) offset) - (setf total-bits (+ offset bits)))) - (:union - (setf total-bits (max total-bits bits))))))) + (declare (ignore bits)) + (let* ((field-type (parse-alien-type type env)) + (bits (alien-type-bits field-type)) + (alignment (alien-type-alignment field-type)) + (parsed-field + (make-alien-record-field :type field-type + :name var))) + (push parsed-field parsed-fields) + (when (null bits) + (error "unknown size: ~S" (unparse-alien-type field-type))) + (when (null alignment) + (error "unknown alignment: ~S" (unparse-alien-type field-type))) + (setf overall-alignment (max overall-alignment alignment)) + (ecase (alien-record-type-kind result) + (:struct + (let ((offset (align-offset total-bits alignment))) + (setf (alien-record-field-offset parsed-field) offset) + (setf total-bits (+ offset bits)))) + (:union + (setf total-bits (max total-bits bits))))))) (let ((new (nreverse parsed-fields))) (setf (alien-record-type-fields result) new)) (setf (alien-record-type-alignment result) overall-alignment) (setf (alien-record-type-bits result) - (align-offset total-bits overall-alignment)))) + (align-offset total-bits overall-alignment)))) (define-alien-type-method (record :unparse) (type) `(,(case (alien-record-type-kind type) @@ -1000,48 +1000,48 @@ (t '???)) ,(alien-record-type-name type) ,@(unless (member type *record-types-already-unparsed* :test #'eq) - (push type *record-types-already-unparsed*) - (mapcar (lambda (field) - `(,(alien-record-field-name field) - ,(%unparse-alien-type (alien-record-field-type field)) - ,@(if (alien-record-field-bits field) - (list (alien-record-field-bits field))))) - (alien-record-type-fields type))))) + (push type *record-types-already-unparsed*) + (mapcar (lambda (field) + `(,(alien-record-field-name field) + ,(%unparse-alien-type (alien-record-field-type field)) + ,@(if (alien-record-field-bits field) + (list (alien-record-field-bits field))))) + (alien-record-type-fields type))))) ;;; Test the record fields. Keep a hashtable table of already compared ;;; types to detect cycles. (defun record-fields-match-p (field1 field2) (and (eq (alien-record-field-name field1) - (alien-record-field-name field2)) + (alien-record-field-name field2)) (eql (alien-record-field-bits field1) - (alien-record-field-bits field2)) + (alien-record-field-bits field2)) (eql (alien-record-field-offset field1) - (alien-record-field-offset field2)) + (alien-record-field-offset field2)) (alien-type-= (alien-record-field-type field1) - (alien-record-field-type field2)))) + (alien-record-field-type field2)))) (defvar *alien-type-matches* nil "A hashtable used to detect cycles while comparing record types.") (define-alien-type-method (record :type=) (type1 type2) (and (eq (alien-record-type-name type1) - (alien-record-type-name type2)) + (alien-record-type-name type2)) (eq (alien-record-type-kind type1) - (alien-record-type-kind type2)) - (eql (alien-type-bits type1) - (alien-type-bits type2)) - (eql (alien-type-alignment type1) - (alien-type-alignment type2)) + (alien-record-type-kind type2)) + (eql (alien-type-bits type1) + (alien-type-bits type2)) + (eql (alien-type-alignment type1) + (alien-type-alignment type2)) (flet ((match-fields (&optional old) - (setf (gethash type1 *alien-type-matches*) (cons type2 old)) - (every #'record-fields-match-p - (alien-record-type-fields type1) - (alien-record-type-fields type2)))) - (if *alien-type-matches* - (let ((types (gethash type1 *alien-type-matches*))) - (or (memq type2 types) (match-fields types))) - (let ((*alien-type-matches* (make-hash-table :test #'eq))) - (match-fields)))))) + (setf (gethash type1 *alien-type-matches*) (cons type2 old)) + (every #'record-fields-match-p + (alien-record-type-fields type1) + (alien-record-type-fields type2)))) + (if *alien-type-matches* + (let ((types (gethash type1 *alien-type-matches*))) + (or (memq type2 types) (match-fields types))) + (let ((*alien-type-matches* (make-hash-table :test #'eq))) + (match-fields)))))) ;;;; the FUNCTION and VALUES alien types @@ -1060,26 +1060,26 @@ (stub nil :type (or null function))) (define-alien-type-translator function (result-type &rest arg-types - &environment env) + &environment env) (make-alien-fun-type :result-type (let ((*values-type-okay* t)) - (parse-alien-type result-type env)) + (parse-alien-type result-type env)) :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env)) - arg-types))) + arg-types))) (define-alien-type-method (fun :unparse) (type) `(function ,(%unparse-alien-type (alien-fun-type-result-type type)) - ,@(mapcar #'%unparse-alien-type - (alien-fun-type-arg-types type)))) + ,@(mapcar #'%unparse-alien-type + (alien-fun-type-arg-types type)))) (define-alien-type-method (fun :type=) (type1 type2) (and (alien-type-= (alien-fun-type-result-type type1) - (alien-fun-type-result-type type2)) + (alien-fun-type-result-type type2)) (= (length (alien-fun-type-arg-types type1)) - (length (alien-fun-type-arg-types type2))) + (length (alien-fun-type-arg-types type2))) (every #'alien-type-= - (alien-fun-type-arg-types type1) - (alien-fun-type-arg-types type2)))) + (alien-fun-type-arg-types type1) + (alien-fun-type-arg-types type2)))) (define-alien-type-class (values) (values (missing-arg) :type list)) @@ -1090,18 +1090,18 @@ (let ((*values-type-okay* nil)) (make-alien-values-type :values (mapcar (lambda (alien-type) (parse-alien-type alien-type env)) - values)))) + values)))) (define-alien-type-method (values :unparse) (type) `(values ,@(mapcar #'%unparse-alien-type - (alien-values-type-values type)))) + (alien-values-type-values type)))) (define-alien-type-method (values :type=) (type1 type2) (and (= (length (alien-values-type-values type1)) - (length (alien-values-type-values type2))) + (length (alien-values-type-values type2))) (every #'alien-type-= - (alien-values-type-values type1) - (alien-values-type-values type2)))) + (alien-values-type-values type1) + (alien-values-type-values type2)))) ;;;; a structure definition needed both in the target and in the ;;;; cross-compilation host @@ -1110,12 +1110,12 @@ ;;; these structures and LOCAL-ALIEN and friends communicate ;;; information about how that local alien is represented. (def!struct (local-alien-info - (:make-load-form-fun sb!kernel:just-dump-it-normally) - (:constructor make-local-alien-info - (&key type force-to-memory-p - &aux (force-to-memory-p (or force-to-memory-p - (alien-array-type-p type) - (alien-record-type-p type)))))) + (:make-load-form-fun sb!kernel:just-dump-it-normally) + (:constructor make-local-alien-info + (&key type force-to-memory-p + &aux (force-to-memory-p (or force-to-memory-p + (alien-array-type-p type) + (alien-record-type-p type)))))) ;; the type of the local alien (type (missing-arg) :type alien-type) ;; Must this local alien be forced into memory? Using the ADDR macro @@ -1124,9 +1124,9 @@ (def!method print-object ((info local-alien-info) stream) (print-unreadable-object (info stream :type t) (format stream - "~:[~;(forced to stack) ~]~S" - (local-alien-info-force-to-memory-p info) - (unparse-alien-type (local-alien-info-type info))))) + "~:[~;(forced to stack) ~]~S" + (local-alien-info-force-to-memory-p info) + (unparse-alien-type (local-alien-info-type info))))) ;;;; the ADDR macro @@ -1136,28 +1136,28 @@ to SLOT or DEREF, or a reference to an Alien variable." (let ((form (sb!xc:macroexpand expr env))) (or (typecase form - (cons - (case (car form) - (slot - (cons '%slot-addr (cdr form))) - (deref - (cons '%deref-addr (cdr form))) - (%heap-alien - (cons '%heap-alien-addr (cdr form))) - (local-alien - (let ((info (let ((info-arg (second form))) - (and (consp info-arg) - (eq (car info-arg) 'quote) - (second info-arg))))) - (unless (local-alien-info-p info) - (error "Something is wrong, LOCAL-ALIEN-INFO not found: ~S" - form)) - (setf (local-alien-info-force-to-memory-p info) t)) - (cons '%local-alien-addr (cdr form))))) - (symbol - (let ((kind (info :variable :kind form))) - (when (eq kind :alien) - `(%heap-alien-addr ',(info :variable :alien-info form)))))) - (error "~S is not a valid L-value." form)))) + (cons + (case (car form) + (slot + (cons '%slot-addr (cdr form))) + (deref + (cons '%deref-addr (cdr form))) + (%heap-alien + (cons '%heap-alien-addr (cdr form))) + (local-alien + (let ((info (let ((info-arg (second form))) + (and (consp info-arg) + (eq (car info-arg) 'quote) + (second info-arg))))) + (unless (local-alien-info-p info) + (error "Something is wrong, LOCAL-ALIEN-INFO not found: ~S" + form)) + (setf (local-alien-info-force-to-memory-p info) t)) + (cons '%local-alien-addr (cdr form))))) + (symbol + (let ((kind (info :variable :kind form))) + (when (eq kind :alien) + `(%heap-alien-addr ',(info :variable :alien-info form)))))) + (error "~S is not a valid L-value." form)))) (/show0 "host-alieneval.lisp end of file") diff --git a/src/code/hppa-vm.lisp b/src/code/hppa-vm.lisp index 9f30c9a..dee7b04 100644 --- a/src/code/hppa-vm.lisp +++ b/src/code/hppa-vm.lisp @@ -19,30 +19,30 @@ (error "Unaligned instruction? offset=#x~X." offset)) (sb!sys:without-gcing (let* ((sap (truly-the system-area-pointer - (%primitive sb!kernel::code-instructions code))) - (inst (sap-ref-32 sap offset))) + (%primitive sb!kernel::code-instructions code))) + (inst (sap-ref-32 sap offset))) (setf (sap-ref-32 sap offset) - (ecase kind - (:load - (logior (ash (ldb (byte 11 0) value) 1) - (logand inst #xffffc000))) - (:load-short - (let ((low-bits (ldb (byte 11 0) value))) - (aver (<= 0 low-bits (1- (ash 1 4)))) - (logior (ash low-bits 17) - (logand inst #xffe0ffff)))) - (:hi - (logior (ash (ldb (byte 5 13) value) 16) - (ash (ldb (byte 2 18) value) 14) - (ash (ldb (byte 2 11) value) 12) - (ash (ldb (byte 11 20) value) 1) - (ldb (byte 1 31) value) - (logand inst #xffe00000))) - (:branch - (let ((bits (ldb (byte 9 2) value))) - (aver (zerop (ldb (byte 2 0) value))) - (logior (ash bits 3) - (logand inst #xffe0e002))))))))) + (ecase kind + (:load + (logior (ash (ldb (byte 11 0) value) 1) + (logand inst #xffffc000))) + (:load-short + (let ((low-bits (ldb (byte 11 0) value))) + (aver (<= 0 low-bits (1- (ash 1 4)))) + (logior (ash low-bits 17) + (logand inst #xffe0ffff)))) + (:hi + (logior (ash (ldb (byte 5 13) value) 16) + (ash (ldb (byte 2 18) value) 14) + (ash (ldb (byte 2 11) value) 12) + (ash (ldb (byte 11 20) value) 1) + (ldb (byte 1 31) value) + (logand inst #xffe00000))) + (:branch + (let ((bits (ldb (byte 9 2) value))) + (aver (zerop (ldb (byte 2 0) value))) + (logior (ash bits 3) + (logand inst #xffe0e002))))))))) (define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int) (context (* os-context-t))) @@ -79,21 +79,21 @@ ;;; ;;; Given the sigcontext, extract the internal error arguments from the ;;; instruction stream. -;;; +;;; (defun internal-error-args (context) (declare (type (alien (* os-context-t)) context)) (let ((pc (context-pc context))) (declare (type system-area-pointer pc)) (let* ((length (sap-ref-8 pc 4)) - (vector (make-array length :element-type '(unsigned-byte 8)))) + (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (type (unsigned-byte 8) length) - (type (simple-array (unsigned-byte 8) (*)) vector)) + (type (simple-array (unsigned-byte 8) (*)) vector)) (copy-ub8-from-system-area pc 5 vector 0 length) (let* ((index 0) - (error-number (sb!c:read-var-integer vector index))) - (collect ((sc-offsets)) - (loop - (when (>= index length) - (return)) - (sc-offsets (sb!c:read-var-integer vector index))) - (values error-number (sc-offsets))))))) + (error-number (sb!c:read-var-integer vector index))) + (collect ((sc-offsets)) + (loop + (when (>= index length) + (return)) + (sc-offsets (sb!c:read-var-integer vector index))) + (values error-number (sc-offsets))))))) diff --git a/src/code/inspect.lisp b/src/code/inspect.lisp index 603319c..f059e88 100644 --- a/src/code/inspect.lisp +++ b/src/code/inspect.lisp @@ -50,68 +50,68 @@ evaluated expressions. (defun %inspect (*inspected* s) (named-let redisplay () ; "LAMBDA, the ultimate GOTO":-| (multiple-value-bind (description named-p elements) - (inspected-parts *inspected*) + (inspected-parts *inspected*) (tty-display-inspected-parts description named-p elements s) (named-let reread () - (format s "~&> ") - (force-output) - (let* (;; newly-consed object for hermetic protection against - ;; mischievous input like #.*EOF-OBJECT*: - (eof (cons *eof-object* nil)) + (format s "~&> ") + (force-output) + (let* (;; newly-consed object for hermetic protection against + ;; mischievous input like #.*EOF-OBJECT*: + (eof (cons *eof-object* nil)) (command (read *standard-input* nil eof))) (when (eq command eof) - ;; currently-undocumented feature: EOF is handled as Q. - ;; If there's ever consensus that this is *the* right - ;; thing to do (as opposed to e.g. handling it as U), we - ;; could document it. Meanwhile, it seems more Unix-y to - ;; do this than to signal an error. - (/show0 "THROWing QUIT-INSPECT for EOF") - (throw 'quit-inspect nil)) - (typecase command - (integer - (let ((elements-length (length elements))) - (cond ((< -1 command elements-length) - (let* ((element (nth command elements)) - (value (if named-p (cdr element) element))) - (cond ((eq value *inspect-unbound-object-marker*) - (format s "~%That slot is unbound.~%") - (return-from %inspect (reread))) - (t - (%inspect value s) - ;; If we ever return, then we should be - ;; looking at *INSPECTED* again. - (return-from %inspect (redisplay)))))) - ((zerop elements-length) - (format s "~%The object contains nothing to inspect.~%") - (return-from %inspect (reread))) - (t - (format s "~%Enter a valid index (~:[0-~W~;0~]).~%" - (= elements-length 1) (1- elements-length)) - (return-from %inspect (reread)))))) - (symbol - (case (find-symbol (symbol-name command) *keyword-package*) - ((:q :e) - (/show0 "THROWing QUIT-INSPECT for :Q or :E") - (throw 'quit-inspect nil)) - (:u - (return-from %inspect)) - (:r - (return-from %inspect (redisplay))) - ((:h :? :help) - (write-string *help-for-inspect* s) - (return-from %inspect (reread))) - (t - (eval-for-inspect command s) - (return-from %inspect (reread))))) - (t - (eval-for-inspect command s) - (return-from %inspect (reread))))))))) + ;; currently-undocumented feature: EOF is handled as Q. + ;; If there's ever consensus that this is *the* right + ;; thing to do (as opposed to e.g. handling it as U), we + ;; could document it. Meanwhile, it seems more Unix-y to + ;; do this than to signal an error. + (/show0 "THROWing QUIT-INSPECT for EOF") + (throw 'quit-inspect nil)) + (typecase command + (integer + (let ((elements-length (length elements))) + (cond ((< -1 command elements-length) + (let* ((element (nth command elements)) + (value (if named-p (cdr element) element))) + (cond ((eq value *inspect-unbound-object-marker*) + (format s "~%That slot is unbound.~%") + (return-from %inspect (reread))) + (t + (%inspect value s) + ;; If we ever return, then we should be + ;; looking at *INSPECTED* again. + (return-from %inspect (redisplay)))))) + ((zerop elements-length) + (format s "~%The object contains nothing to inspect.~%") + (return-from %inspect (reread))) + (t + (format s "~%Enter a valid index (~:[0-~W~;0~]).~%" + (= elements-length 1) (1- elements-length)) + (return-from %inspect (reread)))))) + (symbol + (case (find-symbol (symbol-name command) *keyword-package*) + ((:q :e) + (/show0 "THROWing QUIT-INSPECT for :Q or :E") + (throw 'quit-inspect nil)) + (:u + (return-from %inspect)) + (:r + (return-from %inspect (redisplay))) + ((:h :? :help) + (write-string *help-for-inspect* s) + (return-from %inspect (reread))) + (t + (eval-for-inspect command s) + (return-from %inspect (reread))))) + (t + (eval-for-inspect command s) + (return-from %inspect (reread))))))))) (defun eval-for-inspect (command stream) (let ((result-list (restart-case (multiple-value-list (eval command)) - (nil () :report "Return to the inspector." - (format stream "~%returning to the inspector~%") - (return-from eval-for-inspect nil))))) + (nil () :report "Return to the inspector." + (format stream "~%returning to the inspector~%") + (return-from eval-for-inspect nil))))) ;; FIXME: Much of this interactive-EVAL logic is shared with ;; the main REPL EVAL and with the debugger EVAL. The code should ;; be shared explicitly. @@ -125,12 +125,12 @@ evaluated expressions. (let ((index 0)) (dolist (element elements) (if named-p - (destructuring-bind (name . value) element - (format stream "~W. ~A: ~W~%" index name - (if (eq value *inspect-unbound-object-marker*) - "unbound" - value))) - (format stream "~W. ~W~%" index element)) + (destructuring-bind (name . value) element + (format stream "~W. ~A: ~W~%" index name + (if (eq value *inspect-unbound-object-marker*) + "unbound" + value))) + (format stream "~W. ~W~%" index element)) (incf index)))) ;;;; INSPECTED-PARTS @@ -156,16 +156,16 @@ evaluated expressions. (defmethod inspected-parts ((object symbol)) (values (format nil "The object is a SYMBOL.~%") - t - (list (cons "Name" (symbol-name object)) - (cons "Package" (symbol-package object)) - (cons "Value" (if (boundp object) - (symbol-value object) - *inspect-unbound-object-marker*)) - (cons "Function" (if (fboundp object) - (symbol-function object) - *inspect-unbound-object-marker*)) - (cons "Plist" (symbol-plist object))))) + t + (list (cons "Name" (symbol-name object)) + (cons "Package" (symbol-package object)) + (cons "Value" (if (boundp object) + (symbol-value object) + *inspect-unbound-object-marker*)) + (cons "Function" (if (fboundp object) + (symbol-function object) + *inspect-unbound-object-marker*)) + (cons "Plist" (symbol-plist object))))) (defun inspected-structure-elements (object) (let ((parts-list '()) @@ -178,40 +178,40 @@ evaluated expressions. (defmethod inspected-parts ((object structure-object)) (values (format nil "The object is a STRUCTURE-OBJECT of type ~S.~%" - (type-of object)) - t - (inspected-structure-elements object))) + (type-of object)) + t + (inspected-structure-elements object))) (defun inspected-standard-object-elements (object) (let ((reversed-elements nil) - (class-slots (sb-pcl::class-slots (class-of object)))) + (class-slots (sb-pcl::class-slots (class-of object)))) (dolist (class-slot class-slots (nreverse reversed-elements)) (let* ((slot-name (slot-value class-slot 'sb-pcl::name)) - (slot-value (if (slot-boundp object slot-name) - (slot-value object slot-name) - *inspect-unbound-object-marker*))) - (push (cons slot-name slot-value) reversed-elements))))) + (slot-value (if (slot-boundp object slot-name) + (slot-value object slot-name) + *inspect-unbound-object-marker*))) + (push (cons slot-name slot-value) reversed-elements))))) (defmethod inspected-parts ((object standard-object)) (values (format nil "The object is a STANDARD-OBJECT of type ~S.~%" - (type-of object)) - t - (inspected-standard-object-elements object))) + (type-of object)) + t + (inspected-standard-object-elements object))) (defmethod inspected-parts ((object funcallable-instance)) (values (format nil "The object is a FUNCALLABLE-INSTANCE of type ~S.~%" - (type-of object)) - t - (inspected-standard-object-elements object))) + (type-of object)) + t + (inspected-standard-object-elements object))) (defmethod inspected-parts ((object condition)) (values (format nil "The object is a CONDITION of type ~S.~%" - (type-of object)) - t - (inspected-standard-object-elements object))) + (type-of object)) + t + (inspected-standard-object-elements object))) (defmethod inspected-parts ((object function)) - (values (format nil "The object is a ~A named ~S.~%" + (values (format nil "The object is a ~A named ~S.~%" (if (closurep object) 'closure 'function) (%fun-name object)) t @@ -227,48 +227,48 @@ evaluated expressions. (defmethod inspected-parts ((object vector)) (values (format nil - "The object is a ~:[~;displaced ~]VECTOR of length ~W.~%" - (and (array-header-p object) - (%array-displaced-p object)) - (length object)) - nil - ;; FIXME: Should we respect *INSPECT-LENGTH* here? If not, what - ;; does *INSPECT-LENGTH* mean? - (coerce object 'list))) + "The object is a ~:[~;displaced ~]VECTOR of length ~W.~%" + (and (array-header-p object) + (%array-displaced-p object)) + (length object)) + nil + ;; FIXME: Should we respect *INSPECT-LENGTH* here? If not, what + ;; does *INSPECT-LENGTH* mean? + (coerce object 'list))) (defun inspected-index-string (index rev-dimensions) (if (null rev-dimensions) "[]" (let ((list nil)) - (dolist (dim rev-dimensions) - (multiple-value-bind (q r) (floor index dim) - (setq index q) - (push r list))) - (format nil "[~W~{,~W~}]" (car list) (cdr list))))) + (dolist (dim rev-dimensions) + (multiple-value-bind (q r) (floor index dim) + (setq index q) + (push r list))) + (format nil "[~W~{,~W~}]" (car list) (cdr list))))) (defmethod inspected-parts ((object array)) (let* ((length (min (array-total-size object) *inspect-length*)) - (reference-array (make-array length - :element-type (array-element-type object) - :displaced-to object)) - (dimensions (array-dimensions object)) - (reversed-elements nil)) + (reference-array (make-array length + :element-type (array-element-type object) + :displaced-to object)) + (dimensions (array-dimensions object)) + (reversed-elements nil)) ;; FIXME: Should we respect *INSPECT-LENGTH* here? If not, what does ;; *INSPECT-LENGTH* mean? (dotimes (i length) (push (cons (format nil - "~A " - (inspected-index-string i (reverse dimensions))) - (aref reference-array i)) - reversed-elements)) + "~A " + (inspected-index-string i (reverse dimensions))) + (aref reference-array i)) + reversed-elements)) (values (format nil "The object is ~:[a displaced~;an~] ARRAY of ~A.~%~ Its dimensions are ~S.~%" - (array-element-type object) - (and (array-header-p object) - (%array-displaced-p object)) - dimensions) - t - (nreverse reversed-elements)))) + (array-element-type object) + (and (array-header-p object) + (%array-displaced-p object)) + dimensions) + t + (nreverse reversed-elements)))) (defmethod inspected-parts ((object cons)) (if (consp (cdr object)) @@ -278,31 +278,31 @@ evaluated expressions. (defun inspected-parts-of-simple-cons (object) (values "The object is a CONS. " - t - (list (cons 'car (car object)) - (cons 'cdr (cdr object))))) + t + (list (cons 'car (car object)) + (cons 'cdr (cdr object))))) (defun inspected-parts-of-nontrivial-list (object) (let ((length 0) - (in-list object) - (reversed-elements nil)) + (in-list object) + (reversed-elements nil)) (flet ((done (description-format) - (return-from inspected-parts-of-nontrivial-list - (values (format nil description-format length) - t - (nreverse reversed-elements))))) + (return-from inspected-parts-of-nontrivial-list + (values (format nil description-format length) + t + (nreverse reversed-elements))))) (loop (cond ((null in-list) - (done "The object is a proper list of length ~S.~%")) - ((>= length *inspect-length*) - (push (cons 'rest in-list) reversed-elements) - (done "The object is a long list (more than ~S elements).~%")) - ((consp in-list) - (push (cons length (pop in-list)) reversed-elements) - (incf length)) - (t - (push (cons 'rest in-list) reversed-elements) - (done "The object is an improper list of length ~S.~%"))))))) + (done "The object is a proper list of length ~S.~%")) + ((>= length *inspect-length*) + (push (cons 'rest in-list) reversed-elements) + (done "The object is a long list (more than ~S elements).~%")) + ((consp in-list) + (push (cons length (pop in-list)) reversed-elements) + (incf length)) + (t + (push (cons 'rest in-list) reversed-elements) + (done "The object is an improper list of length ~S.~%"))))))) (defmethod inspected-parts ((object t)) (values (format nil "The object is an ATOM:~% ~W~%" object) nil nil)) diff --git a/src/code/interr.lisp b/src/code/interr.lisp index b230d79..5b97d54 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -21,41 +21,41 @@ (sb!xc:defmacro deferr (name args &rest body) (let* ((rest-pos (position '&rest args)) - (required (if rest-pos (subseq args 0 rest-pos) args)) - (fp (gensym)) - (context (gensym)) - (sc-offsets (gensym)) - (fn-name (symbolicate name "-HANDLER"))) + (required (if rest-pos (subseq args 0 rest-pos) args)) + (fp (gensym)) + (context (gensym)) + (sc-offsets (gensym)) + (fn-name (symbolicate name "-HANDLER"))) `(progn ;; FIXME: Having a separate full DEFUN for each error doesn't ;; seem to add much value, and it takes a lot of space. Perhaps ;; we could do this dispatch with a big CASE statement instead? (defun ,fn-name (name ,fp ,context ,sc-offsets) - ;; FIXME: It would probably be good to do *STACK-TOP-HINT* - ;; tricks to hide this internal error-handling logic from the - ;; poor high level user, so his debugger tells him about - ;; where his error was detected instead of telling him where - ;; he ended up inside the system error-handling logic. - (declare (ignorable name ,fp ,context ,sc-offsets)) - (let (,@(let ((offset -1)) - (mapcar (lambda (var) - `(,var (sb!di::sub-access-debug-var-slot - ,fp - (nth ,(incf offset) - ,sc-offsets) - ,context))) - required)) - ,@(when rest-pos - `((,(nth (1+ rest-pos) args) - (mapcar (lambda (sc-offset) - (sb!di::sub-access-debug-var-slot - ,fp - sc-offset - ,context)) - (nthcdr ,rest-pos ,sc-offsets)))))) - ,@body)) + ;; FIXME: It would probably be good to do *STACK-TOP-HINT* + ;; tricks to hide this internal error-handling logic from the + ;; poor high level user, so his debugger tells him about + ;; where his error was detected instead of telling him where + ;; he ended up inside the system error-handling logic. + (declare (ignorable name ,fp ,context ,sc-offsets)) + (let (,@(let ((offset -1)) + (mapcar (lambda (var) + `(,var (sb!di::sub-access-debug-var-slot + ,fp + (nth ,(incf offset) + ,sc-offsets) + ,context))) + required)) + ,@(when rest-pos + `((,(nth (1+ rest-pos) args) + (mapcar (lambda (sc-offset) + (sb!di::sub-access-debug-var-slot + ,fp + sc-offset + ,context)) + (nthcdr ,rest-pos ,sc-offsets)))))) + ,@body)) (setf (svref *internal-errors* ,(error-number-or-lose name)) - #',fn-name)))) + #',fn-name)))) ) ; EVAL-WHEN @@ -64,282 +64,282 @@ (deferr object-not-fun-error (object) (error 'type-error - :datum object - :expected-type 'function)) + :datum object + :expected-type 'function)) (deferr object-not-list-error (object) (error 'type-error - :datum object - :expected-type 'list)) + :datum object + :expected-type 'list)) (deferr object-not-bignum-error (object) (error 'type-error - :datum object - :expected-type 'bignum)) + :datum object + :expected-type 'bignum)) (deferr object-not-ratio-error (object) (error 'type-error - :datum object - :expected-type 'ratio)) + :datum object + :expected-type 'ratio)) (deferr object-not-single-float-error (object) (error 'type-error - :datum object - :expected-type 'single-float)) + :datum object + :expected-type 'single-float)) (deferr object-not-double-float-error (object) (error 'type-error - :datum object - :expected-type 'double-float)) + :datum object + :expected-type 'double-float)) #!+long-float (deferr object-not-long-float-error (object) (error 'type-error - :datum object - :expected-type 'long-float)) + :datum object + :expected-type 'long-float)) (deferr object-not-simple-string-error (object) (error 'type-error - :datum object - :expected-type 'simple-string)) + :datum object + :expected-type 'simple-string)) (deferr object-not-fixnum-error (object) (error 'type-error - :datum object - :expected-type 'fixnum)) + :datum object + :expected-type 'fixnum)) (deferr object-not-vector-error (object) (error 'type-error - :datum object - :expected-type 'vector)) + :datum object + :expected-type 'vector)) (deferr object-not-string-error (object) (error 'type-error - :datum object - :expected-type 'string)) + :datum object + :expected-type 'string)) (deferr object-not-base-string-error (object) (error 'type-error - :datum object - :expected-type 'base-string)) + :datum object + :expected-type 'base-string)) (deferr object-not-vector-nil-error (object) (error 'type-error - :datum object - :expected-type '(vector nil))) + :datum object + :expected-type '(vector nil))) #!+sb-unicode (deferr object-not-character-string-error (object) (error 'type-error - :datum object - :expected-type '(vector character))) + :datum object + :expected-type '(vector character))) (deferr object-not-bit-vector-error (object) (error 'type-error - :datum object - :expected-type 'bit-vector)) + :datum object + :expected-type 'bit-vector)) (deferr object-not-array-error (object) (error 'type-error - :datum object - :expected-type 'array)) + :datum object + :expected-type 'array)) (deferr object-not-number-error (object) (error 'type-error - :datum object - :expected-type 'number)) + :datum object + :expected-type 'number)) (deferr object-not-rational-error (object) (error 'type-error - :datum object - :expected-type 'rational)) + :datum object + :expected-type 'rational)) (deferr object-not-float-error (object) (error 'type-error - :datum object - :expected-type 'float)) + :datum object + :expected-type 'float)) (deferr object-not-real-error (object) (error 'type-error - :datum object - :expected-type 'real)) + :datum object + :expected-type 'real)) (deferr object-not-integer-error (object) (error 'type-error - :datum object - :expected-type 'integer)) + :datum object + :expected-type 'integer)) (deferr object-not-cons-error (object) (error 'type-error - :datum object - :expected-type 'cons)) + :datum object + :expected-type 'cons)) (deferr object-not-symbol-error (object) (error 'type-error - :datum object - :expected-type 'symbol)) + :datum object + :expected-type 'symbol)) (deferr undefined-fun-error (fdefn-or-symbol) (error 'undefined-function - :name (etypecase fdefn-or-symbol - (symbol fdefn-or-symbol) - (fdefn (fdefn-name fdefn-or-symbol))))) + :name (etypecase fdefn-or-symbol + (symbol fdefn-or-symbol) + (fdefn (fdefn-name fdefn-or-symbol))))) (deferr invalid-arg-count-error (nargs) (error 'simple-program-error - :format-control "invalid number of arguments: ~S" - :format-arguments (list nargs))) + :format-control "invalid number of arguments: ~S" + :format-arguments (list nargs))) (deferr bogus-arg-to-values-list-error (list) (error 'simple-type-error - :datum list - :expected-type 'list - :format-control - "~@" - :format-arguments (list list))) + :datum list + :expected-type 'list + :format-control + "~@" + :format-arguments (list list))) (deferr unbound-symbol-error (symbol) (error 'unbound-variable :name symbol)) (deferr object-not-character-error (object) (error 'type-error - :datum object - :expected-type 'character)) + :datum object + :expected-type 'character)) (deferr object-not-sap-error (object) (error 'type-error - :datum object - :expected-type 'system-area-pointer)) + :datum object + :expected-type 'system-area-pointer)) (deferr invalid-unwind-error () (error 'simple-control-error - :format-control - "attempt to RETURN-FROM a block or GO to a tag that no longer exists" - )) + :format-control + "attempt to RETURN-FROM a block or GO to a tag that no longer exists" + )) (deferr unseen-throw-tag-error (tag) (error 'simple-control-error - :format-control "attempt to THROW to a tag that does not exist: ~S" - :format-arguments (list tag))) + :format-control "attempt to THROW to a tag that does not exist: ~S" + :format-arguments (list tag))) (deferr nil-fun-returned-error (function) (error 'simple-control-error - :format-control - "A function with declared result type NIL returned:~% ~S" - :format-arguments (list function))) + :format-control + "A function with declared result type NIL returned:~% ~S" + :format-arguments (list function))) (deferr nil-array-accessed-error (array) (error 'nil-array-accessed-error - :datum array :expected-type '(not (array nil)))) + :datum array :expected-type '(not (array nil)))) (deferr division-by-zero-error (this that) (error 'division-by-zero - :operation 'division - :operands (list this that))) + :operation 'division + :operands (list this that))) (deferr object-not-type-error (object type) (error (if (and (typep object 'instance) - (layout-invalid (%instance-layout object))) - 'layout-invalid - 'type-error) - :datum object - :expected-type type)) + (layout-invalid (%instance-layout object))) + 'layout-invalid + 'type-error) + :datum object + :expected-type type)) (deferr layout-invalid-error (object layout) (error 'layout-invalid - :datum object - :expected-type (layout-classoid layout))) + :datum object + :expected-type (layout-classoid layout))) (deferr odd-key-args-error () (error 'simple-program-error - :format-control "odd number of &KEY arguments")) + :format-control "odd number of &KEY arguments")) (deferr unknown-key-arg-error (key-name) (error 'simple-program-error - :format-control "unknown &KEY argument: ~S" - :format-arguments (list key-name))) + :format-control "unknown &KEY argument: ~S" + :format-arguments (list key-name))) (deferr invalid-array-index-error (array bound index) (error 'simple-type-error - :format-control - "invalid array index ~W for ~S (should be nonnegative and <~W)" - :format-arguments (list index array bound) - :datum index - :expected-type `(integer 0 (,bound)))) + :format-control + "invalid array index ~W for ~S (should be nonnegative and <~W)" + :format-arguments (list index array bound) + :datum index + :expected-type `(integer 0 (,bound)))) (deferr object-not-simple-array-error (object) (error 'type-error - :datum object - :expected-type 'simple-array)) + :datum object + :expected-type 'simple-array)) (deferr object-not-signed-byte-32-error (object) (error 'type-error - :datum object - :expected-type '(signed-byte 32))) + :datum object + :expected-type '(signed-byte 32))) (deferr object-not-unsigned-byte-32-error (object) (error 'type-error - :datum object - :expected-type '(unsigned-byte 32))) + :datum object + :expected-type '(unsigned-byte 32))) (macrolet ((define-simple-array-internal-errors () - `(progn - ,@(map 'list - (lambda (saetp) - `(deferr ,(symbolicate - "OBJECT-NOT-" - (sb!vm:saetp-primitive-type-name saetp) - "-ERROR") - (object) - (error 'type-error - :datum object - :expected-type '(simple-array - ,(sb!vm:saetp-specifier saetp) - (*))))) - sb!vm:*specialized-array-element-type-properties*)))) + `(progn + ,@(map 'list + (lambda (saetp) + `(deferr ,(symbolicate + "OBJECT-NOT-" + (sb!vm:saetp-primitive-type-name saetp) + "-ERROR") + (object) + (error 'type-error + :datum object + :expected-type '(simple-array + ,(sb!vm:saetp-specifier saetp) + (*))))) + sb!vm:*specialized-array-element-type-properties*)))) (define-simple-array-internal-errors)) (deferr object-not-complex-error (object) (error 'type-error - :datum object - :expected-type 'complex)) + :datum object + :expected-type 'complex)) (deferr object-not-complex-rational-error (object) (error 'type-error - :datum object - :expected-type '(complex rational))) + :datum object + :expected-type '(complex rational))) (deferr object-not-complex-single-float-error (object) (error 'type-error - :datum object - :expected-type '(complex single-float))) + :datum object + :expected-type '(complex single-float))) (deferr object-not-complex-double-float-error (object) (error 'type-error - :datum object - :expected-type '(complex double-float))) + :datum object + :expected-type '(complex double-float))) #!+long-float (deferr object-not-complex-long-float-error (object) (error 'type-error - :datum object - :expected-type '(complex long-float))) + :datum object + :expected-type '(complex long-float))) (deferr object-not-weak-pointer-error (object) (error 'type-error - :datum object - :expected-type 'weak-pointer)) + :datum object + :expected-type 'weak-pointer)) (deferr object-not-instance-error (object) (error 'type-error - :datum object - :expected-type 'instance)) + :datum object + :expected-type 'instance)) (deferr object-not-complex-vector-error (object) (error 'type-error - :datum object - :expected-type '(and vector (not simple-array)))) + :datum object + :expected-type '(and vector (not simple-array)))) ;;;; fetching errorful function name @@ -351,44 +351,44 @@ (if *finding-name* (values "" nil) (handler-case - (let* ((*finding-name* t) - (frame (sb!di:frame-down (sb!di:frame-down (sb!di:top-frame)))) - (name (sb!di:debug-fun-name - (sb!di:frame-debug-fun frame)))) - (sb!di:flush-frames-above frame) - (values name frame)) - (error () - (values "" nil)) - (sb!di:debug-condition () - (values "" - nil))))) + (let* ((*finding-name* t) + (frame (sb!di:frame-down (sb!di:frame-down (sb!di:top-frame)))) + (name (sb!di:debug-fun-name + (sb!di:frame-debug-fun frame)))) + (sb!di:flush-frames-above frame) + (values name frame)) + (error () + (values "" nil)) + (sb!di:debug-condition () + (values "" + nil))))) (defun find-interrupted-name () (/show0 "entering FIND-INTERRUPTED-NAME") (if *finding-name* (values "" nil) (handler-case - (let ((*finding-name* t)) - (/show0 "in ordinary case") - (do ((frame (sb!di:top-frame) (sb!di:frame-down frame))) - ((null frame) - (/show0 "null frame") - (values "" nil)) - (/show0 "at head of DO loop") - (when (and (sb!di::compiled-frame-p frame) - (sb!di::compiled-frame-escaped frame)) - (sb!di:flush-frames-above frame) - (/show0 "returning from within DO loop") - (return (values (sb!di:debug-fun-name - (sb!di:frame-debug-fun frame)) - frame))))) - (error () - (/show0 "trapped ERROR") - (values "" nil)) - (sb!di:debug-condition () - (/show0 "trapped DEBUG-CONDITION") - (values "" - nil))))) + (let ((*finding-name* t)) + (/show0 "in ordinary case") + (do ((frame (sb!di:top-frame) (sb!di:frame-down frame))) + ((null frame) + (/show0 "null frame") + (values "" nil)) + (/show0 "at head of DO loop") + (when (and (sb!di::compiled-frame-p frame) + (sb!di::compiled-frame-escaped frame)) + (sb!di:flush-frames-above frame) + (/show0 "returning from within DO loop") + (return (values (sb!di:debug-fun-name + (sb!di:frame-debug-fun frame)) + frame))))) + (error () + (/show0 "trapped ERROR") + (values "" nil)) + (sb!di:debug-condition () + (/show0 "trapped DEBUG-CONDITION") + (values "" + nil))))) ;;;; INTERNAL-ERROR signal handler @@ -402,11 +402,11 @@ (infinite-error-protect (/show0 "about to bind ALIEN-CONTEXT") (let ((alien-context (locally - (declare (optimize (inhibit-warnings 3))) - (sb!alien:sap-alien context (* os-context-t))))) + (declare (optimize (inhibit-warnings 3))) + (sb!alien:sap-alien context (* os-context-t))))) (/show0 "about to bind ERROR-NUMBER and ARGUMENTS") (multiple-value-bind (error-number arguments) - (sb!vm:internal-error-args alien-context) + (sb!vm:internal-error-args alien-context) ;; There's a limit to how much error reporting we can usefully ;; do before initialization is complete, but try to be a little @@ -416,44 +416,44 @@ (/show0 "cold/low ARGUMENTS=..") (/hexstr arguments) (unless *cold-init-complete-p* - (%primitive print "can't recover from error in cold init, halting") - (%primitive sb!c:halt)) + (%primitive print "can't recover from error in cold init, halting") + (%primitive sb!c:halt)) (multiple-value-bind (name sb!debug:*stack-top-hint*) - (find-interrupted-name) - (/show0 "back from FIND-INTERRUPTED-NAME") - (let ((fp (int-sap (sb!vm:context-register alien-context - sb!vm::cfp-offset))) - (handler (and (< -1 error-number (length *internal-errors*)) - (svref *internal-errors* error-number)))) - (cond ((null handler) - (error 'simple-error - :format-control - "unknown internal error, ~D, args=~S" - :format-arguments - (list error-number - (mapcar (lambda (sc-offset) - (sb!di::sub-access-debug-var-slot - fp sc-offset alien-context)) - arguments)))) - ((not (functionp handler)) - (error 'simple-error - :format-control "internal error ~D: ~A; args=~S" - :format-arguments - (list error-number - handler - (mapcar (lambda (sc-offset) - (sb!di::sub-access-debug-var-slot - fp sc-offset alien-context)) - arguments)))) - (t - (funcall handler name fp alien-context arguments))))))))) + (find-interrupted-name) + (/show0 "back from FIND-INTERRUPTED-NAME") + (let ((fp (int-sap (sb!vm:context-register alien-context + sb!vm::cfp-offset))) + (handler (and (< -1 error-number (length *internal-errors*)) + (svref *internal-errors* error-number)))) + (cond ((null handler) + (error 'simple-error + :format-control + "unknown internal error, ~D, args=~S" + :format-arguments + (list error-number + (mapcar (lambda (sc-offset) + (sb!di::sub-access-debug-var-slot + fp sc-offset alien-context)) + arguments)))) + ((not (functionp handler)) + (error 'simple-error + :format-control "internal error ~D: ~A; args=~S" + :format-arguments + (list error-number + handler + (mapcar (lambda (sc-offset) + (sb!di::sub-access-debug-var-slot + fp sc-offset alien-context)) + arguments)))) + (t + (funcall handler name fp alien-context arguments))))))))) (defun control-stack-exhausted-error () (let ((sb!debug:*stack-top-hint* nil)) (infinite-error-protect (format *error-output* - "Control stack guard page temporarily disabled: proceed with caution~%") + "Control stack guard page temporarily disabled: proceed with caution~%") (error 'control-stack-exhausted)))) (defun undefined-alien-variable-error () diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 25a5f8b..9b901e8 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -43,7 +43,7 @@ #!+x86 ;; for constant folding (macrolet ((def (name ll) - `(defun ,name ,ll (,name ,@ll)))) + `(defun ,name ,ll (,name ,@ll)))) (def %atan2 (x y)) (def %atan (x)) (def %tan-quick (x)) @@ -91,7 +91,7 @@ (handle-reals %exp number) ((complex) (* (exp (realpart number)) - (cis (imagpart number)))))) + (cis (imagpart number)))))) ;;; INTEXP -- Handle the rational base, integer power case. @@ -105,20 +105,20 @@ ;;; integers, and inverted if negative. (defun intexp (base power) (when (and *intexp-maximum-exponent* - (> (abs power) *intexp-maximum-exponent*)) + (> (abs power) *intexp-maximum-exponent*)) (error "The absolute value of ~S exceeds ~S." - power '*intexp-maximum-exponent*)) + power '*intexp-maximum-exponent*)) (cond ((minusp power) - (/ (intexp base (- power)))) - ((eql base 2) - (ash 1 power)) - (t - (do ((nextn (ash power -1) (ash power -1)) - (total (if (oddp power) base 1) - (if (oddp power) (* base total) total))) - ((zerop nextn) total) - (setq base (* base base)) - (setq power nextn))))) + (/ (intexp base (- power)))) + ((eql base 2) + (ash 1 power)) + (t + (do ((nextn (ash power -1) (ash power -1)) + (total (if (oddp power) base 1) + (if (oddp power) (* base total) total))) + ((zerop nextn) total) + (setq base (* base base)) + (setq power nextn))))) ;;; If an integer power of a rational, use INTEXP above. Otherwise, do ;;; floating point stuff. If both args are real, we try %POW right @@ -131,154 +131,154 @@ "Return BASE raised to the POWER." (if (zerop power) (let ((result (1+ (* base power)))) - (if (and (floatp result) (float-nan-p result)) - (float 1 result) - result)) + (if (and (floatp result) (float-nan-p result)) + (float 1 result) + result)) (labels (;; determine if the double float is an integer. - ;; 0 - not an integer - ;; 1 - an odd int - ;; 2 - an even int - (isint (ihi lo) - (declare (type (unsigned-byte 31) ihi) - (type (unsigned-byte 32) lo) - (optimize (speed 3) (safety 0))) - (let ((isint 0)) - (declare (type fixnum isint)) - (cond ((>= ihi #x43400000) ; exponent >= 53 - (setq isint 2)) - ((>= ihi #x3ff00000) - (let ((k (- (ash ihi -20) #x3ff))) ; exponent - (declare (type (mod 53) k)) - (cond ((> k 20) - (let* ((shift (- 52 k)) - (j (logand (ash lo (- shift)))) - (j2 (ash j shift))) - (declare (type (mod 32) shift) - (type (unsigned-byte 32) j j2)) - (when (= j2 lo) - (setq isint (- 2 (logand j 1)))))) - ((= lo 0) - (let* ((shift (- 20 k)) - (j (ash ihi (- shift))) - (j2 (ash j shift))) - (declare (type (mod 32) shift) - (type (unsigned-byte 31) j j2)) - (when (= j2 ihi) - (setq isint (- 2 (logand j 1)))))))))) - isint)) - (real-expt (x y rtype) - (let ((x (coerce x 'double-float)) - (y (coerce y 'double-float))) - (declare (double-float x y)) - (let* ((x-hi (sb!kernel:double-float-high-bits x)) - (x-lo (sb!kernel:double-float-low-bits x)) - (x-ihi (logand x-hi #x7fffffff)) - (y-hi (sb!kernel:double-float-high-bits y)) - (y-lo (sb!kernel:double-float-low-bits y)) - (y-ihi (logand y-hi #x7fffffff))) - (declare (type (signed-byte 32) x-hi y-hi) - (type (unsigned-byte 31) x-ihi y-ihi) - (type (unsigned-byte 32) x-lo y-lo)) - ;; y==zero: x**0 = 1 - (when (zerop (logior y-ihi y-lo)) - (return-from real-expt (coerce 1d0 rtype))) - ;; +-NaN return x+y - (when (or (> x-ihi #x7ff00000) - (and (= x-ihi #x7ff00000) (/= x-lo 0)) - (> y-ihi #x7ff00000) - (and (= y-ihi #x7ff00000) (/= y-lo 0))) - (return-from real-expt (coerce (+ x y) rtype))) - (let ((yisint (if (< x-hi 0) (isint y-ihi y-lo) 0))) - (declare (type fixnum yisint)) - ;; special value of y - (when (and (zerop y-lo) (= y-ihi #x7ff00000)) - ;; y is +-inf - (return-from real-expt - (cond ((and (= x-ihi #x3ff00000) (zerop x-lo)) - ;; +-1**inf is NaN - (coerce (- y y) rtype)) - ((>= x-ihi #x3ff00000) - ;; (|x|>1)**+-inf = inf,0 - (if (>= y-hi 0) - (coerce y rtype) - (coerce 0 rtype))) - (t - ;; (|x|<1)**-,+inf = inf,0 - (if (< y-hi 0) - (coerce (- y) rtype) - (coerce 0 rtype)))))) + ;; 0 - not an integer + ;; 1 - an odd int + ;; 2 - an even int + (isint (ihi lo) + (declare (type (unsigned-byte 31) ihi) + (type (unsigned-byte 32) lo) + (optimize (speed 3) (safety 0))) + (let ((isint 0)) + (declare (type fixnum isint)) + (cond ((>= ihi #x43400000) ; exponent >= 53 + (setq isint 2)) + ((>= ihi #x3ff00000) + (let ((k (- (ash ihi -20) #x3ff))) ; exponent + (declare (type (mod 53) k)) + (cond ((> k 20) + (let* ((shift (- 52 k)) + (j (logand (ash lo (- shift)))) + (j2 (ash j shift))) + (declare (type (mod 32) shift) + (type (unsigned-byte 32) j j2)) + (when (= j2 lo) + (setq isint (- 2 (logand j 1)))))) + ((= lo 0) + (let* ((shift (- 20 k)) + (j (ash ihi (- shift))) + (j2 (ash j shift))) + (declare (type (mod 32) shift) + (type (unsigned-byte 31) j j2)) + (when (= j2 ihi) + (setq isint (- 2 (logand j 1)))))))))) + isint)) + (real-expt (x y rtype) + (let ((x (coerce x 'double-float)) + (y (coerce y 'double-float))) + (declare (double-float x y)) + (let* ((x-hi (sb!kernel:double-float-high-bits x)) + (x-lo (sb!kernel:double-float-low-bits x)) + (x-ihi (logand x-hi #x7fffffff)) + (y-hi (sb!kernel:double-float-high-bits y)) + (y-lo (sb!kernel:double-float-low-bits y)) + (y-ihi (logand y-hi #x7fffffff))) + (declare (type (signed-byte 32) x-hi y-hi) + (type (unsigned-byte 31) x-ihi y-ihi) + (type (unsigned-byte 32) x-lo y-lo)) + ;; y==zero: x**0 = 1 + (when (zerop (logior y-ihi y-lo)) + (return-from real-expt (coerce 1d0 rtype))) + ;; +-NaN return x+y + (when (or (> x-ihi #x7ff00000) + (and (= x-ihi #x7ff00000) (/= x-lo 0)) + (> y-ihi #x7ff00000) + (and (= y-ihi #x7ff00000) (/= y-lo 0))) + (return-from real-expt (coerce (+ x y) rtype))) + (let ((yisint (if (< x-hi 0) (isint y-ihi y-lo) 0))) + (declare (type fixnum yisint)) + ;; special value of y + (when (and (zerop y-lo) (= y-ihi #x7ff00000)) + ;; y is +-inf + (return-from real-expt + (cond ((and (= x-ihi #x3ff00000) (zerop x-lo)) + ;; +-1**inf is NaN + (coerce (- y y) rtype)) + ((>= x-ihi #x3ff00000) + ;; (|x|>1)**+-inf = inf,0 + (if (>= y-hi 0) + (coerce y rtype) + (coerce 0 rtype))) + (t + ;; (|x|<1)**-,+inf = inf,0 + (if (< y-hi 0) + (coerce (- y) rtype) + (coerce 0 rtype)))))) - (let ((abs-x (abs x))) - (declare (double-float abs-x)) - ;; special value of x - (when (and (zerop x-lo) - (or (= x-ihi #x7ff00000) (zerop x-ihi) - (= x-ihi #x3ff00000))) - ;; x is +-0,+-inf,+-1 - (let ((z (if (< y-hi 0) - (/ 1 abs-x) ; z = (1/|x|) - abs-x))) - (declare (double-float z)) - (when (< x-hi 0) - (cond ((and (= x-ihi #x3ff00000) (zerop yisint)) - ;; (-1)**non-int - (let ((y*pi (* y pi))) - (declare (double-float y*pi)) - (return-from real-expt - (complex - (coerce (%cos y*pi) rtype) - (coerce (%sin y*pi) rtype))))) - ((= yisint 1) - ;; (x<0)**odd = -(|x|**odd) - (setq z (- z))))) - (return-from real-expt (coerce z rtype)))) + (let ((abs-x (abs x))) + (declare (double-float abs-x)) + ;; special value of x + (when (and (zerop x-lo) + (or (= x-ihi #x7ff00000) (zerop x-ihi) + (= x-ihi #x3ff00000))) + ;; x is +-0,+-inf,+-1 + (let ((z (if (< y-hi 0) + (/ 1 abs-x) ; z = (1/|x|) + abs-x))) + (declare (double-float z)) + (when (< x-hi 0) + (cond ((and (= x-ihi #x3ff00000) (zerop yisint)) + ;; (-1)**non-int + (let ((y*pi (* y pi))) + (declare (double-float y*pi)) + (return-from real-expt + (complex + (coerce (%cos y*pi) rtype) + (coerce (%sin y*pi) rtype))))) + ((= yisint 1) + ;; (x<0)**odd = -(|x|**odd) + (setq z (- z))))) + (return-from real-expt (coerce z rtype)))) - (if (>= x-hi 0) - ;; x>0 - (coerce (sb!kernel::%pow x y) rtype) - ;; x<0 - (let ((pow (sb!kernel::%pow abs-x y))) - (declare (double-float pow)) - (case yisint - (1 ; odd - (coerce (* -1d0 pow) rtype)) - (2 ; even - (coerce pow rtype)) - (t ; non-integer - (let ((y*pi (* y pi))) - (declare (double-float y*pi)) - (complex - (coerce (* pow (%cos y*pi)) - rtype) - (coerce (* pow (%sin y*pi)) - rtype))))))))))))) + (if (>= x-hi 0) + ;; x>0 + (coerce (sb!kernel::%pow x y) rtype) + ;; x<0 + (let ((pow (sb!kernel::%pow abs-x y))) + (declare (double-float pow)) + (case yisint + (1 ; odd + (coerce (* -1d0 pow) rtype)) + (2 ; even + (coerce pow rtype)) + (t ; non-integer + (let ((y*pi (* y pi))) + (declare (double-float y*pi)) + (complex + (coerce (* pow (%cos y*pi)) + rtype) + (coerce (* pow (%sin y*pi)) + rtype))))))))))))) (declare (inline real-expt)) (number-dispatch ((base number) (power number)) - (((foreach fixnum (or bignum ratio) (complex rational)) integer) - (intexp base power)) - (((foreach single-float double-float) rational) - (real-expt base power '(dispatch-type base))) - (((foreach fixnum (or bignum ratio) single-float) - (foreach ratio single-float)) - (real-expt base power 'single-float)) - (((foreach fixnum (or bignum ratio) single-float double-float) - double-float) - (real-expt base power 'double-float)) - ((double-float single-float) - (real-expt base power 'double-float)) - (((foreach (complex rational) (complex float)) rational) - (* (expt (abs base) power) - (cis (* power (phase base))))) - (((foreach fixnum (or bignum ratio) single-float double-float) - complex) - (if (and (zerop base) (plusp (realpart power))) - (* base power) - (exp (* power (log base))))) - (((foreach (complex float) (complex rational)) - (foreach complex double-float single-float)) - (if (and (zerop base) (plusp (realpart power))) - (* base power) - (exp (* power (log base))))))))) + (((foreach fixnum (or bignum ratio) (complex rational)) integer) + (intexp base power)) + (((foreach single-float double-float) rational) + (real-expt base power '(dispatch-type base))) + (((foreach fixnum (or bignum ratio) single-float) + (foreach ratio single-float)) + (real-expt base power 'single-float)) + (((foreach fixnum (or bignum ratio) single-float double-float) + double-float) + (real-expt base power 'double-float)) + ((double-float single-float) + (real-expt base power 'double-float)) + (((foreach (complex rational) (complex float)) rational) + (* (expt (abs base) power) + (cis (* power (phase base))))) + (((foreach fixnum (or bignum ratio) single-float double-float) + complex) + (if (and (zerop base) (plusp (realpart power))) + (* base power) + (exp (* power (log base))))) + (((foreach (complex float) (complex rational)) + (foreach complex double-float single-float)) + (if (and (zerop base) (plusp (realpart power))) + (* base power) + (exp (* power (log base))))))))) ;;; FIXME: Maybe rename this so that it's clearer that it only works ;;; on integers? @@ -293,52 +293,52 @@ ;; Motivated by an attempt to get LOG to work better on bignums. (let ((n (integer-length x))) (if (< n sb!vm:double-float-digits) - (log (coerce x 'double-float) 2.0d0) - (let ((f (ldb (byte sb!vm:double-float-digits - (- n sb!vm:double-float-digits)) - x))) - (+ n (log (scale-float (coerce f 'double-float) - (- sb!vm:double-float-digits)) - 2.0d0)))))) + (log (coerce x 'double-float) 2.0d0) + (let ((f (ldb (byte sb!vm:double-float-digits + (- n sb!vm:double-float-digits)) + x))) + (+ n (log (scale-float (coerce f 'double-float) + (- sb!vm:double-float-digits)) + 2.0d0)))))) (defun log (number &optional (base nil base-p)) #!+sb-doc "Return the logarithm of NUMBER in the base BASE, which defaults to e." (if base-p (cond - ((zerop base) 0f0) ; FIXME: type - ((and (typep number '(integer (0) *)) - (typep base '(integer (0) *))) - (coerce (/ (log2 number) (log2 base)) 'single-float)) - (t (/ (log number) (log base)))) + ((zerop base) 0f0) ; FIXME: type + ((and (typep number '(integer (0) *)) + (typep base '(integer (0) *))) + (coerce (/ (log2 number) (log2 base)) 'single-float)) + (t (/ (log number) (log base)))) (number-dispatch ((number number)) - (((foreach fixnum bignum)) - (if (minusp number) - (complex (log (- number)) (coerce pi 'single-float)) - (coerce (/ (log2 number) (log (exp 1.0d0) 2.0d0)) 'single-float))) - ((ratio) - (if (minusp number) - (complex (log (- number)) (coerce pi 'single-float)) - (let ((numerator (numerator number)) - (denominator (denominator number))) - (if (= (integer-length numerator) - (integer-length denominator)) - (coerce (%log1p (coerce (- number 1) 'double-float)) - 'single-float) - (coerce (/ (- (log2 numerator) (log2 denominator)) - (log (exp 1.0d0) 2.0d0)) - 'single-float))))) - (((foreach single-float double-float)) - ;; Is (log -0) -infinity (libm.a) or -infinity + i*pi (Kahan)? - ;; Since this doesn't seem to be an implementation issue - ;; I (pw) take the Kahan result. - (if (< (float-sign number) - (coerce 0 '(dispatch-type number))) - (complex (log (- number)) (coerce pi '(dispatch-type number))) - (coerce (%log (coerce number 'double-float)) - '(dispatch-type number)))) - ((complex) - (complex-log number))))) + (((foreach fixnum bignum)) + (if (minusp number) + (complex (log (- number)) (coerce pi 'single-float)) + (coerce (/ (log2 number) (log (exp 1.0d0) 2.0d0)) 'single-float))) + ((ratio) + (if (minusp number) + (complex (log (- number)) (coerce pi 'single-float)) + (let ((numerator (numerator number)) + (denominator (denominator number))) + (if (= (integer-length numerator) + (integer-length denominator)) + (coerce (%log1p (coerce (- number 1) 'double-float)) + 'single-float) + (coerce (/ (- (log2 numerator) (log2 denominator)) + (log (exp 1.0d0) 2.0d0)) + 'single-float))))) + (((foreach single-float double-float)) + ;; Is (log -0) -infinity (libm.a) or -infinity + i*pi (Kahan)? + ;; Since this doesn't seem to be an implementation issue + ;; I (pw) take the Kahan result. + (if (< (float-sign number) + (coerce 0 '(dispatch-type number))) + (complex (log (- number)) (coerce pi '(dispatch-type number))) + (coerce (%log (coerce number 'double-float)) + '(dispatch-type number)))) + ((complex) + (complex-log number))))) (defun sqrt (number) #!+sb-doc @@ -346,13 +346,13 @@ (number-dispatch ((number number)) (((foreach fixnum bignum ratio)) (if (minusp number) - (complex-sqrt number) - (coerce (%sqrt (coerce number 'double-float)) 'single-float))) + (complex-sqrt number) + (coerce (%sqrt (coerce number 'double-float)) 'single-float))) (((foreach single-float double-float)) (if (minusp number) - (complex-sqrt (complex number)) - (coerce (%sqrt (coerce number 'double-float)) - '(dispatch-type number)))) + (complex-sqrt (complex number)) + (coerce (%sqrt (coerce number 'double-float)) + '(dispatch-type number)))) ((complex) (complex-sqrt number)))) @@ -366,16 +366,16 @@ (abs number)) ((complex) (let ((rx (realpart number)) - (ix (imagpart number))) + (ix (imagpart number))) (etypecase rx - (rational - (sqrt (+ (* rx rx) (* ix ix)))) - (single-float - (coerce (%hypot (coerce rx 'double-float) - (coerce ix 'double-float)) - 'single-float)) - (double-float - (%hypot rx ix))))))) + (rational + (sqrt (+ (* rx rx) (* ix ix)))) + (single-float + (coerce (%hypot (coerce rx 'double-float) + (coerce ix 'double-float)) + 'single-float)) + (double-float + (%hypot rx ix))))))) (defun phase (number) #!+sb-doc @@ -386,16 +386,16 @@ (etypecase number (rational (if (minusp number) - (coerce pi 'single-float) - 0.0f0)) + (coerce pi 'single-float) + 0.0f0)) (single-float (if (minusp (float-sign number)) - (coerce pi 'single-float) - 0.0f0)) + (coerce pi 'single-float) + 0.0f0)) (double-float (if (minusp (float-sign number)) - (coerce pi 'double-float) - 0.0d0)) + (coerce pi 'double-float) + 0.0d0)) (complex (atan (imagpart number) (realpart number))))) @@ -406,9 +406,9 @@ (handle-reals %sin number) ((complex) (let ((x (realpart number)) - (y (imagpart number))) + (y (imagpart number))) (complex (* (sin x) (cosh y)) - (* (cos x) (sinh y))))))) + (* (cos x) (sinh y))))))) (defun cos (number) #!+sb-doc @@ -417,9 +417,9 @@ (handle-reals %cos number) ((complex) (let ((x (realpart number)) - (y (imagpart number))) + (y (imagpart number))) (complex (* (cos x) (cosh y)) - (- (* (sin x) (sinh y)))))))) + (- (* (sin x) (sinh y)))))))) (defun tan (number) #!+sb-doc @@ -441,14 +441,14 @@ (number-dispatch ((number number)) ((rational) (if (or (> number 1) (< number -1)) - (complex-asin number) - (coerce (%asin (coerce number 'double-float)) 'single-float))) + (complex-asin number) + (coerce (%asin (coerce number 'double-float)) 'single-float))) (((foreach single-float double-float)) (if (or (> number (coerce 1 '(dispatch-type number))) - (< number (coerce -1 '(dispatch-type number)))) - (complex-asin (complex number)) - (coerce (%asin (coerce number 'double-float)) - '(dispatch-type number)))) + (< number (coerce -1 '(dispatch-type number)))) + (complex-asin (complex number)) + (coerce (%asin (coerce number 'double-float)) + '(dispatch-type number)))) ((complex) (complex-asin number)))) @@ -458,14 +458,14 @@ (number-dispatch ((number number)) ((rational) (if (or (> number 1) (< number -1)) - (complex-acos number) - (coerce (%acos (coerce number 'double-float)) 'single-float))) + (complex-acos number) + (coerce (%acos (coerce number 'double-float)) 'single-float))) (((foreach single-float double-float)) (if (or (> number (coerce 1 '(dispatch-type number))) - (< number (coerce -1 '(dispatch-type number)))) - (complex-acos (complex number)) - (coerce (%acos (coerce number 'double-float)) - '(dispatch-type number)))) + (< number (coerce -1 '(dispatch-type number)))) + (complex-acos (complex number)) + (coerce (%acos (coerce number 'double-float)) + '(dispatch-type number)))) ((complex) (complex-acos number)))) @@ -474,30 +474,30 @@ "Return the arc tangent of Y if X is omitted or Y/X if X is supplied." (if xp (flet ((atan2 (y x) - (declare (type double-float y x) - (values double-float)) - (if (zerop x) - (if (zerop y) - (if (plusp (float-sign x)) - y - (float-sign y pi)) - (float-sign y (/ pi 2))) - (%atan2 y x)))) - (number-dispatch ((y real) (x real)) - ((double-float - (foreach double-float single-float fixnum bignum ratio)) - (atan2 y (coerce x 'double-float))) - (((foreach single-float fixnum bignum ratio) - double-float) - (atan2 (coerce y 'double-float) x)) - (((foreach single-float fixnum bignum ratio) - (foreach single-float fixnum bignum ratio)) - (coerce (atan2 (coerce y 'double-float) (coerce x 'double-float)) - 'single-float)))) + (declare (type double-float y x) + (values double-float)) + (if (zerop x) + (if (zerop y) + (if (plusp (float-sign x)) + y + (float-sign y pi)) + (float-sign y (/ pi 2))) + (%atan2 y x)))) + (number-dispatch ((y real) (x real)) + ((double-float + (foreach double-float single-float fixnum bignum ratio)) + (atan2 y (coerce x 'double-float))) + (((foreach single-float fixnum bignum ratio) + double-float) + (atan2 (coerce y 'double-float) x)) + (((foreach single-float fixnum bignum ratio) + (foreach single-float fixnum bignum ratio)) + (coerce (atan2 (coerce y 'double-float) (coerce x 'double-float)) + 'single-float)))) (number-dispatch ((y number)) - (handle-reals %atan y) - ((complex) - (complex-atan y))))) + (handle-reals %atan y) + ((complex) + (complex-atan y))))) ;;; It seems that every target system has a C version of sinh, cosh, ;;; and tanh. Let's use these for reals because the original @@ -512,9 +512,9 @@ (handle-reals %sinh number) ((complex) (let ((x (realpart number)) - (y (imagpart number))) + (y (imagpart number))) (complex (* (sinh x) (cos y)) - (* (cosh x) (sin y))))))) + (* (cosh x) (sin y))))))) (defun cosh (number) #!+sb-doc @@ -523,9 +523,9 @@ (handle-reals %cosh number) ((complex) (let ((x (realpart number)) - (y (imagpart number))) + (y (imagpart number))) (complex (* (cosh x) (cos y)) - (* (sinh x) (sin y))))))) + (* (sinh x) (sin y))))))) (defun tanh (number) #!+sb-doc @@ -550,13 +550,13 @@ ((rational) ;; acosh is complex if number < 1 (if (< number 1) - (complex-acosh number) - (coerce (%acosh (coerce number 'double-float)) 'single-float))) + (complex-acosh number) + (coerce (%acosh (coerce number 'double-float)) 'single-float))) (((foreach single-float double-float)) (if (< number (coerce 1 '(dispatch-type number))) - (complex-acosh (complex number)) - (coerce (%acosh (coerce number 'double-float)) - '(dispatch-type number)))) + (complex-acosh (complex number)) + (coerce (%acosh (coerce number 'double-float)) + '(dispatch-type number)))) ((complex) (complex-acosh number)))) @@ -567,19 +567,19 @@ ((rational) ;; atanh is complex if |number| > 1 (if (or (> number 1) (< number -1)) - (complex-atanh number) - (coerce (%atanh (coerce number 'double-float)) 'single-float))) + (complex-atanh number) + (coerce (%atanh (coerce number 'double-float)) 'single-float))) (((foreach single-float double-float)) (if (or (> number (coerce 1 '(dispatch-type number))) - (< number (coerce -1 '(dispatch-type number)))) - (complex-atanh (complex number)) - (coerce (%atanh (coerce number 'double-float)) - '(dispatch-type number)))) + (< number (coerce -1 '(dispatch-type number)))) + (complex-atanh (complex number)) + (coerce (%atanh (coerce number 'double-float)) + '(dispatch-type number)))) ((complex) (complex-atanh number)))) ;;; HP-UX does not supply a C version of log1p, so use the definition. -;;; +;;; ;;; FIXME: This is really not a good definition. As per Raymond Toy ;;; working on CMU CL, "The definition really loses big-time in ;;; roundoff as x gets small." @@ -588,7 +588,7 @@ #!+hpux (defun %log1p (number) (declare (double-float number) - (optimize (speed 3) (safety 0))) + (optimize (speed 3) (safety 0))) (the double-float (log (the (double-float 0d0) (+ number 1d0))))) ;;;; not-OLD-SPECFUN stuff @@ -685,7 +685,7 @@ (declaim (inline scalb)) (defun scalb (x n) (declare (type double-float x) - (type double-float-exponent n)) + (type double-float-exponent n)) (scale-float x n)) ;;; This is like LOGB, but X is not infinity and non-zero and not a @@ -709,16 +709,16 @@ (defun logb (x) (declare (type double-float x)) (cond ((float-nan-p x) - x) - ((float-infinity-p x) - ;; DOUBLE-FLOAT-POSITIVE-INFINITY - (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0)) - ((zerop x) - ;; The answer is negative infinity, but we are supposed to + x) + ((float-infinity-p x) + ;; DOUBLE-FLOAT-POSITIVE-INFINITY + (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0)) + ((zerop x) + ;; The answer is negative infinity, but we are supposed to ;; signal divide-by-zero, so do the actual division - (/ -1.0d0 x) - ) - (t + (/ -1.0d0 x) + ) + (t (logb-finite x)))) ;;; This function is used to create a complex number of the @@ -727,26 +727,26 @@ ;;; such that has the same type as Z. If Z has type (complex ;;; rational), the X and Y are coerced to single-float. #!+long-float (eval-when (:compile-toplevel :load-toplevel :execute) - (error "needs work for long float support")) + (error "needs work for long float support")) (declaim (inline coerce-to-complex-type)) (defun coerce-to-complex-type (x y z) (declare (double-float x y) - (number z)) + (number z)) (if (typep (realpart z) 'double-float) (complex x y) ;; Convert anything that's not already a DOUBLE-FLOAT (because ;; the initial argument was a (COMPLEX DOUBLE-FLOAT) and we ;; haven't done anything to lose precision) to a SINGLE-FLOAT. (complex (float x 1f0) - (float y 1f0)))) + (float y 1f0)))) ;;; Compute |(x+i*y)/2^k|^2 scaled to avoid over/underflow. The ;;; result is r + i*k, where k is an integer. #!+long-float (eval-when (:compile-toplevel :load-toplevel :execute) - (error "needs work for long float support")) + (error "needs work for long float support")) (defun cssqs (z) (let ((x (float (realpart z) 1d0)) - (y (float (imagpart z) 1d0))) + (y (float (imagpart z) 1d0))) ;; Would this be better handled using an exception handler to ;; catch the overflow or underflow signal? For now, we turn all ;; traps off and look at the accrued exceptions to see if any @@ -755,23 +755,23 @@ (let ((rho (+ (square x) (square y)))) (declare (optimize (speed 3) (space 0))) (cond ((and (or (float-nan-p rho) - (float-infinity-p rho)) - (or (float-infinity-p (abs x)) - (float-infinity-p (abs y)))) - ;; DOUBLE-FLOAT-POSITIVE-INFINITY - (values - (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0) - 0)) - ((let ((threshold #.(/ least-positive-double-float - double-float-epsilon)) - (traps (ldb sb!vm::float-sticky-bits - (sb!vm:floating-point-modes)))) + (float-infinity-p rho)) + (or (float-infinity-p (abs x)) + (float-infinity-p (abs y)))) + ;; DOUBLE-FLOAT-POSITIVE-INFINITY + (values + (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0) + 0)) + ((let ((threshold #.(/ least-positive-double-float + double-float-epsilon)) + (traps (ldb sb!vm::float-sticky-bits + (sb!vm:floating-point-modes)))) ;; Overflow raised or (underflow raised and rho < ;; lambda/eps) - (or (not (zerop (logand sb!vm:float-overflow-trap-bit traps))) - (and (not (zerop (logand sb!vm:float-underflow-trap-bit - traps))) - (< rho threshold)))) + (or (not (zerop (logand sb!vm:float-overflow-trap-bit traps))) + (and (not (zerop (logand sb!vm:float-underflow-trap-bit + traps))) + (< rho threshold)))) ;; If we're here, neither x nor y are infinity and at ;; least one is non-zero.. Thus logb returns a nice ;; integer. @@ -798,9 +798,9 @@ (declare (type (or (member 0d0) (double-float 0d0)) rho) (type fixnum k)) (let ((x (float (realpart z) 1.0d0)) - (y (float (imagpart z) 1.0d0)) - (eta 0d0) - (nu 0d0)) + (y (float (imagpart z) 1.0d0)) + (eta 0d0) + (nu 0d0)) (declare (double-float x y eta nu)) (locally @@ -808,13 +808,13 @@ (declare (optimize (speed 3) (space 0))) (if (not (float-nan-p x)) - (setf rho (+ (scalb (abs x) (- k)) (sqrt rho)))) + (setf rho (+ (scalb (abs x) (- k)) (sqrt rho)))) (cond ((oddp k) - (setf k (ash k -1))) - (t - (setf k (1- (ash k -1))) - (setf rho (+ rho rho)))) + (setf k (ash k -1))) + (t + (setf k (1- (ash k -1))) + (setf rho (+ rho rho)))) (setf rho (scalb (sqrt rho) k)) @@ -822,42 +822,42 @@ (setf nu y) (when (/= rho 0d0) - (when (not (float-infinity-p (abs nu))) - (setf nu (/ (/ nu rho) 2d0))) - (when (< x 0d0) - (setf eta (abs nu)) - (setf nu (float-sign y rho)))) + (when (not (float-infinity-p (abs nu))) + (setf nu (/ (/ nu rho) 2d0))) + (when (< x 0d0) + (setf eta (abs nu)) + (setf nu (float-sign y rho)))) (coerce-to-complex-type eta nu z))))) - + ;;; Compute log(2^j*z). ;;; ;;; This is for use with J /= 0 only when |z| is huge. (defun complex-log-scaled (z j) (declare (type (or rational complex) z) - (fixnum j)) + (fixnum j)) ;; The constants t0, t1, t2 should be evaluated to machine ;; precision. In addition, Kahan says the accuracy of log1p ;; influences the choices of these constants but doesn't say how to ;; choose them. We'll just assume his choices matches our ;; implementation of log1p. (let ((t0 #.(/ 1 (sqrt 2.0d0))) - (t1 1.2d0) - (t2 3d0) - (ln2 #.(log 2d0)) - (x (float (realpart z) 1.0d0)) - (y (float (imagpart z) 1.0d0))) + (t1 1.2d0) + (t2 3d0) + (ln2 #.(log 2d0)) + (x (float (realpart z) 1.0d0)) + (y (float (imagpart z) 1.0d0))) (multiple-value-bind (rho k) - (cssqs z) + (cssqs z) (declare (optimize (speed 3))) (let ((beta (max (abs x) (abs y))) - (theta (min (abs x) (abs y)))) + (theta (min (abs x) (abs y)))) (coerce-to-complex-type (if (and (zerop k) - (< t0 beta) - (or (<= beta t1) - (< rho t2))) + (< t0 beta) + (or (<= beta t1) + (< rho t2))) (/ (%log1p (+ (* (- beta 1.0d0) - (+ beta 1.0d0)) - (* theta theta))) + (+ beta 1.0d0)) + (* theta theta))) 2d0) (+ (/ (log rho) 2d0) (* (+ k j) ln2))) @@ -870,7 +870,7 @@ (defun complex-log (z) (declare (type (or rational complex) z)) (complex-log-scaled z 0)) - + ;;; KLUDGE: Let us note the following "strange" behavior. atanh 1.0d0 ;;; is +infinity, but the following code returns approx 176 + i*pi/4. ;;; The reason for the imaginary part is caused by the fact that arg @@ -882,90 +882,90 @@ (theta (/ (sqrt most-positive-double-float) 4.0d0)) (rho (/ 4.0d0 (sqrt most-positive-double-float))) (half-pi (/ pi 2.0d0)) - (rp (float (realpart z) 1.0d0)) - (beta (float-sign rp 1.0d0)) - (x (* beta rp)) - (y (* beta (- (float (imagpart z) 1.0d0)))) - (eta 0.0d0) - (nu 0.0d0)) + (rp (float (realpart z) 1.0d0)) + (beta (float-sign rp 1.0d0)) + (x (* beta rp)) + (y (* beta (- (float (imagpart z) 1.0d0)))) + (eta 0.0d0) + (nu 0.0d0)) ;; Shouldn't need this declare. (declare (double-float x y)) (locally (declare (optimize (speed 3))) (cond ((or (> x theta) - (> (abs y) theta)) - ;; To avoid overflow... - (setf nu (float-sign y half-pi)) - ;; ETA is real part of 1/(x + iy). This is x/(x^2+y^2), - ;; which can cause overflow. Arrange this computation so - ;; that it won't overflow. - (setf eta (let* ((x-bigger (> x (abs y))) - (r (if x-bigger (/ y x) (/ x y))) - (d (+ 1.0d0 (* r r)))) - (if x-bigger - (/ (/ x) d) - (/ (/ r y) d))))) - ((= x 1.0d0) - ;; Should this be changed so that if y is zero, eta is set - ;; to +infinity instead of approx 176? In any case - ;; tanh(176) is 1.0d0 within working precision. - (let ((t1 (+ 4d0 (square y))) - (t2 (+ (abs y) rho))) - (setf eta (log (/ (sqrt (sqrt t1)) - (sqrt t2)))) - (setf nu (* 0.5d0 - (float-sign y - (+ half-pi (atan (* 0.5d0 t2)))))))) - (t - (let ((t1 (+ (abs y) rho))) + (> (abs y) theta)) + ;; To avoid overflow... + (setf nu (float-sign y half-pi)) + ;; ETA is real part of 1/(x + iy). This is x/(x^2+y^2), + ;; which can cause overflow. Arrange this computation so + ;; that it won't overflow. + (setf eta (let* ((x-bigger (> x (abs y))) + (r (if x-bigger (/ y x) (/ x y))) + (d (+ 1.0d0 (* r r)))) + (if x-bigger + (/ (/ x) d) + (/ (/ r y) d))))) + ((= x 1.0d0) + ;; Should this be changed so that if y is zero, eta is set + ;; to +infinity instead of approx 176? In any case + ;; tanh(176) is 1.0d0 within working precision. + (let ((t1 (+ 4d0 (square y))) + (t2 (+ (abs y) rho))) + (setf eta (log (/ (sqrt (sqrt t1)) + (sqrt t2)))) + (setf nu (* 0.5d0 + (float-sign y + (+ half-pi (atan (* 0.5d0 t2)))))))) + (t + (let ((t1 (+ (abs y) rho))) ;; Normal case using log1p(x) = log(1 + x) - (setf eta (* 0.25d0 - (%log1p (/ (* 4.0d0 x) - (+ (square (- 1.0d0 x)) - (square t1)))))) - (setf nu (* 0.5d0 - (atan (* 2.0d0 y) - (- (* (- 1.0d0 x) - (+ 1.0d0 x)) - (square t1)))))))) + (setf eta (* 0.25d0 + (%log1p (/ (* 4.0d0 x) + (+ (square (- 1.0d0 x)) + (square t1)))))) + (setf nu (* 0.5d0 + (atan (* 2.0d0 y) + (- (* (- 1.0d0 x) + (+ 1.0d0 x)) + (square t1)))))))) (coerce-to-complex-type (* beta eta) - (- (* beta nu)) + (- (* beta nu)) z)))) ;;; Compute tanh z = sinh z / cosh z. (defun complex-tanh (z) (declare (type (or rational complex) z)) (let ((x (float (realpart z) 1.0d0)) - (y (float (imagpart z) 1.0d0))) + (y (float (imagpart z) 1.0d0))) (locally ;; space 0 to get maybe-inline functions inlined (declare (optimize (speed 3) (space 0))) (cond ((> (abs x) - ;; FIXME: this form is hideously broken wrt - ;; cross-compilation portability. Much else in this - ;; file is too, of course, sometimes hidden by - ;; constant-folding, but this one in particular clearly - ;; depends on host and target - ;; MOST-POSITIVE-DOUBLE-FLOATs being equal. -- CSR, - ;; 2003-04-20 - #.(/ (+ (log 2.0d0) - (log most-positive-double-float)) - 4d0)) - (coerce-to-complex-type (float-sign x) - (float-sign y) z)) - (t - (let* ((tv (%tan y)) - (beta (+ 1.0d0 (* tv tv))) - (s (sinh x)) - (rho (sqrt (+ 1.0d0 (* s s))))) - (if (float-infinity-p (abs tv)) - (coerce-to-complex-type (/ rho s) - (/ tv) - z) - (let ((den (+ 1.0d0 (* beta s s)))) - (coerce-to-complex-type (/ (* beta rho s) - den) - (/ tv den) + ;; FIXME: this form is hideously broken wrt + ;; cross-compilation portability. Much else in this + ;; file is too, of course, sometimes hidden by + ;; constant-folding, but this one in particular clearly + ;; depends on host and target + ;; MOST-POSITIVE-DOUBLE-FLOATs being equal. -- CSR, + ;; 2003-04-20 + #.(/ (+ (log 2.0d0) + (log most-positive-double-float)) + 4d0)) + (coerce-to-complex-type (float-sign x) + (float-sign y) z)) + (t + (let* ((tv (%tan y)) + (beta (+ 1.0d0 (* tv tv))) + (s (sinh x)) + (rho (sqrt (+ 1.0d0 (* s s))))) + (if (float-infinity-p (abs tv)) + (coerce-to-complex-type (/ rho s) + (/ tv) + z) + (let ((den (+ 1.0d0 (* beta s s)))) + (coerce-to-complex-type (/ (* beta rho s) + den) + (/ tv den) z))))))))) ;;; Compute acos z = pi/2 - asin z. @@ -995,12 +995,12 @@ ;; -arg z, which is clearly true for all z. (declare (type (or rational complex) z)) (let ((sqrt-1+z (complex-sqrt (+ 1 z))) - (sqrt-1-z (complex-sqrt (- 1 z)))) + (sqrt-1-z (complex-sqrt (- 1 z)))) (with-float-traps-masked (:divide-by-zero) (complex (* 2 (atan (/ (realpart sqrt-1-z) - (realpart sqrt-1+z)))) - (asinh (imagpart (* (conjugate sqrt-1+z) - sqrt-1-z))))))) + (realpart sqrt-1+z)))) + (asinh (imagpart (* (conjugate sqrt-1+z) + sqrt-1-z))))))) ;;; Compute acosh z = 2 * log(sqrt((z+1)/2) + sqrt((z-1)/2)) ;;; @@ -1008,12 +1008,12 @@ (defun complex-acosh (z) (declare (type (or rational complex) z)) (let ((sqrt-z-1 (complex-sqrt (- z 1))) - (sqrt-z+1 (complex-sqrt (+ z 1)))) + (sqrt-z+1 (complex-sqrt (+ z 1)))) (with-float-traps-masked (:divide-by-zero) (complex (asinh (realpart (* (conjugate sqrt-z-1) - sqrt-z+1))) - (* 2 (atan (/ (imagpart sqrt-z-1) - (realpart sqrt-z+1)))))))) + sqrt-z+1))) + (* 2 (atan (/ (imagpart sqrt-z-1) + (realpart sqrt-z+1)))))))) ;;; Compute asin z = asinh(i*z)/i. ;;; @@ -1021,12 +1021,12 @@ (defun complex-asin (z) (declare (type (or rational complex) z)) (let ((sqrt-1-z (complex-sqrt (- 1 z))) - (sqrt-1+z (complex-sqrt (+ 1 z)))) + (sqrt-1+z (complex-sqrt (+ 1 z)))) (with-float-traps-masked (:divide-by-zero) (complex (atan (/ (realpart z) - (realpart (* sqrt-1-z sqrt-1+z)))) - (asinh (imagpart (* (conjugate sqrt-1-z) - sqrt-1+z))))))) + (realpart (* sqrt-1-z sqrt-1+z)))) + (asinh (imagpart (* (conjugate sqrt-1-z) + sqrt-1+z))))))) ;;; Compute asinh z = log(z + sqrt(1 + z*z)). ;;; @@ -1035,10 +1035,10 @@ (declare (type (or rational complex) z)) ;; asinh z = -i * asin (i*z) (let* ((iz (complex (- (imagpart z)) (realpart z))) - (result (complex-asin iz))) + (result (complex-asin iz))) (complex (imagpart result) - (- (realpart result))))) - + (- (realpart result))))) + ;;; Compute atan z = atanh (i*z) / i. ;;; ;;; Z may be any number, but the result is always a complex. @@ -1046,9 +1046,9 @@ (declare (type (or rational complex) z)) ;; atan z = -i * atanh (i*z) (let* ((iz (complex (- (imagpart z)) (realpart z))) - (result (complex-atanh iz))) + (result (complex-atanh iz))) (complex (imagpart result) - (- (realpart result))))) + (- (realpart result))))) ;;; Compute tan z = -i * tanh(i * z) ;;; @@ -1057,6 +1057,6 @@ (declare (type (or rational complex) z)) ;; tan z = -i * tanh(i*z) (let* ((iz (complex (- (imagpart z)) (realpart z))) - (result (complex-tanh iz))) + (result (complex-tanh iz))) (complex (imagpart result) - (- (realpart result))))) + (- (realpart result))))) diff --git a/src/code/koi8-r.lisp b/src/code/koi8-r.lisp index ef91310..d9ec2af 100644 --- a/src/code/koi8-r.lisp +++ b/src/code/koi8-r.lisp @@ -139,14 +139,14 @@ (declaim (inline get-koi8-r-bytes)) (defun get-koi8-r-bytes (string pos end) (declare (optimize speed (safety 0)) - (type simple-string string) - (type array-range pos end)) + (type simple-string string) + (type array-range pos end)) (get-latin-bytes #'identity :koi8-r string pos end)) (defun string->koi8-r (string sstart send null-padding) (declare (optimize speed (safety 0)) - (type simple-string string) - (type array-range sstart send)) + (type simple-string string) + (type array-range sstart send)) (values (string->latin% string sstart send #'get-koi8-r-bytes null-padding))) (defmacro define-koi8-r->string* (accessor type) @@ -154,7 +154,7 @@ (let ((name (make-od-name 'koi8-r->string* accessor))) `(progn (defun ,name (string sstart send array astart aend) - (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'identity))))) + (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'identity))))) (instantiate-octets-definition define-koi8-r->string*) (defmacro define-koi8-r->string (accessor type) diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp index 4b71114..a841f90 100644 --- a/src/code/late-extensions.lisp +++ b/src/code/late-extensions.lisp @@ -20,12 +20,12 @@ (defun list-with-length-p (x) (values (ignore-errors (list-length x)))) -;;; not used in 0.7.8, but possibly useful for defensive programming +;;; not used in 0.7.8, but possibly useful for defensive programming ;;; in e.g. (COERCE ... 'VECTOR) ;;;(defun list-length-or-die (x) ;;; (or (list-length x) ;;; ;; not clear how to do this best: -;;; ;; * Should this be a TYPE-ERROR? Colloquially that'd make +;;; ;; * Should this be a TYPE-ERROR? Colloquially that'd make ;;; ;; lots of sense, but since I'm not sure how to express ;;; ;; "noncircular list" as a Lisp type expression, coding ;;; ;; it seems awkward. diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index 88ff777..4e262c0 100644 --- a/src/code/late-format.lisp +++ b/src/code/late-format.lisp @@ -13,26 +13,26 @@ ((complaint :reader format-error-complaint :initarg :complaint) (args :reader format-error-args :initarg :args :initform nil) (control-string :reader format-error-control-string - :initarg :control-string - :initform *default-format-error-control-string*) + :initarg :control-string + :initform *default-format-error-control-string*) (offset :reader format-error-offset :initarg :offset - :initform *default-format-error-offset*) + :initform *default-format-error-offset*) (second-relative :reader format-error-second-relative :initarg :second-relative :initform nil) (print-banner :reader format-error-print-banner :initarg :print-banner - :initform t)) + :initform t)) (:report %print-format-error) (:default-initargs :references nil)) (defun %print-format-error (condition stream) (format stream - "~:[~*~;error in ~S: ~]~?~@[~% ~A~% ~V@T^~@[~V@T^~]~]" - (format-error-print-banner condition) + "~:[~*~;error in ~S: ~]~?~@[~% ~A~% ~V@T^~@[~V@T^~]~]" + (format-error-print-banner condition) 'format - (format-error-complaint condition) - (format-error-args condition) - (format-error-control-string condition) - (format-error-offset condition) + (format-error-complaint condition) + (format-error-args condition) + (format-error-control-string condition) + (format-error-offset condition) (format-error-second-relative condition))) (def!struct format-directive @@ -46,17 +46,17 @@ (def!method print-object ((x format-directive) stream) (print-unreadable-object (x stream) (write-string (format-directive-string x) - stream - :start (format-directive-start x) - :end (format-directive-end x)))) + stream + :start (format-directive-start x) + :end (format-directive-end x)))) ;;;; TOKENIZE-CONTROL-STRING (defun tokenize-control-string (string) (declare (simple-string string)) (let ((index 0) - (end (length string)) - (result nil) + (end (length string)) + (result nil) ;; FIXME: consider rewriting this 22.3.5.2-related processing ;; using specials to maintain state and doing the logic inside ;; the directive expanders themselves. @@ -66,11 +66,11 @@ (justification-semicolon)) (loop (let ((next-directive (or (position #\~ string :start index) end))) - (when (> next-directive index) - (push (subseq string index next-directive) result)) - (when (= next-directive end) - (return)) - (let* ((directive (parse-directive string next-directive)) + (when (> next-directive index) + (push (subseq string index next-directive) result)) + (when (= next-directive end) + (return)) + (let* ((directive (parse-directive string next-directive)) (char (format-directive-character directive))) ;; this processing is required by CLHS 22.3.5.2 (cond @@ -95,8 +95,8 @@ (#\T (when (and (format-directive-colonp directive) (not pprint)) (setf pprint directive)))))) - (push directive result) - (setf index (format-directive-end directive))))) + (push directive result) + (setf index (format-directive-end directive))))) (when (and pprint justification-semicolon) (let ((pprint-offset (1- (format-directive-end pprint))) (justification-offset @@ -113,104 +113,104 @@ (defun parse-directive (string start) (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil) - (end (length string))) + (end (length string))) (flet ((get-char () - (if (= posn end) - (error 'format-error - :complaint "string ended before directive was found" - :control-string string - :offset start) - (schar string posn))) - (check-ordering () - (when (or colonp atsignp) - (error 'format-error - :complaint "parameters found after #\\: or #\\@ modifier" - :control-string string - :offset posn + (if (= posn end) + (error 'format-error + :complaint "string ended before directive was found" + :control-string string + :offset start) + (schar string posn))) + (check-ordering () + (when (or colonp atsignp) + (error 'format-error + :complaint "parameters found after #\\: or #\\@ modifier" + :control-string string + :offset posn :references (list '(:ansi-cl :section (22 3))))))) (loop - (let ((char (get-char))) - (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-)) - (check-ordering) - (multiple-value-bind (param new-posn) - (parse-integer string :start posn :junk-allowed t) - (push (cons posn param) params) - (setf posn new-posn) - (case (get-char) - (#\,) - ((#\: #\@) - (decf posn)) - (t - (return))))) - ((or (char= char #\v) - (char= char #\V)) - (check-ordering) - (push (cons posn :arg) params) - (incf posn) - (case (get-char) - (#\,) - ((#\: #\@) - (decf posn)) - (t - (return)))) - ((char= char #\#) - (check-ordering) - (push (cons posn :remaining) params) - (incf posn) - (case (get-char) - (#\,) - ((#\: #\@) - (decf posn)) - (t - (return)))) - ((char= char #\') - (check-ordering) - (incf posn) - (push (cons posn (get-char)) params) - (incf posn) - (unless (char= (get-char) #\,) - (decf posn))) - ((char= char #\,) - (check-ordering) - (push (cons posn nil) params)) - ((char= char #\:) - (if colonp - (error 'format-error - :complaint "too many colons supplied" - :control-string string - :offset posn + (let ((char (get-char))) + (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-)) + (check-ordering) + (multiple-value-bind (param new-posn) + (parse-integer string :start posn :junk-allowed t) + (push (cons posn param) params) + (setf posn new-posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return))))) + ((or (char= char #\v) + (char= char #\V)) + (check-ordering) + (push (cons posn :arg) params) + (incf posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return)))) + ((char= char #\#) + (check-ordering) + (push (cons posn :remaining) params) + (incf posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return)))) + ((char= char #\') + (check-ordering) + (incf posn) + (push (cons posn (get-char)) params) + (incf posn) + (unless (char= (get-char) #\,) + (decf posn))) + ((char= char #\,) + (check-ordering) + (push (cons posn nil) params)) + ((char= char #\:) + (if colonp + (error 'format-error + :complaint "too many colons supplied" + :control-string string + :offset posn :references (list '(:ansi-cl :section (22 3)))) - (setf colonp t))) - ((char= char #\@) - (if atsignp - (error 'format-error - :complaint "too many #\\@ characters supplied" - :control-string string - :offset posn + (setf colonp t))) + ((char= char #\@) + (if atsignp + (error 'format-error + :complaint "too many #\\@ characters supplied" + :control-string string + :offset posn :references (list '(:ansi-cl :section (22 3)))) - (setf atsignp t))) - (t - (when (and (char= (schar string (1- posn)) #\,) - (or (< posn 2) - (char/= (schar string (- posn 2)) #\'))) - (check-ordering) - (push (cons (1- posn) nil) params)) - (return)))) - (incf posn)) + (setf atsignp t))) + (t + (when (and (char= (schar string (1- posn)) #\,) + (or (< posn 2) + (char/= (schar string (- posn 2)) #\'))) + (check-ordering) + (push (cons (1- posn) nil) params)) + (return)))) + (incf posn)) (let ((char (get-char))) - (when (char= char #\/) - (let ((closing-slash (position #\/ string :start (1+ posn)))) - (if closing-slash - (setf posn closing-slash) - (error 'format-error - :complaint "no matching closing slash" - :control-string string - :offset posn)))) - (make-format-directive - :string string :start start :end (1+ posn) - :character (char-upcase char) - :colonp colonp :atsignp atsignp - :params (nreverse params)))))) + (when (char= char #\/) + (let ((closing-slash (position #\/ string :start (1+ posn)))) + (if closing-slash + (setf posn closing-slash) + (error 'format-error + :complaint "no matching closing slash" + :control-string string + :offset posn)))) + (make-format-directive + :string string :start start :end (1+ posn) + :character (char-upcase char) + :colonp colonp :atsignp atsignp + :params (nreverse params)))))) ;;;; FORMATTER stuff @@ -221,49 +221,49 @@ (block nil (catch 'need-orig-args (let* ((*simple-args* nil) - (*only-simple-args* t) - (guts (expand-control-string control-string)) - (args nil)) - (dolist (arg *simple-args*) - (push `(,(car arg) - (error - 'format-error - :complaint "required argument missing" - :control-string ,control-string - :offset ,(cdr arg))) - args)) - (return `(lambda (stream &optional ,@args &rest args) - ,guts - args)))) + (*only-simple-args* t) + (guts (expand-control-string control-string)) + (args nil)) + (dolist (arg *simple-args*) + (push `(,(car arg) + (error + 'format-error + :complaint "required argument missing" + :control-string ,control-string + :offset ,(cdr arg))) + args)) + (return `(lambda (stream &optional ,@args &rest args) + ,guts + args)))) (let ((*orig-args-available* t) - (*only-simple-args* nil)) + (*only-simple-args* nil)) `(lambda (stream &rest orig-args) - (let ((args orig-args)) - ,(expand-control-string control-string) - args))))) + (let ((args orig-args)) + ,(expand-control-string control-string) + args))))) (defun expand-control-string (string) (let* ((string (etypecase string - (simple-string - string) - (string - (coerce string 'simple-string)))) - (*default-format-error-control-string* string) - (directives (tokenize-control-string string))) + (simple-string + string) + (string + (coerce string 'simple-string)))) + (*default-format-error-control-string* string) + (directives (tokenize-control-string string))) `(block nil ,@(expand-directive-list directives)))) (defun expand-directive-list (directives) (let ((results nil) - (remaining-directives directives)) + (remaining-directives directives)) (loop (unless remaining-directives - (return)) + (return)) (multiple-value-bind (form new-directives) - (expand-directive (car remaining-directives) - (cdr remaining-directives)) - (push form results) - (setf remaining-directives new-directives))) + (expand-directive (car remaining-directives) + (cdr remaining-directives)) + (push form results) + (setf remaining-directives new-directives))) (reverse results))) (defun expand-directive (directive more-directives) @@ -275,112 +275,112 @@ (base-char (aref *format-directive-expanders* (char-code char))) (character nil)))) - (*default-format-error-offset* - (1- (format-directive-end directive)))) + (*default-format-error-offset* + (1- (format-directive-end directive)))) (declare (type (or null function) expander)) (if expander - (funcall expander directive more-directives) - (error 'format-error - :complaint "unknown directive ~@[(character: ~A)~]" - :args (list (char-name (format-directive-character directive))))))) + (funcall expander directive more-directives) + (error 'format-error + :complaint "unknown directive ~@[(character: ~A)~]" + :args (list (char-name (format-directive-character directive))))))) (simple-string (values `(write-string ,directive stream) - more-directives)))) + more-directives)))) (defmacro-mundanely expander-next-arg (string offset) `(if args (pop args) (error 'format-error - :complaint "no more arguments" - :control-string ,string - :offset ,offset))) + :complaint "no more arguments" + :control-string ,string + :offset ,offset))) (defun expand-next-arg (&optional offset) (if (or *orig-args-available* (not *only-simple-args*)) `(,*expander-next-arg-macro* - ,*default-format-error-control-string* - ,(or offset *default-format-error-offset*)) + ,*default-format-error-control-string* + ,(or offset *default-format-error-offset*)) (let ((symbol (gensym "FORMAT-ARG-"))) - (push (cons symbol (or offset *default-format-error-offset*)) - *simple-args*) - symbol))) + (push (cons symbol (or offset *default-format-error-offset*)) + *simple-args*) + symbol))) (defmacro expand-bind-defaults (specs params &body body) (once-only ((params params)) (if specs - (collect ((expander-bindings) (runtime-bindings)) - (dolist (spec specs) - (destructuring-bind (var default) spec - (let ((symbol (gensym))) - (expander-bindings - `(,var ',symbol)) - (runtime-bindings - `(list ',symbol - (let* ((param-and-offset (pop ,params)) - (offset (car param-and-offset)) - (param (cdr param-and-offset))) - (case param - (:arg `(or ,(expand-next-arg offset) - ,,default)) - (:remaining - (setf *only-simple-args* nil) - '(length args)) - ((nil) ,default) - (t param)))))))) - `(let ,(expander-bindings) - `(let ,(list ,@(runtime-bindings)) - ,@(if ,params - (error - 'format-error - :complaint - "too many parameters, expected no more than ~W" - :args (list ,(length specs)) - :offset (caar ,params))) - ,,@body))) - `(progn - (when ,params - (error 'format-error - :complaint "too many parameters, expected none" - :offset (caar ,params))) - ,@body)))) + (collect ((expander-bindings) (runtime-bindings)) + (dolist (spec specs) + (destructuring-bind (var default) spec + (let ((symbol (gensym))) + (expander-bindings + `(,var ',symbol)) + (runtime-bindings + `(list ',symbol + (let* ((param-and-offset (pop ,params)) + (offset (car param-and-offset)) + (param (cdr param-and-offset))) + (case param + (:arg `(or ,(expand-next-arg offset) + ,,default)) + (:remaining + (setf *only-simple-args* nil) + '(length args)) + ((nil) ,default) + (t param)))))))) + `(let ,(expander-bindings) + `(let ,(list ,@(runtime-bindings)) + ,@(if ,params + (error + 'format-error + :complaint + "too many parameters, expected no more than ~W" + :args (list ,(length specs)) + :offset (caar ,params))) + ,,@body))) + `(progn + (when ,params + (error 'format-error + :complaint "too many parameters, expected none" + :offset (caar ,params))) + ,@body)))) ;;;; format directive machinery ;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN (defmacro def-complex-format-directive (char lambda-list &body body) (let ((defun-name (intern (format nil - "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER" - char))) - (directive (gensym)) - (directives (if lambda-list (car (last lambda-list)) (gensym)))) + "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER" + char))) + (directive (gensym)) + (directives (if lambda-list (car (last lambda-list)) (gensym)))) `(progn (defun ,defun-name (,directive ,directives) - ,@(if lambda-list - `((let ,(mapcar (lambda (var) - `(,var - (,(symbolicate "FORMAT-DIRECTIVE-" var) - ,directive))) - (butlast lambda-list)) - ,@body)) - `((declare (ignore ,directive ,directives)) - ,@body))) + ,@(if lambda-list + `((let ,(mapcar (lambda (var) + `(,var + (,(symbolicate "FORMAT-DIRECTIVE-" var) + ,directive))) + (butlast lambda-list)) + ,@body)) + `((declare (ignore ,directive ,directives)) + ,@body))) (%set-format-directive-expander ,char #',defun-name)))) ;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN (defmacro def-format-directive (char lambda-list &body body) (let ((directives (gensym)) - (declarations nil) - (body-without-decls body)) + (declarations nil) + (body-without-decls body)) (loop (let ((form (car body-without-decls))) - (unless (and (consp form) (eq (car form) 'declare)) - (return)) - (push (pop body-without-decls) declarations))) + (unless (and (consp form) (eq (car form) 'declare)) + (return)) + (push (pop body-without-decls) declarations))) (setf declarations (reverse declarations)) `(def-complex-format-directive ,char (,@lambda-list ,directives) ,@declarations (values (progn ,@body-without-decls) - ,directives)))) + ,directives)))) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) @@ -390,32 +390,32 @@ (defun %set-format-directive-interpreter (char fn) (setf (aref *format-directive-interpreters* - (char-code (char-upcase char))) - fn) + (char-code (char-upcase char))) + fn) char) (defun find-directive (directives kind stop-at-semi) (if directives (let ((next (car directives))) - (if (format-directive-p next) - (let ((char (format-directive-character next))) - (if (or (char= kind char) - (and stop-at-semi (char= char #\;))) - (car directives) - (find-directive - (cdr (flet ((after (char) - (member (find-directive (cdr directives) - char - nil) - directives))) - (case char - (#\( (after #\))) - (#\< (after #\>)) - (#\[ (after #\])) - (#\{ (after #\})) - (t directives)))) - kind stop-at-semi))) - (find-directive (cdr directives) kind stop-at-semi))))) + (if (format-directive-p next) + (let ((char (format-directive-character next))) + (if (or (char= kind char) + (and stop-at-semi (char= char #\;))) + (car directives) + (find-directive + (cdr (flet ((after (char) + (member (find-directive (cdr directives) + char + nil) + directives))) + (case char + (#\( (after #\))) + (#\< (after #\>)) + (#\[ (after #\])) + (#\{ (after #\})) + (t directives)))) + kind stop-at-semi))) + (find-directive (cdr directives) kind stop-at-semi))))) ) ; EVAL-WHEN @@ -424,61 +424,61 @@ (def-format-directive #\A (colonp atsignp params) (if params (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) - (padchar #\space)) - params - `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp - ,mincol ,colinc ,minpad ,padchar)) + (padchar #\space)) + params + `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp + ,mincol ,colinc ,minpad ,padchar)) `(princ ,(if colonp - `(or ,(expand-next-arg) "()") - (expand-next-arg)) - stream))) + `(or ,(expand-next-arg) "()") + (expand-next-arg)) + stream))) (def-format-directive #\S (colonp atsignp params) (cond (params - (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) - (padchar #\space)) - params - `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp - ,mincol ,colinc ,minpad ,padchar))) - (colonp - `(let ((arg ,(expand-next-arg))) - (if arg - (prin1 arg stream) - (princ "()" stream)))) - (t - `(prin1 ,(expand-next-arg) stream)))) + (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) + (padchar #\space)) + params + `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp + ,mincol ,colinc ,minpad ,padchar))) + (colonp + `(let ((arg ,(expand-next-arg))) + (if arg + (prin1 arg stream) + (princ "()" stream)))) + (t + `(prin1 ,(expand-next-arg) stream)))) (def-format-directive #\C (colonp atsignp params) (expand-bind-defaults () params (if colonp - `(format-print-named-character ,(expand-next-arg) stream) - (if atsignp - `(prin1 ,(expand-next-arg) stream) - `(write-char ,(expand-next-arg) stream))))) + `(format-print-named-character ,(expand-next-arg) stream) + (if atsignp + `(prin1 ,(expand-next-arg) stream) + `(write-char ,(expand-next-arg) stream))))) (def-format-directive #\W (colonp atsignp params) (expand-bind-defaults () params (if (or colonp atsignp) - `(let (,@(when colonp - '((*print-pretty* t))) - ,@(when atsignp - '((*print-level* nil) - (*print-length* nil)))) - (output-object ,(expand-next-arg) stream)) - `(output-object ,(expand-next-arg) stream)))) + `(let (,@(when colonp + '((*print-pretty* t))) + ,@(when atsignp + '((*print-level* nil) + (*print-length* nil)))) + (output-object ,(expand-next-arg) stream)) + `(output-object ,(expand-next-arg) stream)))) ;;;; format directives for integer output (defun expand-format-integer (base colonp atsignp params) (if (or colonp atsignp params) (expand-bind-defaults - ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) - params - `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp - ,base ,mincol ,padchar ,commachar - ,commainterval)) + ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) + params + `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp + ,base ,mincol ,padchar ,commachar + ,commainterval)) `(write ,(expand-next-arg) :stream stream :base ,base :radix nil - :escape nil))) + :escape nil))) (def-format-directive #\D (colonp atsignp params) (expand-format-integer 10 colonp atsignp params)) @@ -497,73 +497,73 @@ ((base nil) (mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) params - (let ((n-arg (gensym))) + (let ((n-arg (gensym))) `(let ((,n-arg ,(expand-next-arg))) (if ,base (format-print-integer stream ,n-arg ,colonp ,atsignp - ,base ,mincol - ,padchar ,commachar ,commainterval) + ,base ,mincol + ,padchar ,commachar ,commainterval) ,(if atsignp (if colonp `(format-print-old-roman stream ,n-arg) `(format-print-roman stream ,n-arg)) (if colonp `(format-print-ordinal stream ,n-arg) - `(format-print-cardinal stream ,n-arg)))))))) + `(format-print-cardinal stream ,n-arg)))))))) ;;;; format directive for pluralization (def-format-directive #\P (colonp atsignp params end) (expand-bind-defaults () params (let ((arg (cond - ((not colonp) - (expand-next-arg)) - (*orig-args-available* - `(if (eq orig-args args) - (error 'format-error - :complaint "no previous argument" - :offset ,(1- end)) - (do ((arg-ptr orig-args (cdr arg-ptr))) - ((eq (cdr arg-ptr) args) - (car arg-ptr))))) - (*only-simple-args* - (unless *simple-args* - (error 'format-error - :complaint "no previous argument")) - (caar *simple-args*)) - (t - (/show0 "THROWing NEED-ORIG-ARGS from tilde-P") - (throw 'need-orig-args nil))))) + ((not colonp) + (expand-next-arg)) + (*orig-args-available* + `(if (eq orig-args args) + (error 'format-error + :complaint "no previous argument" + :offset ,(1- end)) + (do ((arg-ptr orig-args (cdr arg-ptr))) + ((eq (cdr arg-ptr) args) + (car arg-ptr))))) + (*only-simple-args* + (unless *simple-args* + (error 'format-error + :complaint "no previous argument")) + (caar *simple-args*)) + (t + (/show0 "THROWing NEED-ORIG-ARGS from tilde-P") + (throw 'need-orig-args nil))))) (if atsignp - `(write-string (if (eql ,arg 1) "y" "ies") stream) - `(unless (eql ,arg 1) (write-char #\s stream)))))) + `(write-string (if (eql ,arg 1) "y" "ies") stream) + `(unless (eql ,arg 1) (write-char #\s stream)))))) ;;;; format directives for floating point output (def-format-directive #\F (colonp atsignp params) (when colonp (error 'format-error - :complaint - "The colon modifier cannot be used with this directive.")) + :complaint + "The colon modifier cannot be used with this directive.")) (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp))) (def-format-directive #\E (colonp atsignp params) (when colonp (error 'format-error - :complaint - "The colon modifier cannot be used with this directive.")) + :complaint + "The colon modifier cannot be used with this directive.")) (expand-bind-defaults ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil)) params `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark - ,atsignp))) + ,atsignp))) (def-format-directive #\G (colonp atsignp params) (when colonp (error 'format-error - :complaint - "The colon modifier cannot be used with this directive.")) + :complaint + "The colon modifier cannot be used with this directive.")) (expand-bind-defaults ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil)) params @@ -572,105 +572,105 @@ (def-format-directive #\$ (colonp atsignp params) (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp - ,atsignp))) + ,atsignp))) ;;;; format directives for line/page breaks etc. (def-format-directive #\% (colonp atsignp params) (when (or colonp atsignp) (error 'format-error - :complaint - "The colon and atsign modifiers cannot be used with this directive." - )) + :complaint + "The colon and atsign modifiers cannot be used with this directive." + )) (if params (expand-bind-defaults ((count 1)) params - `(dotimes (i ,count) - (terpri stream))) + `(dotimes (i ,count) + (terpri stream))) '(terpri stream))) (def-format-directive #\& (colonp atsignp params) (when (or colonp atsignp) (error 'format-error - :complaint - "The colon and atsign modifiers cannot be used with this directive." - )) + :complaint + "The colon and atsign modifiers cannot be used with this directive." + )) (if params (expand-bind-defaults ((count 1)) params - `(progn - (fresh-line stream) - (dotimes (i (1- ,count)) - (terpri stream)))) + `(progn + (fresh-line stream) + (dotimes (i (1- ,count)) + (terpri stream)))) '(fresh-line stream))) (def-format-directive #\| (colonp atsignp params) (when (or colonp atsignp) (error 'format-error - :complaint - "The colon and atsign modifiers cannot be used with this directive." - )) + :complaint + "The colon and atsign modifiers cannot be used with this directive." + )) (if params (expand-bind-defaults ((count 1)) params - `(dotimes (i ,count) - (write-char (code-char form-feed-char-code) stream))) + `(dotimes (i ,count) + (write-char (code-char form-feed-char-code) stream))) '(write-char (code-char form-feed-char-code) stream))) (def-format-directive #\~ (colonp atsignp params) (when (or colonp atsignp) (error 'format-error - :complaint - "The colon and atsign modifiers cannot be used with this directive." - )) + :complaint + "The colon and atsign modifiers cannot be used with this directive." + )) (if params (expand-bind-defaults ((count 1)) params - `(dotimes (i ,count) - (write-char #\~ stream))) + `(dotimes (i ,count) + (write-char #\~ stream))) '(write-char #\~ stream))) (def-complex-format-directive #\newline (colonp atsignp params directives) (when (and colonp atsignp) (error 'format-error - :complaint "both colon and atsign modifiers used simultaneously")) + :complaint "both colon and atsign modifiers used simultaneously")) (values (expand-bind-defaults () params - (if atsignp - '(write-char #\newline stream) - nil)) - (if (and (not colonp) - directives - (simple-string-p (car directives))) - (cons (string-left-trim *format-whitespace-chars* - (car directives)) - (cdr directives)) - directives))) + (if atsignp + '(write-char #\newline stream) + nil)) + (if (and (not colonp) + directives + (simple-string-p (car directives))) + (cons (string-left-trim *format-whitespace-chars* + (car directives)) + (cdr directives)) + directives))) ;;;; format directives for tabs and simple pretty printing (def-format-directive #\T (colonp atsignp params) (if colonp (expand-bind-defaults ((n 1) (m 1)) params - `(pprint-tab ,(if atsignp :section-relative :section) - ,n ,m stream)) + `(pprint-tab ,(if atsignp :section-relative :section) + ,n ,m stream)) (if atsignp - (expand-bind-defaults ((colrel 1) (colinc 1)) params - `(format-relative-tab stream ,colrel ,colinc)) - (expand-bind-defaults ((colnum 1) (colinc 1)) params - `(format-absolute-tab stream ,colnum ,colinc))))) + (expand-bind-defaults ((colrel 1) (colinc 1)) params + `(format-relative-tab stream ,colrel ,colinc)) + (expand-bind-defaults ((colnum 1) (colinc 1)) params + `(format-absolute-tab stream ,colnum ,colinc))))) (def-format-directive #\_ (colonp atsignp params) (expand-bind-defaults () params `(pprint-newline ,(if colonp - (if atsignp - :mandatory - :fill) - (if atsignp - :miser - :linear)) - stream))) + (if atsignp + :mandatory + :fill) + (if atsignp + :miser + :linear)) + stream))) (def-format-directive #\I (colonp atsignp params) (when atsignp (error 'format-error - :complaint - "cannot use the at-sign modifier with this directive")) + :complaint + "cannot use the at-sign modifier with this directive")) (expand-bind-defaults ((n 0)) params `(pprint-indent ,(if colonp :current :block) ,n stream))) @@ -679,66 +679,66 @@ (def-format-directive #\* (colonp atsignp params end) (if atsignp (if colonp - (error 'format-error - :complaint - "both colon and atsign modifiers used simultaneously") - (expand-bind-defaults ((posn 0)) params - (unless *orig-args-available* - (/show0 "THROWing NEED-ORIG-ARGS from tilde-@*") - (throw 'need-orig-args nil)) - `(if (<= 0 ,posn (length orig-args)) - (setf args (nthcdr ,posn orig-args)) - (error 'format-error - :complaint "Index ~W out of bounds. Should have been ~ + (error 'format-error + :complaint + "both colon and atsign modifiers used simultaneously") + (expand-bind-defaults ((posn 0)) params + (unless *orig-args-available* + (/show0 "THROWing NEED-ORIG-ARGS from tilde-@*") + (throw 'need-orig-args nil)) + `(if (<= 0 ,posn (length orig-args)) + (setf args (nthcdr ,posn orig-args)) + (error 'format-error + :complaint "Index ~W out of bounds. Should have been ~ between 0 and ~W." - :args (list ,posn (length orig-args)) - :offset ,(1- end))))) + :args (list ,posn (length orig-args)) + :offset ,(1- end))))) (if colonp - (expand-bind-defaults ((n 1)) params - (unless *orig-args-available* - (/show0 "THROWing NEED-ORIG-ARGS from tilde-:*") - (throw 'need-orig-args nil)) - `(do ((cur-posn 0 (1+ cur-posn)) - (arg-ptr orig-args (cdr arg-ptr))) - ((eq arg-ptr args) - (let ((new-posn (- cur-posn ,n))) - (if (<= 0 new-posn (length orig-args)) - (setf args (nthcdr new-posn orig-args)) - (error 'format-error - :complaint - "Index ~W is out of bounds; should have been ~ + (expand-bind-defaults ((n 1)) params + (unless *orig-args-available* + (/show0 "THROWing NEED-ORIG-ARGS from tilde-:*") + (throw 'need-orig-args nil)) + `(do ((cur-posn 0 (1+ cur-posn)) + (arg-ptr orig-args (cdr arg-ptr))) + ((eq arg-ptr args) + (let ((new-posn (- cur-posn ,n))) + (if (<= 0 new-posn (length orig-args)) + (setf args (nthcdr new-posn orig-args)) + (error 'format-error + :complaint + "Index ~W is out of bounds; should have been ~ between 0 and ~W." - :args (list new-posn (length orig-args)) - :offset ,(1- end))))))) - (if params - (expand-bind-defaults ((n 1)) params - (setf *only-simple-args* nil) - `(dotimes (i ,n) - ,(expand-next-arg))) - (expand-next-arg))))) + :args (list new-posn (length orig-args)) + :offset ,(1- end))))))) + (if params + (expand-bind-defaults ((n 1)) params + (setf *only-simple-args* nil) + `(dotimes (i ,n) + ,(expand-next-arg))) + (expand-next-arg))))) ;;;; format directive for indirection (def-format-directive #\? (colonp atsignp params string end) (when colonp (error 'format-error - :complaint "cannot use the colon modifier with this directive")) + :complaint "cannot use the colon modifier with this directive")) (expand-bind-defaults () params `(handler-bind - ((format-error - (lambda (condition) - (error 'format-error - :complaint - "~A~%while processing indirect format string:" - :args (list condition) - :print-banner nil - :control-string ,string - :offset ,(1- end))))) + ((format-error + (lambda (condition) + (error 'format-error + :complaint + "~A~%while processing indirect format string:" + :args (list condition) + :print-banner nil + :control-string ,string + :offset ,(1- end))))) ,(if atsignp - (if *orig-args-available* - `(setf args (%format stream ,(expand-next-arg) orig-args args)) - (throw 'need-orig-args nil)) - `(%format stream ,(expand-next-arg) ,(expand-next-arg)))))) + (if *orig-args-available* + `(setf args (%format stream ,(expand-next-arg) orig-args args)) + (throw 'need-orig-args nil)) + `(%format stream ,(expand-next-arg) ,(expand-next-arg)))))) ;;;; format directives for capitalization @@ -746,26 +746,26 @@ (let ((close (find-directive directives #\) nil))) (unless close (error 'format-error - :complaint "no corresponding close parenthesis")) + :complaint "no corresponding close parenthesis")) (let* ((posn (position close directives)) - (before (subseq directives 0 posn)) - (after (nthcdr (1+ posn) directives))) + (before (subseq directives 0 posn)) + (after (nthcdr (1+ posn) directives))) (values (expand-bind-defaults () params - `(let ((stream (make-case-frob-stream stream - ,(if colonp - (if atsignp - :upcase - :capitalize) - (if atsignp - :capitalize-first - :downcase))))) - ,@(expand-directive-list before))) + `(let ((stream (make-case-frob-stream stream + ,(if colonp + (if atsignp + :upcase + :capitalize) + (if atsignp + :capitalize-first + :downcase))))) + ,@(expand-directive-list before))) after)))) (def-complex-format-directive #\) () (error 'format-error - :complaint "no corresponding open parenthesis")) + :complaint "no corresponding open parenthesis")) ;;;; format directives and support functions for conditionalization @@ -774,140 +774,140 @@ (parse-conditional-directive directives) (values (if atsignp - (if colonp - (error 'format-error - :complaint - "both colon and atsign modifiers used simultaneously") - (if (cdr sublists) - (error 'format-error - :complaint - "Can only specify one section") - (expand-bind-defaults () params - (expand-maybe-conditional (car sublists))))) - (if colonp - (if (= (length sublists) 2) - (expand-bind-defaults () params - (expand-true-false-conditional (car sublists) - (cadr sublists))) - (error 'format-error - :complaint - "must specify exactly two sections")) - (expand-bind-defaults ((index nil)) params - (setf *only-simple-args* nil) - (let ((clauses nil) + (if colonp + (error 'format-error + :complaint + "both colon and atsign modifiers used simultaneously") + (if (cdr sublists) + (error 'format-error + :complaint + "Can only specify one section") + (expand-bind-defaults () params + (expand-maybe-conditional (car sublists))))) + (if colonp + (if (= (length sublists) 2) + (expand-bind-defaults () params + (expand-true-false-conditional (car sublists) + (cadr sublists))) + (error 'format-error + :complaint + "must specify exactly two sections")) + (expand-bind-defaults ((index nil)) params + (setf *only-simple-args* nil) + (let ((clauses nil) (case `(or ,index ,(expand-next-arg)))) - (when last-semi-with-colon-p - (push `(t ,@(expand-directive-list (pop sublists))) - clauses)) - (let ((count (length sublists))) - (dolist (sublist sublists) - (push `(,(decf count) - ,@(expand-directive-list sublist)) - clauses))) - `(case ,case ,@clauses))))) + (when last-semi-with-colon-p + (push `(t ,@(expand-directive-list (pop sublists))) + clauses)) + (let ((count (length sublists))) + (dolist (sublist sublists) + (push `(,(decf count) + ,@(expand-directive-list sublist)) + clauses))) + `(case ,case ,@clauses))))) remaining))) (defun parse-conditional-directive (directives) (let ((sublists nil) - (last-semi-with-colon-p nil) - (remaining directives)) + (last-semi-with-colon-p nil) + (remaining directives)) (loop (let ((close-or-semi (find-directive remaining #\] t))) - (unless close-or-semi - (error 'format-error - :complaint "no corresponding close bracket")) - (let ((posn (position close-or-semi remaining))) - (push (subseq remaining 0 posn) sublists) - (setf remaining (nthcdr (1+ posn) remaining)) - (when (char= (format-directive-character close-or-semi) #\]) - (return)) - (setf last-semi-with-colon-p - (format-directive-colonp close-or-semi))))) + (unless close-or-semi + (error 'format-error + :complaint "no corresponding close bracket")) + (let ((posn (position close-or-semi remaining))) + (push (subseq remaining 0 posn) sublists) + (setf remaining (nthcdr (1+ posn) remaining)) + (when (char= (format-directive-character close-or-semi) #\]) + (return)) + (setf last-semi-with-colon-p + (format-directive-colonp close-or-semi))))) (values sublists last-semi-with-colon-p remaining))) (defun expand-maybe-conditional (sublist) (flet ((hairy () - `(let ((prev-args args) - (arg ,(expand-next-arg))) - (when arg - (setf args prev-args) - ,@(expand-directive-list sublist))))) + `(let ((prev-args args) + (arg ,(expand-next-arg))) + (when arg + (setf args prev-args) + ,@(expand-directive-list sublist))))) (if *only-simple-args* - (multiple-value-bind (guts new-args) - (let ((*simple-args* *simple-args*)) - (values (expand-directive-list sublist) - *simple-args*)) - (cond ((and new-args (eq *simple-args* (cdr new-args))) - (setf *simple-args* new-args) - `(when ,(caar new-args) - ,@guts)) - (t - (setf *only-simple-args* nil) - (hairy)))) - (hairy)))) + (multiple-value-bind (guts new-args) + (let ((*simple-args* *simple-args*)) + (values (expand-directive-list sublist) + *simple-args*)) + (cond ((and new-args (eq *simple-args* (cdr new-args))) + (setf *simple-args* new-args) + `(when ,(caar new-args) + ,@guts)) + (t + (setf *only-simple-args* nil) + (hairy)))) + (hairy)))) (defun expand-true-false-conditional (true false) (let ((arg (expand-next-arg))) (flet ((hairy () - `(if ,arg - (progn - ,@(expand-directive-list true)) - (progn - ,@(expand-directive-list false))))) + `(if ,arg + (progn + ,@(expand-directive-list true)) + (progn + ,@(expand-directive-list false))))) (if *only-simple-args* - (multiple-value-bind (true-guts true-args true-simple) - (let ((*simple-args* *simple-args*) - (*only-simple-args* t)) - (values (expand-directive-list true) - *simple-args* - *only-simple-args*)) - (multiple-value-bind (false-guts false-args false-simple) - (let ((*simple-args* *simple-args*) - (*only-simple-args* t)) - (values (expand-directive-list false) - *simple-args* - *only-simple-args*)) - (if (= (length true-args) (length false-args)) - `(if ,arg - (progn - ,@true-guts) - ,(do ((false false-args (cdr false)) - (true true-args (cdr true)) - (bindings nil (cons `(,(caar false) ,(caar true)) - bindings))) - ((eq true *simple-args*) - (setf *simple-args* true-args) - (setf *only-simple-args* - (and true-simple false-simple)) - (if bindings - `(let ,bindings - ,@false-guts) - `(progn - ,@false-guts))))) - (progn - (setf *only-simple-args* nil) - (hairy))))) - (hairy))))) + (multiple-value-bind (true-guts true-args true-simple) + (let ((*simple-args* *simple-args*) + (*only-simple-args* t)) + (values (expand-directive-list true) + *simple-args* + *only-simple-args*)) + (multiple-value-bind (false-guts false-args false-simple) + (let ((*simple-args* *simple-args*) + (*only-simple-args* t)) + (values (expand-directive-list false) + *simple-args* + *only-simple-args*)) + (if (= (length true-args) (length false-args)) + `(if ,arg + (progn + ,@true-guts) + ,(do ((false false-args (cdr false)) + (true true-args (cdr true)) + (bindings nil (cons `(,(caar false) ,(caar true)) + bindings))) + ((eq true *simple-args*) + (setf *simple-args* true-args) + (setf *only-simple-args* + (and true-simple false-simple)) + (if bindings + `(let ,bindings + ,@false-guts) + `(progn + ,@false-guts))))) + (progn + (setf *only-simple-args* nil) + (hairy))))) + (hairy))))) (def-complex-format-directive #\; () (error 'format-error - :complaint - "~~; directive not contained within either ~~[...~~] or ~~<...~~>")) + :complaint + "~~; directive not contained within either ~~[...~~] or ~~<...~~>")) (def-complex-format-directive #\] () (error 'format-error - :complaint - "no corresponding open bracket")) + :complaint + "no corresponding open bracket")) ;;;; format directive for up-and-out (def-format-directive #\^ (colonp atsignp params) (when atsignp (error 'format-error - :complaint "cannot use the at-sign modifier with this directive")) + :complaint "cannot use the at-sign modifier with this directive")) (when (and colonp (not *up-up-and-out-allowed*)) (error 'format-error - :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct")) + :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct")) `(when ,(expand-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params `(cond (,arg3 (<= ,arg1 ,arg2 ,arg3)) (,arg2 (eql ,arg1 ,arg2)) @@ -918,8 +918,8 @@ (setf *only-simple-args* nil) '(null args)))))) ,(if colonp - '(return-from outside-loop nil) - '(return)))) + '(return-from outside-loop nil) + '(return)))) ;;;; format directives for iteration @@ -927,59 +927,59 @@ (let ((close (find-directive directives #\} nil))) (unless close (error 'format-error - :complaint "no corresponding close brace")) + :complaint "no corresponding close brace")) (let* ((closed-with-colon (format-directive-colonp close)) - (posn (position close directives))) + (posn (position close directives))) (labels - ((compute-insides () - (if (zerop posn) - (if *orig-args-available* - `((handler-bind - ((format-error - (lambda (condition) - (error 'format-error - :complaint - "~A~%while processing indirect format string:" - :args (list condition) - :print-banner nil - :control-string ,string - :offset ,(1- end))))) - (setf args - (%format stream inside-string orig-args args)))) - (throw 'need-orig-args nil)) - (let ((*up-up-and-out-allowed* colonp)) - (expand-directive-list (subseq directives 0 posn))))) - (compute-loop (count) - (when atsignp - (setf *only-simple-args* nil)) - `(loop - ,@(unless closed-with-colon - '((when (null args) - (return)))) - ,@(when count - `((when (and ,count (minusp (decf ,count))) - (return)))) - ,@(if colonp - (let ((*expander-next-arg-macro* 'expander-next-arg) - (*only-simple-args* nil) - (*orig-args-available* t)) - `((let* ((orig-args ,(expand-next-arg)) - (outside-args args) - (args orig-args)) - (declare (ignorable orig-args outside-args args)) - (block nil - ,@(compute-insides))))) - (compute-insides)) - ,@(when closed-with-colon - '((when (null args) - (return)))))) - (compute-block (count) - (if colonp - `(block outside-loop - ,(compute-loop count)) - (compute-loop count))) - (compute-bindings (count) - (if atsignp + ((compute-insides () + (if (zerop posn) + (if *orig-args-available* + `((handler-bind + ((format-error + (lambda (condition) + (error 'format-error + :complaint + "~A~%while processing indirect format string:" + :args (list condition) + :print-banner nil + :control-string ,string + :offset ,(1- end))))) + (setf args + (%format stream inside-string orig-args args)))) + (throw 'need-orig-args nil)) + (let ((*up-up-and-out-allowed* colonp)) + (expand-directive-list (subseq directives 0 posn))))) + (compute-loop (count) + (when atsignp + (setf *only-simple-args* nil)) + `(loop + ,@(unless closed-with-colon + '((when (null args) + (return)))) + ,@(when count + `((when (and ,count (minusp (decf ,count))) + (return)))) + ,@(if colonp + (let ((*expander-next-arg-macro* 'expander-next-arg) + (*only-simple-args* nil) + (*orig-args-available* t)) + `((let* ((orig-args ,(expand-next-arg)) + (outside-args args) + (args orig-args)) + (declare (ignorable orig-args outside-args args)) + (block nil + ,@(compute-insides))))) + (compute-insides)) + ,@(when closed-with-colon + '((when (null args) + (return)))))) + (compute-block (count) + (if colonp + `(block outside-loop + ,(compute-loop count)) + (compute-loop count))) + (compute-bindings (count) + (if atsignp (compute-block count) `(let* ((orig-args ,(expand-next-arg)) (args orig-args)) @@ -988,7 +988,7 @@ (*only-simple-args* nil) (*orig-args-available* t)) (compute-block count)))))) - (values (if params + (values (if params (expand-bind-defaults ((count nil)) params (if (zerop posn) `(let ((inside-string ,(expand-next-arg))) @@ -998,241 +998,241 @@ `(let ((inside-string ,(expand-next-arg))) ,(compute-bindings nil)) (compute-bindings nil))) - (nthcdr (1+ posn) directives)))))) + (nthcdr (1+ posn) directives)))))) (def-complex-format-directive #\} () (error 'format-error - :complaint "no corresponding open brace")) + :complaint "no corresponding open brace")) ;;;; format directives and support functions for justification (defparameter *illegal-inside-justification* (mapcar (lambda (x) (parse-directive x 0)) - '("~W" "~:W" "~@W" "~:@W" - "~_" "~:_" "~@_" "~:@_" - "~:>" "~:@>" - "~I" "~:I" "~@I" "~:@I" - "~:T" "~:@T"))) + '("~W" "~:W" "~@W" "~:@W" + "~_" "~:_" "~@_" "~:@_" + "~:>" "~:@>" + "~I" "~:I" "~@I" "~:@I" + "~:T" "~:@T"))) (defun illegal-inside-justification-p (directive) (member directive *illegal-inside-justification* - :test (lambda (x y) - (and (format-directive-p x) - (format-directive-p y) - (eql (format-directive-character x) (format-directive-character y)) - (eql (format-directive-colonp x) (format-directive-colonp y)) - (eql (format-directive-atsignp x) (format-directive-atsignp y)))))) + :test (lambda (x y) + (and (format-directive-p x) + (format-directive-p y) + (eql (format-directive-character x) (format-directive-character y)) + (eql (format-directive-colonp x) (format-directive-colonp y)) + (eql (format-directive-atsignp x) (format-directive-atsignp y)))))) (def-complex-format-directive #\< (colonp atsignp params string end directives) (multiple-value-bind (segments first-semi close remaining) (parse-format-justification directives) (values (if (format-directive-colonp close) - (multiple-value-bind (prefix per-line-p insides suffix) - (parse-format-logical-block segments colonp first-semi - close params string end) - (expand-format-logical-block prefix per-line-p insides - suffix atsignp)) - (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments)))) - (when (> count 0) - ;; ANSI specifies that "an error is signalled" in this - ;; situation. - (error 'format-error - :complaint "~D illegal directive~:P found inside justification block" - :args (list count) + (multiple-value-bind (prefix per-line-p insides suffix) + (parse-format-logical-block segments colonp first-semi + close params string end) + (expand-format-logical-block prefix per-line-p insides + suffix atsignp)) + (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments)))) + (when (> count 0) + ;; ANSI specifies that "an error is signalled" in this + ;; situation. + (error 'format-error + :complaint "~D illegal directive~:P found inside justification block" + :args (list count) :references (list '(:ansi-cl :section (22 3 5 2))))) - (expand-format-justification segments colonp atsignp + (expand-format-justification segments colonp atsignp first-semi params))) remaining))) (def-complex-format-directive #\> () (error 'format-error - :complaint "no corresponding open bracket")) + :complaint "no corresponding open bracket")) (defun parse-format-logical-block (segments colonp first-semi close params string end) (when params (error 'format-error - :complaint "No parameters can be supplied with ~~<...~~:>." - :offset (caar params))) + :complaint "No parameters can be supplied with ~~<...~~:>." + :offset (caar params))) (multiple-value-bind (prefix insides suffix) (multiple-value-bind (prefix-default suffix-default) - (if colonp (values "(" ")") (values "" "")) - (flet ((extract-string (list prefix-p) - (let ((directive (find-if #'format-directive-p list))) - (if directive - (error 'format-error - :complaint + (if colonp (values "(" ")") (values "" "")) + (flet ((extract-string (list prefix-p) + (let ((directive (find-if #'format-directive-p list))) + (if directive + (error 'format-error + :complaint "cannot include format directives inside the ~ ~:[suffix~;prefix~] segment of ~~<...~~:>" - :args (list prefix-p) - :offset (1- (format-directive-end directive)) + :args (list prefix-p) + :offset (1- (format-directive-end directive)) :references (list '(:ansi-cl :section (22 3 5 2)))) - (apply #'concatenate 'string list))))) - (case (length segments) - (0 (values prefix-default nil suffix-default)) - (1 (values prefix-default (car segments) suffix-default)) - (2 (values (extract-string (car segments) t) - (cadr segments) suffix-default)) - (3 (values (extract-string (car segments) t) - (cadr segments) - (extract-string (caddr segments) nil))) - (t - (error 'format-error - :complaint "too many segments for ~~<...~~:>"))))) + (apply #'concatenate 'string list))))) + (case (length segments) + (0 (values prefix-default nil suffix-default)) + (1 (values prefix-default (car segments) suffix-default)) + (2 (values (extract-string (car segments) t) + (cadr segments) suffix-default)) + (3 (values (extract-string (car segments) t) + (cadr segments) + (extract-string (caddr segments) nil))) + (t + (error 'format-error + :complaint "too many segments for ~~<...~~:>"))))) (when (format-directive-atsignp close) (setf insides - (add-fill-style-newlines insides - string - (if first-semi - (format-directive-end first-semi) - end)))) + (add-fill-style-newlines insides + string + (if first-semi + (format-directive-end first-semi) + end)))) (values prefix - (and first-semi (format-directive-atsignp first-semi)) - insides - suffix))) + (and first-semi (format-directive-atsignp first-semi)) + insides + suffix))) (defun add-fill-style-newlines (list string offset &optional last-directive) (cond (list (let ((directive (car list))) (cond - ((simple-string-p directive) - (let* ((non-space (position #\Space directive :test #'char/=)) - (newlinep (and last-directive - (char= - (format-directive-character last-directive) - #\Newline)))) - (cond - ((and newlinep non-space) - (nconc - (list (subseq directive 0 non-space)) - (add-fill-style-newlines-aux - (subseq directive non-space) string (+ offset non-space)) - (add-fill-style-newlines - (cdr list) string (+ offset (length directive))))) - (newlinep - (cons directive - (add-fill-style-newlines - (cdr list) string (+ offset (length directive))))) - (t - (nconc (add-fill-style-newlines-aux directive string offset) - (add-fill-style-newlines - (cdr list) string (+ offset (length directive)))))))) - (t - (cons directive - (add-fill-style-newlines - (cdr list) string - (format-directive-end directive) directive)))))) + ((simple-string-p directive) + (let* ((non-space (position #\Space directive :test #'char/=)) + (newlinep (and last-directive + (char= + (format-directive-character last-directive) + #\Newline)))) + (cond + ((and newlinep non-space) + (nconc + (list (subseq directive 0 non-space)) + (add-fill-style-newlines-aux + (subseq directive non-space) string (+ offset non-space)) + (add-fill-style-newlines + (cdr list) string (+ offset (length directive))))) + (newlinep + (cons directive + (add-fill-style-newlines + (cdr list) string (+ offset (length directive))))) + (t + (nconc (add-fill-style-newlines-aux directive string offset) + (add-fill-style-newlines + (cdr list) string (+ offset (length directive)))))))) + (t + (cons directive + (add-fill-style-newlines + (cdr list) string + (format-directive-end directive) directive)))))) (t nil))) (defun add-fill-style-newlines-aux (literal string offset) (let ((end (length literal)) - (posn 0)) + (posn 0)) (collect ((results)) (loop - (let ((blank (position #\space literal :start posn))) - (when (null blank) - (results (subseq literal posn)) - (return)) - (let ((non-blank (or (position #\space literal :start blank - :test #'char/=) - end))) - (results (subseq literal posn non-blank)) - (results (make-format-directive - :string string :character #\_ - :start (+ offset non-blank) :end (+ offset non-blank) - :colonp t :atsignp nil :params nil)) - (setf posn non-blank)) - (when (= posn end) - (return)))) + (let ((blank (position #\space literal :start posn))) + (when (null blank) + (results (subseq literal posn)) + (return)) + (let ((non-blank (or (position #\space literal :start blank + :test #'char/=) + end))) + (results (subseq literal posn non-blank)) + (results (make-format-directive + :string string :character #\_ + :start (+ offset non-blank) :end (+ offset non-blank) + :colonp t :atsignp nil :params nil)) + (setf posn non-blank)) + (when (= posn end) + (return)))) (results)))) (defun parse-format-justification (directives) (let ((first-semi nil) - (close nil) - (remaining directives)) + (close nil) + (remaining directives)) (collect ((segments)) (loop - (let ((close-or-semi (find-directive remaining #\> t))) - (unless close-or-semi - (error 'format-error - :complaint "no corresponding close bracket")) - (let ((posn (position close-or-semi remaining))) - (segments (subseq remaining 0 posn)) - (setf remaining (nthcdr (1+ posn) remaining))) - (when (char= (format-directive-character close-or-semi) - #\>) - (setf close close-or-semi) - (return)) - (unless first-semi - (setf first-semi close-or-semi)))) + (let ((close-or-semi (find-directive remaining #\> t))) + (unless close-or-semi + (error 'format-error + :complaint "no corresponding close bracket")) + (let ((posn (position close-or-semi remaining))) + (segments (subseq remaining 0 posn)) + (setf remaining (nthcdr (1+ posn) remaining))) + (when (char= (format-directive-character close-or-semi) + #\>) + (setf close close-or-semi) + (return)) + (unless first-semi + (setf first-semi close-or-semi)))) (values (segments) first-semi close remaining)))) (sb!xc:defmacro expander-pprint-next-arg (string offset) `(progn (when (null args) (error 'format-error - :complaint "no more arguments" - :control-string ,string - :offset ,offset)) + :complaint "no more arguments" + :control-string ,string + :offset ,offset)) (pprint-pop) (pop args))) (defun expand-format-logical-block (prefix per-line-p insides suffix atsignp) `(let ((arg ,(if atsignp 'args (expand-next-arg)))) ,@(when atsignp - (setf *only-simple-args* nil) - '((setf args nil))) + (setf *only-simple-args* nil) + '((setf args nil))) (pprint-logical-block - (stream arg - ,(if per-line-p :per-line-prefix :prefix) ,prefix - :suffix ,suffix) + (stream arg + ,(if per-line-p :per-line-prefix :prefix) ,prefix + :suffix ,suffix) (let ((args arg) - ,@(unless atsignp - `((orig-args arg)))) - (declare (ignorable args ,@(unless atsignp '(orig-args)))) - (block nil - ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg) - (*only-simple-args* nil) - (*orig-args-available* - (if atsignp *orig-args-available* t))) - (expand-directive-list insides))))))) + ,@(unless atsignp + `((orig-args arg)))) + (declare (ignorable args ,@(unless atsignp '(orig-args)))) + (block nil + ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg) + (*only-simple-args* nil) + (*orig-args-available* + (if atsignp *orig-args-available* t))) + (expand-directive-list insides))))))) (defun expand-format-justification (segments colonp atsignp first-semi params) (let ((newline-segment-p - (and first-semi - (format-directive-colonp first-semi)))) + (and first-semi + (format-directive-colonp first-semi)))) (expand-bind-defaults - ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) - params + ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + params `(let ((segments nil) - ,@(when newline-segment-p - '((newline-segment nil) - (extra-space 0) - (line-len 72)))) - (block nil - ,@(when newline-segment-p - `((setf newline-segment - (with-output-to-string (stream) - ,@(expand-directive-list (pop segments)))) - ,(expand-bind-defaults - ((extra 0) - (line-len '(or (sb!impl::line-length stream) 72))) - (format-directive-params first-semi) - `(setf extra-space ,extra line-len ,line-len)))) - ,@(mapcar (lambda (segment) - `(push (with-output-to-string (stream) - ,@(expand-directive-list segment)) - segments)) - segments)) - (format-justification stream - ,@(if newline-segment-p - '(newline-segment extra-space line-len) - '(nil 0 0)) - segments ,colonp ,atsignp - ,mincol ,colinc ,minpad ,padchar))))) + ,@(when newline-segment-p + '((newline-segment nil) + (extra-space 0) + (line-len 72)))) + (block nil + ,@(when newline-segment-p + `((setf newline-segment + (with-output-to-string (stream) + ,@(expand-directive-list (pop segments)))) + ,(expand-bind-defaults + ((extra 0) + (line-len '(or (sb!impl::line-length stream) 72))) + (format-directive-params first-semi) + `(setf extra-space ,extra line-len ,line-len)))) + ,@(mapcar (lambda (segment) + `(push (with-output-to-string (stream) + ,@(expand-directive-list segment)) + segments)) + segments)) + (format-justification stream + ,@(if newline-segment-p + '(newline-segment extra-space line-len) + '(nil 0 0)) + segments ,colonp ,atsignp + ,mincol ,colinc ,minpad ,padchar))))) ;;;; format directive and support function for user-defined method @@ -1240,48 +1240,48 @@ (let ((symbol (extract-user-fun-name string start end))) (collect ((param-names) (bindings)) (dolist (param-and-offset params) - (let ((param (cdr param-and-offset))) - (let ((param-name (gensym))) - (param-names param-name) - (bindings `(,param-name - ,(case param - (:arg (expand-next-arg)) - (:remaining '(length args)) - (t param))))))) + (let ((param (cdr param-and-offset))) + (let ((param-name (gensym))) + (param-names param-name) + (bindings `(,param-name + ,(case param + (:arg (expand-next-arg)) + (:remaining '(length args)) + (t param))))))) `(let ,(bindings) - (,symbol stream ,(expand-next-arg) ,colonp ,atsignp - ,@(param-names)))))) + (,symbol stream ,(expand-next-arg) ,colonp ,atsignp + ,@(param-names)))))) (defun extract-user-fun-name (string start end) (let ((slash (position #\/ string :start start :end (1- end) - :from-end t))) + :from-end t))) (unless slash (error 'format-error - :complaint "malformed ~~/ directive")) + :complaint "malformed ~~/ directive")) (let* ((name (string-upcase (let ((foo string)) - ;; Hack alert: This is to keep the compiler - ;; quiet about deleting code inside the - ;; subseq expansion. - (subseq foo (1+ slash) (1- end))))) - (first-colon (position #\: name)) - (second-colon (if first-colon (position #\: name :start (1+ first-colon)))) - (package-name (if first-colon - (subseq name 0 first-colon) - "COMMON-LISP-USER")) - (package (find-package package-name))) + ;; Hack alert: This is to keep the compiler + ;; quiet about deleting code inside the + ;; subseq expansion. + (subseq foo (1+ slash) (1- end))))) + (first-colon (position #\: name)) + (second-colon (if first-colon (position #\: name :start (1+ first-colon)))) + (package-name (if first-colon + (subseq name 0 first-colon) + "COMMON-LISP-USER")) + (package (find-package package-name))) (unless package - ;; FIXME: should be PACKAGE-ERROR? Could we just use - ;; FIND-UNDELETED-PACKAGE-OR-LOSE? - (error 'format-error - :complaint "no package named ~S" - :args (list package-name))) + ;; FIXME: should be PACKAGE-ERROR? Could we just use + ;; FIND-UNDELETED-PACKAGE-OR-LOSE? + (error 'format-error + :complaint "no package named ~S" + :args (list package-name))) (intern (cond - ((and second-colon (= second-colon (1+ first-colon))) - (subseq name (1+ second-colon))) - (first-colon - (subseq name (1+ first-colon))) - (t name)) - package)))) + ((and second-colon (= second-colon (1+ first-colon))) + (subseq name (1+ second-colon))) + (first-colon + (subseq name (1+ first-colon))) + (t name)) + package)))) ;;; compile-time checking for argument mismatch. This code is ;;; inspired by that of Gerd Moellmann, and comes decorated with @@ -1290,15 +1290,15 @@ (declare (type simple-string string)) (let ((*default-format-error-control-string* string)) (macrolet ((incf-both (&optional (increment 1)) - `(progn - (incf min ,increment) - (incf max ,increment))) - (walk-complex-directive (function) - `(multiple-value-bind (min-inc max-inc remaining) - (,function directive directives args) - (incf min min-inc) - (incf max max-inc) - (setq directives remaining)))) + `(progn + (incf min ,increment) + (incf max ,increment))) + (walk-complex-directive (function) + `(multiple-value-bind (min-inc max-inc remaining) + (,function directive directives args) + (incf min min-inc) + (incf max max-inc) + (setq directives remaining)))) ;; FIXME: these functions take a list of arguments as well as ;; the directive stream. This is to enable possibly some ;; limited type checking on FORMAT's arguments, as well as @@ -1308,93 +1308,93 @@ ;; directive, and some (annotated below) require arguments of ;; particular types. (labels - ((walk-justification (justification directives args) - (declare (ignore args)) - (let ((*default-format-error-offset* - (1- (format-directive-end justification)))) - (multiple-value-bind (segments first-semi close remaining) - (parse-format-justification directives) - (declare (ignore segments first-semi)) - (cond - ((not (format-directive-colonp close)) - (values 0 0 directives)) - ((format-directive-atsignp justification) - (values 0 sb!xc:call-arguments-limit directives)) - ;; FIXME: here we could assert that the - ;; corresponding argument was a list. - (t (values 1 1 remaining)))))) - (walk-conditional (conditional directives args) - (let ((*default-format-error-offset* - (1- (format-directive-end conditional)))) - (multiple-value-bind (sublists last-semi-with-colon-p remaining) - (parse-conditional-directive directives) - (declare (ignore last-semi-with-colon-p)) - (let ((sub-max - (loop for s in sublists - maximize (nth-value - 1 (walk-directive-list s args))))) - (cond - ((format-directive-atsignp conditional) - (values 1 (max 1 sub-max) remaining)) - ((loop for p in (format-directive-params conditional) - thereis (or (integerp (cdr p)) - (memq (cdr p) '(:remaining :arg)))) - (values 0 sub-max remaining)) - ;; FIXME: if not COLONP, then the next argument - ;; must be a number. - (t (values 1 (1+ sub-max) remaining))))))) - (walk-iteration (iteration directives args) - (declare (ignore args)) - (let ((*default-format-error-offset* - (1- (format-directive-end iteration)))) - (let* ((close (find-directive directives #\} nil)) - (posn (or (position close directives) + ((walk-justification (justification directives args) + (declare (ignore args)) + (let ((*default-format-error-offset* + (1- (format-directive-end justification)))) + (multiple-value-bind (segments first-semi close remaining) + (parse-format-justification directives) + (declare (ignore segments first-semi)) + (cond + ((not (format-directive-colonp close)) + (values 0 0 directives)) + ((format-directive-atsignp justification) + (values 0 sb!xc:call-arguments-limit directives)) + ;; FIXME: here we could assert that the + ;; corresponding argument was a list. + (t (values 1 1 remaining)))))) + (walk-conditional (conditional directives args) + (let ((*default-format-error-offset* + (1- (format-directive-end conditional)))) + (multiple-value-bind (sublists last-semi-with-colon-p remaining) + (parse-conditional-directive directives) + (declare (ignore last-semi-with-colon-p)) + (let ((sub-max + (loop for s in sublists + maximize (nth-value + 1 (walk-directive-list s args))))) + (cond + ((format-directive-atsignp conditional) + (values 1 (max 1 sub-max) remaining)) + ((loop for p in (format-directive-params conditional) + thereis (or (integerp (cdr p)) + (memq (cdr p) '(:remaining :arg)))) + (values 0 sub-max remaining)) + ;; FIXME: if not COLONP, then the next argument + ;; must be a number. + (t (values 1 (1+ sub-max) remaining))))))) + (walk-iteration (iteration directives args) + (declare (ignore args)) + (let ((*default-format-error-offset* + (1- (format-directive-end iteration)))) + (let* ((close (find-directive directives #\} nil)) + (posn (or (position close directives) (error 'format-error :complaint "no corresponding close brace"))) - (remaining (nthcdr (1+ posn) directives))) - ;; FIXME: if POSN is zero, the next argument must be - ;; a format control (either a function or a string). - (if (format-directive-atsignp iteration) - (values (if (zerop posn) 1 0) - sb!xc:call-arguments-limit - remaining) - ;; FIXME: the argument corresponding to this - ;; directive must be a list. - (let ((nreq (if (zerop posn) 2 1))) - (values nreq nreq remaining)))))) - (walk-directive-list (directives args) - (let ((min 0) (max 0)) - (loop - (let ((directive (pop directives))) - (when (null directive) - (return (values min (min max sb!xc:call-arguments-limit)))) - (when (format-directive-p directive) - (incf-both (count :arg (format-directive-params directive) - :key #'cdr)) - (let ((c (format-directive-character directive))) - (cond - ((find c "ABCDEFGORSWX$/") - (incf-both)) - ((char= c #\P) - (unless (format-directive-colonp directive) - (incf-both))) - ((or (find c "IT%&|_();>~") (char= c #\Newline))) + (remaining (nthcdr (1+ posn) directives))) + ;; FIXME: if POSN is zero, the next argument must be + ;; a format control (either a function or a string). + (if (format-directive-atsignp iteration) + (values (if (zerop posn) 1 0) + sb!xc:call-arguments-limit + remaining) + ;; FIXME: the argument corresponding to this + ;; directive must be a list. + (let ((nreq (if (zerop posn) 2 1))) + (values nreq nreq remaining)))))) + (walk-directive-list (directives args) + (let ((min 0) (max 0)) + (loop + (let ((directive (pop directives))) + (when (null directive) + (return (values min (min max sb!xc:call-arguments-limit)))) + (when (format-directive-p directive) + (incf-both (count :arg (format-directive-params directive) + :key #'cdr)) + (let ((c (format-directive-character directive))) + (cond + ((find c "ABCDEFGORSWX$/") + (incf-both)) + ((char= c #\P) + (unless (format-directive-colonp directive) + (incf-both))) + ((or (find c "IT%&|_();>~") (char= c #\Newline))) ;; FIXME: check correspondence of ~( and ~) - ((char= c #\<) - (walk-complex-directive walk-justification)) - ((char= c #\[) - (walk-complex-directive walk-conditional)) - ((char= c #\{) - (walk-complex-directive walk-iteration)) - ((char= c #\?) - ;; FIXME: the argument corresponding to this - ;; directive must be a format control. - (cond - ((format-directive-atsignp directive) - (incf min) - (setq max sb!xc:call-arguments-limit)) - (t (incf-both 2)))) - (t (throw 'give-up-format-string-walk nil)))))))))) - (catch 'give-up-format-string-walk - (let ((directives (tokenize-control-string string))) - (walk-directive-list directives args))))))) + ((char= c #\<) + (walk-complex-directive walk-justification)) + ((char= c #\[) + (walk-complex-directive walk-conditional)) + ((char= c #\{) + (walk-complex-directive walk-iteration)) + ((char= c #\?) + ;; FIXME: the argument corresponding to this + ;; directive must be a format control. + (cond + ((format-directive-atsignp directive) + (incf min) + (setq max sb!xc:call-arguments-limit)) + (t (incf-both 2)))) + (t (throw 'give-up-format-string-walk nil)))))))))) + (catch 'give-up-format-string-walk + (let ((directives (tokenize-control-string string))) + (walk-directive-list directives args))))))) diff --git a/src/code/late-setf.lisp b/src/code/late-setf.lisp index 1d41c5c..abaa35a 100644 --- a/src/code/late-setf.lisp +++ b/src/code/late-setf.lisp @@ -26,21 +26,21 @@ (declare (type sb!c::lexenv env)) (collect ((let*-bindings) (mv-bindings) (setters)) (do ((a args (cddr a))) - ((endp a)) + ((endp a)) (if (endp (cdr a)) - (error "Odd number of args to PSETF.")) + (error "Odd number of args to PSETF.")) (multiple-value-bind (dummies vals newval setter getter) - (sb!xc:get-setf-expansion (car a) env) - (declare (ignore getter)) - (let*-bindings (mapcar #'list dummies vals)) - (mv-bindings (list newval (cadr a))) - (setters setter))) + (sb!xc:get-setf-expansion (car a) env) + (declare (ignore getter)) + (let*-bindings (mapcar #'list dummies vals)) + (mv-bindings (list newval (cadr a))) + (setters setter))) (labels ((thunk (let*-bindings mv-bindings) - (if let*-bindings - `(let* ,(car let*-bindings) - (multiple-value-bind ,@(car mv-bindings) - ,(thunk (cdr let*-bindings) (cdr mv-bindings)))) - `(progn ,@(setters) nil)))) + (if let*-bindings + `(let* ,(car let*-bindings) + (multiple-value-bind ,@(car mv-bindings) + ,(thunk (cdr let*-bindings) (cdr mv-bindings)))) + `(progn ,@(setters) nil)))) (thunk (let*-bindings) (mv-bindings))))) ;;; FIXME: Compiling this definition of ROTATEF apparently blows away the @@ -57,41 +57,41 @@ (when args (collect ((let*-bindings) (mv-bindings) (setters) (getters)) (dolist (arg args) - (multiple-value-bind (temps subforms store-vars setter getter) - (sb!xc:get-setf-expansion arg env) - (loop - for temp in temps - for subform in subforms - do (let*-bindings `(,temp ,subform))) - (mv-bindings store-vars) - (setters setter) - (getters getter))) + (multiple-value-bind (temps subforms store-vars setter getter) + (sb!xc:get-setf-expansion arg env) + (loop + for temp in temps + for subform in subforms + do (let*-bindings `(,temp ,subform))) + (mv-bindings store-vars) + (setters setter) + (getters getter))) (setters nil) (getters (car (getters))) (labels ((thunk (mv-bindings getters) - (if mv-bindings - `((multiple-value-bind ,(car mv-bindings) ,(car getters) - ,@(thunk (cdr mv-bindings) (cdr getters)))) - (setters)))) - `(let* ,(let*-bindings) - ,@(thunk (mv-bindings) (cdr (getters)))))))) + (if mv-bindings + `((multiple-value-bind ,(car mv-bindings) ,(car getters) + ,@(thunk (cdr mv-bindings) (cdr getters)))) + (setters)))) + `(let* ,(let*-bindings) + ,@(thunk (mv-bindings) (cdr (getters)))))))) (sb!xc:define-setf-expander values (&rest places &environment env) (declare (type sb!c::lexenv env)) (collect ((setters) (getters)) (let ((all-dummies '()) - (all-vals '()) - (newvals '())) + (all-vals '()) + (newvals '())) (dolist (place places) - (multiple-value-bind (dummies vals newval setter getter) - (sb!xc:get-setf-expansion place env) - ;; ANSI 5.1.2.3 explains this logic quite precisely. -- - ;; CSR, 2004-06-29 - (setq all-dummies (append all-dummies dummies (cdr newval)) - all-vals (append all-vals vals - (mapcar (constantly nil) (cdr newval))) - newvals (append newvals (list (car newval)))) - (setters setter) - (getters getter))) + (multiple-value-bind (dummies vals newval setter getter) + (sb!xc:get-setf-expansion place env) + ;; ANSI 5.1.2.3 explains this logic quite precisely. -- + ;; CSR, 2004-06-29 + (setq all-dummies (append all-dummies dummies (cdr newval)) + all-vals (append all-vals vals + (mapcar (constantly nil) (cdr newval))) + newvals (append newvals (list (car newval)))) + (setters setter) + (getters getter))) (values all-dummies all-vals newvals - `(values ,@(setters)) `(values ,@(getters)))))) + `(values ,@(setters)) `(values ,@(getters)))))) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 147656e..1c49b89 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -50,16 +50,16 @@ ;;; chance to run, instead of immediately returning NIL, T. (defun delegate-complex-subtypep-arg2 (type1 type2) (let ((subtypep-arg1 - (type-class-complex-subtypep-arg1 - (type-class-info type1)))) + (type-class-complex-subtypep-arg1 + (type-class-info type1)))) (if subtypep-arg1 - (funcall subtypep-arg1 type1 type2) - (values nil t)))) + (funcall subtypep-arg1 type1 type2) + (values nil t)))) (defun delegate-complex-intersection2 (type1 type2) (let ((method (type-class-complex-intersection2 (type-class-info type1)))) (if (and method (not (eq method #'delegate-complex-intersection2))) - (funcall method type2 type1) - (hierarchical-intersection2 type1 type2)))) + (funcall method type2 type1) + (hierarchical-intersection2 type1 type2)))) ;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1 ;;; method. INFO is a list of conses @@ -77,16 +77,16 @@ ;; FIXME: This old CMU CL code probably deserves a comment ;; explaining to us mere mortals how it works... (and (sb!xc:typep type2 'classoid) - (dolist (x info nil) - (when (or (not (cdr x)) - (csubtypep type1 (specifier-type (cdr x)))) - (return - (or (eq type2 (car x)) - (let ((inherits (layout-inherits - (classoid-layout (car x))))) - (dotimes (i (length inherits) nil) - (when (eq type2 (layout-classoid (svref inherits i))) - (return t))))))))) + (dolist (x info nil) + (when (or (not (cdr x)) + (csubtypep type1 (specifier-type (cdr x)))) + (return + (or (eq type2 (car x)) + (let ((inherits (layout-inherits + (classoid-layout (car x))))) + (dotimes (i (length inherits) nil) + (when (eq type2 (layout-classoid (svref inherits i))) + (return t))))))))) t))) ;;; This function takes a list of specs, each of the form @@ -105,19 +105,19 @@ (with-unique-names (type-class info) `(,when (let ((,type-class (type-class-or-lose ',type-class-name)) - (,info (mapcar (lambda (spec) - (destructuring-bind - (super &optional guard) - spec - (cons (find-classoid super) guard))) - ',specs))) - (setf (type-class-complex-subtypep-arg1 ,type-class) - (lambda (type1 type2) - (!has-superclasses-complex-subtypep-arg1 type1 type2 ,info))) - (setf (type-class-complex-subtypep-arg2 ,type-class) - #'delegate-complex-subtypep-arg2) - (setf (type-class-complex-intersection2 ,type-class) - #'delegate-complex-intersection2))))) + (,info (mapcar (lambda (spec) + (destructuring-bind + (super &optional guard) + spec + (cons (find-classoid super) guard))) + ',specs))) + (setf (type-class-complex-subtypep-arg1 ,type-class) + (lambda (type1 type2) + (!has-superclasses-complex-subtypep-arg1 type1 type2 ,info))) + (setf (type-class-complex-subtypep-arg2 ,type-class) + #'delegate-complex-subtypep-arg2) + (setf (type-class-complex-intersection2 ,type-class) + #'delegate-complex-intersection2))))) ;;;; FUNCTION and VALUES types ;;;; @@ -137,20 +137,20 @@ ;;; the description of a &KEY argument (defstruct (key-info #-sb-xc-host (:pure t) - (:copier nil)) + (:copier nil)) ;; the key (not necessarily a keyword in ANSI Common Lisp) (name (missing-arg) :type symbol) ;; the type of the argument value (type (missing-arg) :type ctype)) (!define-type-method (values :simple-subtypep :complex-subtypep-arg1) - (type1 type2) + (type1 type2) (declare (ignore type2)) ;; FIXME: should be TYPE-ERROR, here and in next method (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type1))) (!define-type-method (values :complex-subtypep-arg2) - (type1 type2) + (type1 type2) (declare (ignore type1)) (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type2))) @@ -175,14 +175,14 @@ (types2 list2 (cdr types2))) ((or (null types1) (null types2)) (if (or types1 types2) - (values nil t) - (values t t))) + (values nil t) + (values t t))) (multiple-value-bind (val win) - (type= (first types1) (first types2)) + (type= (first types1) (first types2)) (unless win - (return (values nil nil))) + (return (values nil nil))) (unless val - (return (values nil t)))))) + (return (values nil t)))))) (!define-type-method (values :simple-=) (type1 type2) (type=-args type1 type2)) @@ -202,11 +202,11 @@ (if *unparse-fun-type-simplify* 'function (list 'function - (if (fun-type-wild-args type) - '* - (unparse-args-types type)) - (type-specifier - (fun-type-returns type))))) + (if (fun-type-wild-args type) + '* + (unparse-args-types type)) + (type-specifier + (fun-type-returns type))))) ;;; The meaning of this is a little confused. On the one hand, all ;;; function objects are represented the same way regardless of the @@ -232,13 +232,13 @@ (cond ((fun-type-keyp type2) (values nil nil)) ((not (fun-type-rest type2)) (values nil t)) ((not (null (fun-type-required type2))) - (values nil t)) + (values nil t)) (t (and/type (type= *universal-type* - (fun-type-rest type2)) + (fun-type-rest type2)) (every/type #'type= - *universal-type* + *universal-type* (fun-type-optional - type2)))))) + type2)))))) ((not (and (fun-type-simple-p type1) (fun-type-simple-p type2))) (values nil nil)) @@ -248,11 +248,11 @@ (values nil t)) ((and (= min1 min2) (= max1 max2)) (and/type (every-csubtypep - (fun-type-required type1) - (fun-type-required type2)) + (fun-type-required type1) + (fun-type-required type2)) (every-csubtypep - (fun-type-optional type1) - (fun-type-optional type2)))) + (fun-type-optional type1) + (fun-type-optional type2)))) (t (every-csubtypep (concatenate 'list (fun-type-required type1) @@ -352,7 +352,7 @@ (when (args-type-optional type) (result '&optional) (dolist (arg (args-type-optional type)) - (result (type-specifier arg)))) + (result (type-specifier arg)))) (when (args-type-rest type) (result '&rest) @@ -361,8 +361,8 @@ (when (args-type-keyp type) (result '&key) (dolist (key (args-type-keywords type)) - (result (list (key-info-name key) - (type-specifier (key-info-type key)))))) + (result (list (key-info-name key) + (type-specifier (key-info-type key)))))) (when (args-type-allowp type) (result '&allow-other-keys)) @@ -411,11 +411,11 @@ (declare (type ctype type)) (if (and (fun-type-p type) (not (fun-type-wild-args type))) (let ((fixed (length (args-type-required type)))) - (if (or (args-type-rest type) - (args-type-keyp type) - (args-type-allowp type)) - (values fixed nil) - (values fixed (+ fixed (length (args-type-optional type)))))) + (if (or (args-type-rest type) + (args-type-keyp type) + (args-type-allowp type)) + (values fixed nil) + (values fixed (+ fixed (length (args-type-optional type)))))) (values nil nil))) ;;; Determine whether TYPE corresponds to a definite number of values. @@ -425,13 +425,13 @@ (defun values-types (type) (declare (type ctype type)) (cond ((or (eq type *wild-type*) (eq type *empty-type*)) - (values nil :unknown)) - ((or (args-type-optional type) - (args-type-rest type)) - (values nil :unknown)) - (t - (let ((req (args-type-required type))) - (values req (length req)))))) + (values nil :unknown)) + ((or (args-type-optional type) + (args-type-rest type)) + (values nil :unknown)) + (t + (let ((req (args-type-required type))) + (values req (length req)))))) ;;; Return two values: ;;; 1. A list of all the positional (fixed and optional) types. @@ -495,16 +495,16 @@ (declare (list types1 types2) (type ctype rest2) (type function operation)) (let ((exact t)) (values (mapcar (lambda (t1 t2) - (multiple-value-bind (res win) - (funcall operation t1 t2) - (unless win - (setq exact nil)) - res)) - types1 - (append types2 - (make-list (- (length types1) (length types2)) - :initial-element rest2))) - exact))) + (multiple-value-bind (res win) + (funcall operation t1 t2) + (unless win + (setq exact nil)) + res)) + types1 + (append types2 + (make-list (- (length types1) (length types2)) + :initial-element rest2))) + exact))) ;;; If TYPE isn't a values type, then make it into one. (defun-cached (%coerce-to-values @@ -573,7 +573,7 @@ ;;; second value being true doesn't mean the result is exact. (defun args-type-op (type1 type2 operation nreq) (declare (type ctype type1 type2) - (type function operation nreq)) + (type function operation nreq)) (when (eq type1 type2) (values type1 t)) (multiple-value-bind (types1 rest1) @@ -627,9 +627,9 @@ ;;; The return convention seems to be analogous to ;;; TYPES-EQUAL-OR-INTERSECT. -- WHN 19990910. (defun-cached (values-type-union :hash-function type-cache-hash - :hash-bits 8 - :default nil - :init-wrapper !cold-init-forms) + :hash-bits 8 + :default nil + :init-wrapper !cold-init-forms) ((type1 eq) (type2 eq)) (declare (type ctype type1 type2)) (cond ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) *wild-type*) @@ -639,9 +639,9 @@ (values (values-type-op type1 type2 #'type-union #'min))))) (defun-cached (values-type-intersection :hash-function type-cache-hash - :hash-bits 8 - :default (values nil) - :init-wrapper !cold-init-forms) + :hash-bits 8 + :default (values nil) + :init-wrapper !cold-init-forms) ((type1 eq) (type2 eq)) (declare (type ctype type1 type2)) (cond ((eq type1 *wild-type*) @@ -669,21 +669,21 @@ ;;; there isn't really any intersection. (defun values-types-equal-or-intersect (type1 type2) (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*)) - (values t t)) + (values t t)) ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) (values t t)) - (t - (let ((res (values-type-intersection type1 type2))) - (values (not (eq res *empty-type*)) - t))))) + (t + (let ((res (values-type-intersection type1 type2))) + (values (not (eq res *empty-type*)) + t))))) ;;; a SUBTYPEP-like operation that can be used on any types, including ;;; VALUES types (defun-cached (values-subtypep :hash-function type-cache-hash - :hash-bits 8 - :values 2 - :default (values nil :empty) - :init-wrapper !cold-init-forms) + :hash-bits 8 + :values 2 + :default (values nil :empty) + :init-wrapper !cold-init-forms) ((type1 eq) (type2 eq)) (declare (type ctype type1 type2)) (cond ((or (eq type2 *wild-type*) (eq type2 *universal-type*) @@ -722,23 +722,23 @@ ;;; like SUBTYPEP, only works on CTYPE structures (defun-cached (csubtypep :hash-function type-cache-hash - :hash-bits 8 - :values 2 - :default (values nil :empty) - :init-wrapper !cold-init-forms) - ((type1 eq) (type2 eq)) + :hash-bits 8 + :values 2 + :default (values nil :empty) + :init-wrapper !cold-init-forms) + ((type1 eq) (type2 eq)) (declare (type ctype type1 type2)) (cond ((or (eq type1 type2) - (eq type1 *empty-type*) - (eq type2 *universal-type*)) - (values t t)) + (eq type1 *empty-type*) + (eq type2 *universal-type*)) + (values t t)) #+nil - ((eq type1 *universal-type*) - (values nil t)) - (t - (!invoke-type-method :simple-subtypep :complex-subtypep-arg2 - type1 type2 - :complex-arg1 :complex-subtypep-arg1)))) + ((eq type1 *universal-type*) + (values nil t)) + (t + (!invoke-type-method :simple-subtypep :complex-subtypep-arg2 + type1 type2 + :complex-arg1 :complex-subtypep-arg1)))) ;;; Just parse the type specifiers and call CSUBTYPE. (defun sb!xc:subtypep (type1 type2 &optional environment) @@ -754,11 +754,11 @@ ;;; value indicates whether the first value is definitely correct. ;;; This should only fail in the presence of HAIRY types. (defun-cached (type= :hash-function type-cache-hash - :hash-bits 8 - :values 2 - :default (values nil :empty) - :init-wrapper !cold-init-forms) - ((type1 eq) (type2 eq)) + :hash-bits 8 + :values 2 + :default (values nil :empty) + :init-wrapper !cold-init-forms) + ((type1 eq) (type2 eq)) (declare (type ctype type1 type2)) (if (eq type1 type2) (values t t) @@ -771,8 +771,8 @@ (declare (type ctype type1 type2)) (multiple-value-bind (res win) (type= type1 type2) (if win - (values (not res) t) - (values nil nil)))) + (values (not res) t) + (values nil nil)))) ;;; the type method dispatch case of TYPE-UNION2 (defun %type-union2 (type1 type2) @@ -783,12 +783,12 @@ ;; %TYPE-INTERSECTION2, there seems to be no need to distinguish ;; between not finding a method and having a method return NIL. (flet ((1way (x y) - (!invoke-type-method :simple-union2 :complex-union2 - x y - :default nil))) + (!invoke-type-method :simple-union2 :complex-union2 + x y + :default nil))) (declare (inline 1way)) (or (1way type1 type2) - (1way type2 type1)))) + (1way type2 type1)))) ;;; Find a type which includes both types. Any inexactness is ;;; represented by the fuzzy element types; we return a single value @@ -796,27 +796,27 @@ ;;; simplified into the canonical form, thus is not a UNION-TYPE ;;; unless we find no other way to represent the result. (defun-cached (type-union2 :hash-function type-cache-hash - :hash-bits 8 - :init-wrapper !cold-init-forms) - ((type1 eq) (type2 eq)) + :hash-bits 8 + :init-wrapper !cold-init-forms) + ((type1 eq) (type2 eq)) ;; KLUDGE: This was generated from TYPE-INTERSECTION2 by Ye Olde Cut And ;; Paste technique of programming. If it stays around (as opposed to ;; e.g. fading away in favor of some CLOS solution) the shared logic ;; should probably become shared code. -- WHN 2001-03-16 (declare (type ctype type1 type2)) (cond ((eq type1 type2) - type1) - ((csubtypep type1 type2) type2) - ((csubtypep type2 type1) type1) - ((or (union-type-p type1) - (union-type-p type2)) - ;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES - ;; values broken out and united separately. The full TYPE-UNION - ;; function knows how to do this, so let it handle it. - (type-union type1 type2)) - (t - ;; the ordinary case: we dispatch to type methods - (%type-union2 type1 type2)))) + type1) + ((csubtypep type1 type2) type2) + ((csubtypep type2 type1) type1) + ((or (union-type-p type1) + (union-type-p type2)) + ;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES + ;; values broken out and united separately. The full TYPE-UNION + ;; function knows how to do this, so let it handle it. + (type-union type1 type2)) + (t + ;; the ordinary case: we dispatch to type methods + (%type-union2 type1 type2)))) ;;; the type method dispatch case of TYPE-INTERSECTION2 (defun %type-intersection2 (type1 type2) @@ -837,43 +837,43 @@ ;; ;; (Why yes, CLOS probably *would* be nicer..) (flet ((1way (x y) - (!invoke-type-method :simple-intersection2 :complex-intersection2 - x y - :default :call-other-method))) + (!invoke-type-method :simple-intersection2 :complex-intersection2 + x y + :default :call-other-method))) (declare (inline 1way)) (let ((xy (1way type1 type2))) (or (and (not (eql xy :call-other-method)) xy) - (let ((yx (1way type2 type1))) - (or (and (not (eql yx :call-other-method)) yx) - (cond ((and (eql xy :call-other-method) - (eql yx :call-other-method)) - *empty-type*) - (t - (aver (and (not xy) (not yx))) ; else handled above - nil)))))))) + (let ((yx (1way type2 type1))) + (or (and (not (eql yx :call-other-method)) yx) + (cond ((and (eql xy :call-other-method) + (eql yx :call-other-method)) + *empty-type*) + (t + (aver (and (not xy) (not yx))) ; else handled above + nil)))))))) (defun-cached (type-intersection2 :hash-function type-cache-hash - :hash-bits 8 - :values 1 - :default nil - :init-wrapper !cold-init-forms) - ((type1 eq) (type2 eq)) + :hash-bits 8 + :values 1 + :default nil + :init-wrapper !cold-init-forms) + ((type1 eq) (type2 eq)) (declare (type ctype type1 type2)) (cond ((eq type1 type2) - ;; FIXME: For some reason, this doesn't catch e.g. type1 = - ;; type2 = (SPECIFIER-TYPE - ;; 'SOME-UNKNOWN-TYPE). Investigate. - CSR, 2002-04-10 - type1) - ((or (intersection-type-p type1) - (intersection-type-p type2)) - ;; Intersections of INTERSECTION-TYPE should have the - ;; INTERSECTION-TYPE-TYPES values broken out and intersected - ;; separately. The full TYPE-INTERSECTION function knows how - ;; to do that, so let it handle it. - (type-intersection type1 type2)) - (t - ;; the ordinary case: we dispatch to type methods - (%type-intersection2 type1 type2)))) + ;; FIXME: For some reason, this doesn't catch e.g. type1 = + ;; type2 = (SPECIFIER-TYPE + ;; 'SOME-UNKNOWN-TYPE). Investigate. - CSR, 2002-04-10 + type1) + ((or (intersection-type-p type1) + (intersection-type-p type2)) + ;; Intersections of INTERSECTION-TYPE should have the + ;; INTERSECTION-TYPE-TYPES values broken out and intersected + ;; separately. The full TYPE-INTERSECTION function knows how + ;; to do that, so let it handle it. + (type-intersection type1 type2)) + (t + ;; the ordinary case: we dispatch to type methods + (%type-intersection2 type1 type2)))) ;;; Return as restrictive and simple a type as we can discover that is ;;; no more restrictive than the intersection of TYPE1 and TYPE2. At @@ -881,8 +881,8 @@ ;;; value (trying not to return a hairy type). (defun type-approx-intersection2 (type1 type2) (cond ((type-intersection2 type1 type2)) - ((hairy-type-p type1) type2) - (t type1))) + ((hairy-type-p type1) type2) + (t type1))) ;;; a test useful for checking whether a derived type matches a ;;; declared type @@ -897,13 +897,13 @@ (if (or (eq type1 *empty-type*) (eq type2 *empty-type*)) (values t t) (let ((intersection2 (type-intersection2 type1 type2))) - (cond ((not intersection2) - (if (or (csubtypep *universal-type* type1) - (csubtypep *universal-type* type2)) - (values t t) - (values t nil))) - ((eq intersection2 *empty-type*) (values nil t)) - (t (values t t)))))) + (cond ((not intersection2) + (if (or (csubtypep *universal-type* type1) + (csubtypep *universal-type* type2)) + (values t t) + (values t nil))) + ((eq intersection2 *empty-type*) (values nil t)) + (t (values t t)))))) ;;; Return a Common Lisp type specifier corresponding to the TYPE ;;; object. @@ -912,12 +912,12 @@ (funcall (type-class-unparse (type-class-info type)) type)) (defun-cached (type-negation :hash-function (lambda (type) - (logand (type-hash-value type) - #xff)) - :hash-bits 8 - :values 1 - :default nil - :init-wrapper !cold-init-forms) + (logand (type-hash-value type) + #xff)) + :hash-bits 8 + :values 1 + :default nil + :init-wrapper !cold-init-forms) ((type eq)) (declare (type ctype type)) (funcall (type-class-negate (type-class-info type)) type)) @@ -932,18 +932,18 @@ (dolist (spec specs) (let ((res (specifier-type spec))) (unless (unknown-type-p res) - (setf (info :type :builtin spec) res) - ;; KLUDGE: the three copies of this idiom in this file (and - ;; the one in class.lisp as at sbcl-0.7.4.1x) should be - ;; coalesced, or perhaps the error-detecting code that - ;; disallows redefinition of :PRIMITIVE types should be - ;; rewritten to use *TYPE-SYSTEM-FINALIZED* (rather than - ;; *TYPE-SYSTEM-INITIALIZED*). The effect of this is not to - ;; cause redefinition errors when precompute-types is called - ;; for a second time while building the target compiler using - ;; the cross-compiler. -- CSR, trying to explain why this - ;; isn't completely wrong, 2002-06-07 - (setf (info :type :kind spec) #+sb-xc-host :defined #-sb-xc-host :primitive)))) + (setf (info :type :builtin spec) res) + ;; KLUDGE: the three copies of this idiom in this file (and + ;; the one in class.lisp as at sbcl-0.7.4.1x) should be + ;; coalesced, or perhaps the error-detecting code that + ;; disallows redefinition of :PRIMITIVE types should be + ;; rewritten to use *TYPE-SYSTEM-FINALIZED* (rather than + ;; *TYPE-SYSTEM-INITIALIZED*). The effect of this is not to + ;; cause redefinition errors when precompute-types is called + ;; for a second time while building the target compiler using + ;; the cross-compiler. -- CSR, trying to explain why this + ;; isn't completely wrong, 2002-06-07 + (setf (info :type :kind spec) #+sb-xc-host :defined #-sb-xc-host :primitive)))) (values)) ;;;; general TYPE-UNION and TYPE-INTERSECTION operations @@ -957,30 +957,30 @@ ;;; component types, and with any SIMPLY2 simplifications applied. (macrolet ((def (name compound-type-p simplify2) - `(defun ,name (types) - (when types - (multiple-value-bind (first rest) - (if (,compound-type-p (car types)) - (values (car (compound-type-types (car types))) - (append (cdr (compound-type-types (car types))) - (cdr types))) - (values (car types) (cdr types))) - (let ((rest (,name rest)) u) - (dolist (r rest (cons first rest)) - (when (setq u (,simplify2 first r)) - (return (,name (nsubstitute u r rest))))))))))) + `(defun ,name (types) + (when types + (multiple-value-bind (first rest) + (if (,compound-type-p (car types)) + (values (car (compound-type-types (car types))) + (append (cdr (compound-type-types (car types))) + (cdr types))) + (values (car types) (cdr types))) + (let ((rest (,name rest)) u) + (dolist (r rest (cons first rest)) + (when (setq u (,simplify2 first r)) + (return (,name (nsubstitute u r rest))))))))))) (def simplify-intersections intersection-type-p type-intersection2) (def simplify-unions union-type-p type-union2)) - + (defun maybe-distribute-one-union (union-type types) (let* ((intersection (apply #'type-intersection types)) - (union (mapcar (lambda (x) (type-intersection x intersection)) - (union-type-types union-type)))) + (union (mapcar (lambda (x) (type-intersection x intersection)) + (union-type-types union-type)))) (if (notany (lambda (x) (or (hairy-type-p x) - (intersection-type-p x))) - union) - union - nil))) + (intersection-type-p x))) + union) + union + nil))) (defun type-intersection (&rest input-types) (%type-intersection input-types)) @@ -999,23 +999,23 @@ ;; we try to generate a simple type by distributing the union; if ;; the type can't be made simple, we punt to HAIRY-TYPE. (if (and (cdr simplified-types) (some #'union-type-p simplified-types)) - (let* ((first-union (find-if #'union-type-p simplified-types)) - (other-types (coerce (remove first-union simplified-types) - 'list)) - (distributed (maybe-distribute-one-union first-union - other-types))) - (if distributed - (apply #'type-union distributed) - (make-hairy-type - :specifier `(and ,@(map 'list - #'type-specifier - simplified-types))))) - (cond - ((null simplified-types) *universal-type*) - ((null (cdr simplified-types)) (car simplified-types)) - (t (%make-intersection-type - (some #'type-enumerable simplified-types) - simplified-types)))))) + (let* ((first-union (find-if #'union-type-p simplified-types)) + (other-types (coerce (remove first-union simplified-types) + 'list)) + (distributed (maybe-distribute-one-union first-union + other-types))) + (if distributed + (apply #'type-union distributed) + (make-hairy-type + :specifier `(and ,@(map 'list + #'type-specifier + simplified-types))))) + (cond + ((null simplified-types) *universal-type*) + ((null (cdr simplified-types)) (car simplified-types)) + (t (%make-intersection-type + (some #'type-enumerable simplified-types) + simplified-types)))))) (defun type-union (&rest input-types) (%type-union input-types)) @@ -1028,8 +1028,8 @@ ((null simplified-types) *empty-type*) ((null (cdr simplified-types)) (car simplified-types)) (t (make-union-type - (every #'type-enumerable simplified-types) - simplified-types))))) + (every #'type-enumerable simplified-types) + simplified-types))))) ;;;; built-in types @@ -1037,11 +1037,11 @@ (!cold-init-forms (macrolet ((frob (name var) - `(progn + `(progn (setq ,var (make-named-type :name ',name)) - (setf (info :type :kind ',name) - #+sb-xc-host :defined #-sb-xc-host :primitive) - (setf (info :type :builtin ',name) ,var)))) + (setf (info :type :kind ',name) + #+sb-xc-host :defined #-sb-xc-host :primitive) + (setf (info :type :builtin ',name) ,var)))) ;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a ;; special symbol which can be stuck in some places where an ;; ordinary type can go, e.g. (ARRAY * 1) instead of (ARRAY T 1). @@ -1051,7 +1051,7 @@ (frob t *universal-type*)) (setf *universal-fun-type* (make-fun-type :wild-args t - :returns *wild-type*))) + :returns *wild-type*))) (!define-type-method (named :simple-=) (type1 type2) ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type. @@ -1060,12 +1060,12 @@ (!define-type-method (named :complex-=) (type1 type2) (cond ((and (eq type2 *empty-type*) - (intersection-type-p type1) - ;; not allowed to be unsure on these... FIXME: keep the list - ;; of CL types that are intersection types once and only - ;; once. - (not (or (type= type1 (specifier-type 'ratio)) - (type= type1 (specifier-type 'keyword))))) + (intersection-type-p type1) + ;; not allowed to be unsure on these... FIXME: keep the list + ;; of CL types that are intersection types once and only + ;; once. + (not (or (type= type1 (specifier-type 'ratio)) + (type= type1 (specifier-type 'keyword))))) ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION ;; STREAM) can get here. In general, we can't really tell ;; whether these are equal to NIL or not, so @@ -1087,45 +1087,45 @@ ;; ;; (aver (not (eq type1 *wild-type*))) ; * isn't really a type. (cond ((eq type1 *empty-type*) - t) - (;; When TYPE2 might be the universal type in disguise - (type-might-contain-other-types-p type2) - ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods - ;; can delegate to us (more or less as CALL-NEXT-METHOD) when - ;; they're uncertain, we can't just barf on COMPOUND-TYPE and - ;; HAIRY-TYPEs as we used to. Instead we deal with the - ;; problem (where at least part of the problem is cases like - ;; (SUBTYPEP T '(SATISFIES FOO)) - ;; or - ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR))) - ;; where the second type is a hairy type like SATISFIES, or - ;; is a compound type which might contain a hairy type) by - ;; returning uncertainty. - (values nil nil)) - (t - ;; By elimination, TYPE1 is the universal type. - (aver (eq type1 *universal-type*)) - ;; This case would have been picked off by the SIMPLE-SUBTYPEP - ;; method, and so shouldn't appear here. - (aver (not (eq type2 *universal-type*))) - ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not the - ;; universal type in disguise, TYPE2 is not a superset of TYPE1. - (values nil t)))) + t) + (;; When TYPE2 might be the universal type in disguise + (type-might-contain-other-types-p type2) + ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods + ;; can delegate to us (more or less as CALL-NEXT-METHOD) when + ;; they're uncertain, we can't just barf on COMPOUND-TYPE and + ;; HAIRY-TYPEs as we used to. Instead we deal with the + ;; problem (where at least part of the problem is cases like + ;; (SUBTYPEP T '(SATISFIES FOO)) + ;; or + ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR))) + ;; where the second type is a hairy type like SATISFIES, or + ;; is a compound type which might contain a hairy type) by + ;; returning uncertainty. + (values nil nil)) + (t + ;; By elimination, TYPE1 is the universal type. + (aver (eq type1 *universal-type*)) + ;; This case would have been picked off by the SIMPLE-SUBTYPEP + ;; method, and so shouldn't appear here. + (aver (not (eq type2 *universal-type*))) + ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not the + ;; universal type in disguise, TYPE2 is not a superset of TYPE1. + (values nil t)))) (!define-type-method (named :complex-subtypep-arg2) (type1 type2) (aver (not (eq type2 *wild-type*))) ; * isn't really a type. (cond ((eq type2 *universal-type*) - (values t t)) - ((type-might-contain-other-types-p type1) - ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in - ;; disguise. So we'd better delegate. - (invoke-complex-subtypep-arg1-method type1 type2)) - (t - ;; FIXME: This seems to rely on there only being 2 or 3 - ;; NAMED-TYPE values, and the exclusion of various - ;; possibilities above. It would be good to explain it and/or - ;; rewrite it so that it's clearer. - (values (not (eq type2 *empty-type*)) t)))) + (values t t)) + ((type-might-contain-other-types-p type1) + ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in + ;; disguise. So we'd better delegate. + (invoke-complex-subtypep-arg1-method type1 type2)) + (t + ;; FIXME: This seems to rely on there only being 2 or 3 + ;; NAMED-TYPE values, and the exclusion of various + ;; possibilities above. It would be good to explain it and/or + ;; rewrite it so that it's clearer. + (values (not (eq type2 *empty-type*)) t)))) (!define-type-method (named :complex-intersection2) (type1 type2) ;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13. @@ -1158,11 +1158,11 @@ (!define-type-method (hairy :simple-subtypep) (type1 type2) (let ((hairy-spec1 (hairy-type-specifier type1)) - (hairy-spec2 (hairy-type-specifier type2))) + (hairy-spec2 (hairy-type-specifier type2))) (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2) - (values t t)) - (t - (values nil nil))))) + (values t t)) + (t + (values nil nil))))) (!define-type-method (hairy :complex-subtypep-arg2) (type1 type2) (invoke-complex-subtypep-arg1-method type1 type2)) @@ -1184,21 +1184,21 @@ (type= type1 type2))) (values nil nil))) -(!define-type-method (hairy :simple-intersection2 :complex-intersection2) - (type1 type2) +(!define-type-method (hairy :simple-intersection2 :complex-intersection2) + (type1 type2) (if (type= type1 type2) type1 nil)) -(!define-type-method (hairy :simple-union2) - (type1 type2) +(!define-type-method (hairy :simple-union2) + (type1 type2) (if (type= type1 type2) type1 nil)) (!define-type-method (hairy :simple-=) (type1 type2) (if (equal-but-no-car-recursion (hairy-type-specifier type1) - (hairy-type-specifier type2)) + (hairy-type-specifier type2)) (values t t) (values nil nil))) @@ -1209,10 +1209,10 @@ (declare (ignore satisfies)) (unless (symbolp predicate-name) (error 'simple-type-error - :datum predicate-name - :expected-type 'symbol - :format-control "The SATISFIES predicate name is not a symbol: ~S" - :format-arguments (list predicate-name)))) + :datum predicate-name + :expected-type 'symbol + :format-control "The SATISFIES predicate name is not a symbol: ~S" + :format-arguments (list predicate-name)))) ;; Create object. (make-hairy-type :specifier whole)) @@ -1231,12 +1231,12 @@ (!define-type-method (negation :complex-subtypep-arg2) (type1 type2) (let* ((complement-type2 (negation-type-type type2)) - (intersection2 (type-intersection2 type1 - complement-type2))) + (intersection2 (type-intersection2 type1 + complement-type2))) (if intersection2 - ;; FIXME: if uncertain, maybe try arg1? - (type= intersection2 *empty-type*) - (invoke-complex-subtypep-arg1-method type1 type2)))) + ;; FIXME: if uncertain, maybe try arg1? + (type= intersection2 *empty-type*) + (invoke-complex-subtypep-arg1-method type1 type2)))) (!define-type-method (negation :complex-subtypep-arg1) (type1 type2) ;; "Incrementally extended heuristic algorithms tend inexorably toward the @@ -1253,22 +1253,22 @@ ;; maintenance might make it possible for it to end up in this ;; code.) (multiple-value-bind (equal certain) - (type= type2 *universal-type*) + (type= type2 *universal-type*) (unless certain - (return (values nil nil))) + (return (values nil nil))) (when equal - (return (values t t)))) + (return (values t t)))) (let ((complement-type1 (negation-type-type type1))) ;; Do the special cases first, in order to give us a chance if ;; subtype/supertype relationships are hairy. (multiple-value-bind (equal certain) - (type= complement-type1 type2) - ;; If a = b, ~a is not a subtype of b (unless b=T, which was - ;; excluded above). - (unless certain - (return (values nil nil))) - (when equal - (return (values nil t)))) + (type= complement-type1 type2) + ;; If a = b, ~a is not a subtype of b (unless b=T, which was + ;; excluded above). + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) ;; KLUDGE: ANSI requires that the SUBTYPEP result between any ;; two built-in atomic type specifiers never be uncertain. This ;; is hard to do cleanly for the built-in types whose @@ -1281,33 +1281,33 @@ ;; representation in the type system could make it start ;; confidently returning incorrect results.) -- WHN 2002-03-08 (unless (or (type-might-contain-other-types-p complement-type1) - (type-might-contain-other-types-p type2)) - ;; Because of the way our types which don't contain other - ;; types are disjoint subsets of the space of possible values, - ;; (SUBTYPEP '(NOT AA) 'B)=NIL when AA and B are simple (and B - ;; is not T, as checked above). - (return (values nil t))) + (type-might-contain-other-types-p type2)) + ;; Because of the way our types which don't contain other + ;; types are disjoint subsets of the space of possible values, + ;; (SUBTYPEP '(NOT AA) 'B)=NIL when AA and B are simple (and B + ;; is not T, as checked above). + (return (values nil t))) ;; The old (TYPE= TYPE1 TYPE2) branch would never be taken, as ;; TYPE1 and TYPE2 will only be equal if they're both NOT types, ;; and then the :SIMPLE-SUBTYPEP method would be used instead. ;; But a CSUBTYPEP relationship might still hold: (multiple-value-bind (equal certain) - (csubtypep complement-type1 type2) - ;; If a is a subtype of b, ~a is not a subtype of b (unless - ;; b=T, which was excluded above). - (unless certain - (return (values nil nil))) - (when equal - (return (values nil t)))) + (csubtypep complement-type1 type2) + ;; If a is a subtype of b, ~a is not a subtype of b (unless + ;; b=T, which was excluded above). + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) (multiple-value-bind (equal certain) - (csubtypep type2 complement-type1) - ;; If b is a subtype of a, ~a is not a subtype of b. (FIXME: - ;; That's not true if a=T. Do we know at this point that a is - ;; not T?) - (unless certain - (return (values nil nil))) - (when equal - (return (values nil t)))) + (csubtypep type2 complement-type1) + ;; If b is a subtype of a, ~a is not a subtype of b. (FIXME: + ;; That's not true if a=T. Do we know at this point that a is + ;; not T?) + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) ;; old CSR comment ca. 0.7.2, now obsoleted by the SIMPLE-CTYPE? ;; KLUDGE case above: Other cases here would rely on being able ;; to catch all possible cases, which the fragility of this type @@ -1331,7 +1331,7 @@ (!define-type-method (negation :simple-intersection2) (type1 type2) (let ((not1 (negation-type-type type1)) - (not2 (negation-type-type type2))) + (not2 (negation-type-type type2))) (cond ((csubtypep not1 not2) type2) ((csubtypep not2 not1) type1) @@ -1356,7 +1356,7 @@ (!define-type-method (negation :simple-union2) (type1 type2) (let ((not1 (negation-type-type type1)) - (not2 (negation-type-type type2))) + (not2 (negation-type-type type2))) (cond ((csubtypep not1 not2) type1) ((csubtypep not2 not1) type2) @@ -1390,8 +1390,8 @@ (!define-type-method (number :simple-=) (type1 type2) (values (and (numeric-type-equal type1 type2) - (equalp (numeric-type-low type1) (numeric-type-low type2)) - (equalp (numeric-type-high type1) (numeric-type-high type2))) + (equalp (numeric-type-low type1) (numeric-type-low type2)) + (equalp (numeric-type-high type1) (numeric-type-high type2))) t)) (!define-type-method (number :negate) (type) @@ -1399,77 +1399,77 @@ (make-negation-type :type type) (type-union (make-negation-type - :type (modified-numeric-type type :low nil :high nil)) + :type (modified-numeric-type type :low nil :high nil)) (cond - ((null (numeric-type-low type)) - (modified-numeric-type - type - :low (let ((h (numeric-type-high type))) - (if (consp h) (car h) (list h))) - :high nil)) - ((null (numeric-type-high type)) - (modified-numeric-type - type - :low nil - :high (let ((l (numeric-type-low type))) - (if (consp l) (car l) (list l))))) - (t (type-union - (modified-numeric-type - type - :low nil - :high (let ((l (numeric-type-low type))) - (if (consp l) (car l) (list l)))) - (modified-numeric-type - type - :low (let ((h (numeric-type-high type))) - (if (consp h) (car h) (list h))) - :high nil))))))) + ((null (numeric-type-low type)) + (modified-numeric-type + type + :low (let ((h (numeric-type-high type))) + (if (consp h) (car h) (list h))) + :high nil)) + ((null (numeric-type-high type)) + (modified-numeric-type + type + :low nil + :high (let ((l (numeric-type-low type))) + (if (consp l) (car l) (list l))))) + (t (type-union + (modified-numeric-type + type + :low nil + :high (let ((l (numeric-type-low type))) + (if (consp l) (car l) (list l)))) + (modified-numeric-type + type + :low (let ((h (numeric-type-high type))) + (if (consp h) (car h) (list h))) + :high nil))))))) (!define-type-method (number :unparse) (type) (let* ((complexp (numeric-type-complexp type)) - (low (numeric-type-low type)) - (high (numeric-type-high type)) - (base (case (numeric-type-class type) - (integer 'integer) - (rational 'rational) - (float (or (numeric-type-format type) 'float)) - (t 'real)))) + (low (numeric-type-low type)) + (high (numeric-type-high type)) + (base (case (numeric-type-class type) + (integer 'integer) + (rational 'rational) + (float (or (numeric-type-format type) 'float)) + (t 'real)))) (let ((base+bounds - (cond ((and (eq base 'integer) high low) - (let ((high-count (logcount high)) - (high-length (integer-length high))) - (cond ((= low 0) - (cond ((= high 0) '(integer 0 0)) - ((= high 1) 'bit) - ((and (= high-count high-length) - (plusp high-length)) - `(unsigned-byte ,high-length)) - (t - `(mod ,(1+ high))))) - ((and (= low sb!xc:most-negative-fixnum) - (= high sb!xc:most-positive-fixnum)) - 'fixnum) - ((and (= low (lognot high)) - (= high-count high-length) - (> high-count 0)) - `(signed-byte ,(1+ high-length))) - (t - `(integer ,low ,high))))) - (high `(,base ,(or low '*) ,high)) - (low - (if (and (eq base 'integer) (= low 0)) - 'unsigned-byte - `(,base ,low))) - (t base)))) + (cond ((and (eq base 'integer) high low) + (let ((high-count (logcount high)) + (high-length (integer-length high))) + (cond ((= low 0) + (cond ((= high 0) '(integer 0 0)) + ((= high 1) 'bit) + ((and (= high-count high-length) + (plusp high-length)) + `(unsigned-byte ,high-length)) + (t + `(mod ,(1+ high))))) + ((and (= low sb!xc:most-negative-fixnum) + (= high sb!xc:most-positive-fixnum)) + 'fixnum) + ((and (= low (lognot high)) + (= high-count high-length) + (> high-count 0)) + `(signed-byte ,(1+ high-length))) + (t + `(integer ,low ,high))))) + (high `(,base ,(or low '*) ,high)) + (low + (if (and (eq base 'integer) (= low 0)) + 'unsigned-byte + `(,base ,low))) + (t base)))) (ecase complexp - (:real - base+bounds) - (:complex - (aver (neq base+bounds 'real)) - `(complex ,base+bounds)) - ((nil) - (aver (eq base+bounds 'real)) - 'number))))) + (:real + base+bounds) + (:complex + (aver (neq base+bounds 'real)) + `(complex ,base+bounds)) + ((nil) + (aver (eq base+bounds 'real)) + 'number))))) ;;; Return true if X is "less than or equal" to Y, taking open bounds ;;; into consideration. CLOSED is the predicate used to test the bound @@ -1483,15 +1483,15 @@ ;;; upper. Use NUMERIC-BOUND-TEST* for different kinds of bounds. (defmacro numeric-bound-test (x y closed open) `(cond ((not ,y) t) - ((not ,x) nil) - ((consp ,x) - (if (consp ,y) - (,closed (car ,x) (car ,y)) - (,closed (car ,x) ,y))) - (t - (if (consp ,y) - (,open ,x (car ,y)) - (,closed ,x ,y))))) + ((not ,x) nil) + ((consp ,x) + (if (consp ,y) + (,closed (car ,x) (car ,y)) + (,closed (car ,x) ,y))) + (t + (if (consp ,y) + (,open ,x (car ,y)) + (,closed ,x ,y))))) ;;; This is used to compare upper and lower bounds. This is different ;;; from the same-bound case: @@ -1501,15 +1501,15 @@ ;;; causing us to use the OPEN test for those cases as well. (defmacro numeric-bound-test* (x y closed open) `(cond ((not ,y) t) - ((not ,x) t) - ((consp ,x) - (if (consp ,y) - (,open (car ,x) (car ,y)) - (,open (car ,x) ,y))) - (t - (if (consp ,y) - (,open ,x (car ,y)) - (,closed ,x ,y))))) + ((not ,x) t) + ((consp ,x) + (if (consp ,y) + (,open (car ,x) (car ,y)) + (,open (car ,x) ,y))) + (t + (if (consp ,y) + (,open ,x (car ,y)) + (,closed ,x ,y))))) ;;; Return whichever of the numeric bounds X and Y is "maximal" ;;; according to the predicates CLOSED (e.g. >=) and OPEN (e.g. >). @@ -1518,51 +1518,51 @@ ;;; otherwise we return the other arg. (defmacro numeric-bound-max (x y closed open max-p) (once-only ((n-x x) - (n-y y)) + (n-y y)) `(cond ((not ,n-x) ,(if max-p nil n-y)) - ((not ,n-y) ,(if max-p nil n-x)) - ((consp ,n-x) - (if (consp ,n-y) - (if (,closed (car ,n-x) (car ,n-y)) ,n-x ,n-y) - (if (,open (car ,n-x) ,n-y) ,n-x ,n-y))) - (t - (if (consp ,n-y) - (if (,open (car ,n-y) ,n-x) ,n-y ,n-x) - (if (,closed ,n-y ,n-x) ,n-y ,n-x)))))) + ((not ,n-y) ,(if max-p nil n-x)) + ((consp ,n-x) + (if (consp ,n-y) + (if (,closed (car ,n-x) (car ,n-y)) ,n-x ,n-y) + (if (,open (car ,n-x) ,n-y) ,n-x ,n-y))) + (t + (if (consp ,n-y) + (if (,open (car ,n-y) ,n-x) ,n-y ,n-x) + (if (,closed ,n-y ,n-x) ,n-y ,n-x)))))) (!define-type-method (number :simple-subtypep) (type1 type2) (let ((class1 (numeric-type-class type1)) - (class2 (numeric-type-class type2)) - (complexp2 (numeric-type-complexp type2)) - (format2 (numeric-type-format type2)) - (low1 (numeric-type-low type1)) - (high1 (numeric-type-high type1)) - (low2 (numeric-type-low type2)) - (high2 (numeric-type-high type2))) + (class2 (numeric-type-class type2)) + (complexp2 (numeric-type-complexp type2)) + (format2 (numeric-type-format type2)) + (low1 (numeric-type-low type1)) + (high1 (numeric-type-high type1)) + (low2 (numeric-type-low type2)) + (high2 (numeric-type-high type2))) ;; If one is complex and the other isn't, they are disjoint. (cond ((not (or (eq (numeric-type-complexp type1) complexp2) - (null complexp2))) - (values nil t)) - ;; If the classes are specified and different, the types are - ;; disjoint unless type2 is RATIONAL and type1 is INTEGER. - ;; [ or type1 is INTEGER and type2 is of the form (RATIONAL - ;; X X) for integral X, but this is dealt with in the - ;; canonicalization inside MAKE-NUMERIC-TYPE ] - ((not (or (eq class1 class2) - (null class2) - (and (eq class1 'integer) (eq class2 'rational)))) - (values nil t)) - ;; If the float formats are specified and different, the types - ;; are disjoint. - ((not (or (eq (numeric-type-format type1) format2) - (null format2))) - (values nil t)) - ;; Check the bounds. - ((and (numeric-bound-test low1 low2 >= >) - (numeric-bound-test high1 high2 <= <)) - (values t t)) - (t - (values nil t))))) + (null complexp2))) + (values nil t)) + ;; If the classes are specified and different, the types are + ;; disjoint unless type2 is RATIONAL and type1 is INTEGER. + ;; [ or type1 is INTEGER and type2 is of the form (RATIONAL + ;; X X) for integral X, but this is dealt with in the + ;; canonicalization inside MAKE-NUMERIC-TYPE ] + ((not (or (eq class1 class2) + (null class2) + (and (eq class1 'integer) (eq class2 'rational)))) + (values nil t)) + ;; If the float formats are specified and different, the types + ;; are disjoint. + ((not (or (eq (numeric-type-format type1) format2) + (null format2))) + (values nil t)) + ;; Check the bounds. + ((and (numeric-bound-test low1 low2 >= >) + (numeric-bound-test high1 high2 <= <)) + (values t t)) + (t + (values nil t))))) (!define-superclasses number ((number)) !cold-init-forms) @@ -1570,52 +1570,52 @@ ;;; then return true, otherwise NIL. (defun numeric-types-adjacent (low high) (let ((low-bound (numeric-type-high low)) - (high-bound (numeric-type-low high))) + (high-bound (numeric-type-low high))) (cond ((not (and low-bound high-bound)) nil) - ((and (consp low-bound) (consp high-bound)) nil) - ((consp low-bound) - (let ((low-value (car low-bound))) - (or (eql low-value high-bound) - (and (eql low-value - (load-time-value (make-unportable-float - :single-float-negative-zero))) - (eql high-bound 0f0)) - (and (eql low-value 0f0) - (eql high-bound - (load-time-value (make-unportable-float - :single-float-negative-zero)))) - (and (eql low-value - (load-time-value (make-unportable-float - :double-float-negative-zero))) - (eql high-bound 0d0)) - (and (eql low-value 0d0) - (eql high-bound - (load-time-value (make-unportable-float - :double-float-negative-zero))))))) - ((consp high-bound) - (let ((high-value (car high-bound))) - (or (eql high-value low-bound) - (and (eql high-value - (load-time-value (make-unportable-float - :single-float-negative-zero))) - (eql low-bound 0f0)) - (and (eql high-value 0f0) - (eql low-bound - (load-time-value (make-unportable-float - :single-float-negative-zero)))) - (and (eql high-value - (load-time-value (make-unportable-float - :double-float-negative-zero))) - (eql low-bound 0d0)) - (and (eql high-value 0d0) - (eql low-bound - (load-time-value (make-unportable-float - :double-float-negative-zero))))))) - ((and (eq (numeric-type-class low) 'integer) - (eq (numeric-type-class high) 'integer)) - (eql (1+ low-bound) high-bound)) - (t - nil)))) + ((and (consp low-bound) (consp high-bound)) nil) + ((consp low-bound) + (let ((low-value (car low-bound))) + (or (eql low-value high-bound) + (and (eql low-value + (load-time-value (make-unportable-float + :single-float-negative-zero))) + (eql high-bound 0f0)) + (and (eql low-value 0f0) + (eql high-bound + (load-time-value (make-unportable-float + :single-float-negative-zero)))) + (and (eql low-value + (load-time-value (make-unportable-float + :double-float-negative-zero))) + (eql high-bound 0d0)) + (and (eql low-value 0d0) + (eql high-bound + (load-time-value (make-unportable-float + :double-float-negative-zero))))))) + ((consp high-bound) + (let ((high-value (car high-bound))) + (or (eql high-value low-bound) + (and (eql high-value + (load-time-value (make-unportable-float + :single-float-negative-zero))) + (eql low-bound 0f0)) + (and (eql high-value 0f0) + (eql low-bound + (load-time-value (make-unportable-float + :single-float-negative-zero)))) + (and (eql high-value + (load-time-value (make-unportable-float + :double-float-negative-zero))) + (eql low-bound 0d0)) + (and (eql high-value 0d0) + (eql low-bound + (load-time-value (make-unportable-float + :double-float-negative-zero))))))) + ((and (eq (numeric-type-class low) 'integer) + (eq (numeric-type-class high) 'integer)) + (eql (1+ low-bound) high-bound)) + (t + nil)))) ;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2. ;;; @@ -1626,116 +1626,116 @@ (!define-type-method (number :simple-union2) (type1 type2) (declare (type numeric-type type1 type2)) (cond ((csubtypep type1 type2) type2) - ((csubtypep type2 type1) type1) - (t - (let ((class1 (numeric-type-class type1)) - (format1 (numeric-type-format type1)) - (complexp1 (numeric-type-complexp type1)) - (class2 (numeric-type-class type2)) - (format2 (numeric-type-format type2)) - (complexp2 (numeric-type-complexp type2))) - (cond - ((and (eq class1 class2) - (eq format1 format2) - (eq complexp1 complexp2) - (or (numeric-types-intersect type1 type2) - (numeric-types-adjacent type1 type2) - (numeric-types-adjacent type2 type1))) - (make-numeric-type - :class class1 - :format format1 - :complexp complexp1 - :low (numeric-bound-max (numeric-type-low type1) - (numeric-type-low type2) - <= < t) - :high (numeric-bound-max (numeric-type-high type1) - (numeric-type-high type2) - >= > t))) - ;; FIXME: These two clauses are almost identical, and the - ;; consequents are in fact identical in every respect. - ((and (eq class1 'rational) - (eq class2 'integer) - (eq format1 format2) - (eq complexp1 complexp2) - (integerp (numeric-type-low type2)) - (integerp (numeric-type-high type2)) - (= (numeric-type-low type2) (numeric-type-high type2)) - (or (numeric-types-adjacent type1 type2) - (numeric-types-adjacent type2 type1))) - (make-numeric-type - :class 'rational - :format format1 - :complexp complexp1 - :low (numeric-bound-max (numeric-type-low type1) - (numeric-type-low type2) - <= < t) - :high (numeric-bound-max (numeric-type-high type1) - (numeric-type-high type2) - >= > t))) - ((and (eq class1 'integer) - (eq class2 'rational) - (eq format1 format2) - (eq complexp1 complexp2) - (integerp (numeric-type-low type1)) - (integerp (numeric-type-high type1)) - (= (numeric-type-low type1) (numeric-type-high type1)) - (or (numeric-types-adjacent type1 type2) - (numeric-types-adjacent type2 type1))) - (make-numeric-type - :class 'rational - :format format1 - :complexp complexp1 - :low (numeric-bound-max (numeric-type-low type1) - (numeric-type-low type2) - <= < t) - :high (numeric-bound-max (numeric-type-high type1) - (numeric-type-high type2) - >= > t))) - (t nil)))))) + ((csubtypep type2 type1) type1) + (t + (let ((class1 (numeric-type-class type1)) + (format1 (numeric-type-format type1)) + (complexp1 (numeric-type-complexp type1)) + (class2 (numeric-type-class type2)) + (format2 (numeric-type-format type2)) + (complexp2 (numeric-type-complexp type2))) + (cond + ((and (eq class1 class2) + (eq format1 format2) + (eq complexp1 complexp2) + (or (numeric-types-intersect type1 type2) + (numeric-types-adjacent type1 type2) + (numeric-types-adjacent type2 type1))) + (make-numeric-type + :class class1 + :format format1 + :complexp complexp1 + :low (numeric-bound-max (numeric-type-low type1) + (numeric-type-low type2) + <= < t) + :high (numeric-bound-max (numeric-type-high type1) + (numeric-type-high type2) + >= > t))) + ;; FIXME: These two clauses are almost identical, and the + ;; consequents are in fact identical in every respect. + ((and (eq class1 'rational) + (eq class2 'integer) + (eq format1 format2) + (eq complexp1 complexp2) + (integerp (numeric-type-low type2)) + (integerp (numeric-type-high type2)) + (= (numeric-type-low type2) (numeric-type-high type2)) + (or (numeric-types-adjacent type1 type2) + (numeric-types-adjacent type2 type1))) + (make-numeric-type + :class 'rational + :format format1 + :complexp complexp1 + :low (numeric-bound-max (numeric-type-low type1) + (numeric-type-low type2) + <= < t) + :high (numeric-bound-max (numeric-type-high type1) + (numeric-type-high type2) + >= > t))) + ((and (eq class1 'integer) + (eq class2 'rational) + (eq format1 format2) + (eq complexp1 complexp2) + (integerp (numeric-type-low type1)) + (integerp (numeric-type-high type1)) + (= (numeric-type-low type1) (numeric-type-high type1)) + (or (numeric-types-adjacent type1 type2) + (numeric-types-adjacent type2 type1))) + (make-numeric-type + :class 'rational + :format format1 + :complexp complexp1 + :low (numeric-bound-max (numeric-type-low type1) + (numeric-type-low type2) + <= < t) + :high (numeric-bound-max (numeric-type-high type1) + (numeric-type-high type2) + >= > t))) + (t nil)))))) (!cold-init-forms (setf (info :type :kind 'number) - #+sb-xc-host :defined #-sb-xc-host :primitive) + #+sb-xc-host :defined #-sb-xc-host :primitive) (setf (info :type :builtin 'number) - (make-numeric-type :complexp nil))) + (make-numeric-type :complexp nil))) (!def-type-translator complex (&optional (typespec '*)) (if (eq typespec '*) (specifier-type '(complex real)) (labels ((not-numeric () - (error "The component type for COMPLEX is not numeric: ~S" - typespec)) - (not-real () - (error "The component type for COMPLEX is not a subtype of REAL: ~S" - typespec)) - (complex1 (component-type) - (unless (numeric-type-p component-type) - (not-numeric)) - (when (eq (numeric-type-complexp component-type) :complex) - (not-real)) - (if (csubtypep component-type (specifier-type '(eql 0))) - *empty-type* - (modified-numeric-type component-type - :complexp :complex)))) - (let ((ctype (specifier-type typespec))) - (cond - ((eq ctype *empty-type*) *empty-type*) - ((eq ctype *universal-type*) (not-real)) - ((typep ctype 'numeric-type) (complex1 ctype)) - ((typep ctype 'union-type) - (apply #'type-union - ;; FIXME: This code could suffer from (admittedly - ;; very obscure) cases of bug 145 e.g. when TYPE - ;; is - ;; (OR (AND INTEGER (SATISFIES ODDP)) - ;; (AND FLOAT (SATISFIES FOO)) - ;; and not even report the problem very well. - (mapcar #'complex1 (union-type-types ctype)))) - ((typep ctype 'member-type) - (apply #'type-union - (mapcar (lambda (x) (complex1 (ctype-of x))) - (member-type-members ctype)))) + (error "The component type for COMPLEX is not numeric: ~S" + typespec)) + (not-real () + (error "The component type for COMPLEX is not a subtype of REAL: ~S" + typespec)) + (complex1 (component-type) + (unless (numeric-type-p component-type) + (not-numeric)) + (when (eq (numeric-type-complexp component-type) :complex) + (not-real)) + (if (csubtypep component-type (specifier-type '(eql 0))) + *empty-type* + (modified-numeric-type component-type + :complexp :complex)))) + (let ((ctype (specifier-type typespec))) + (cond + ((eq ctype *empty-type*) *empty-type*) + ((eq ctype *universal-type*) (not-real)) + ((typep ctype 'numeric-type) (complex1 ctype)) + ((typep ctype 'union-type) + (apply #'type-union + ;; FIXME: This code could suffer from (admittedly + ;; very obscure) cases of bug 145 e.g. when TYPE + ;; is + ;; (OR (AND INTEGER (SATISFIES ODDP)) + ;; (AND FLOAT (SATISFIES FOO)) + ;; and not even report the problem very well. + (mapcar #'complex1 (union-type-types ctype)))) + ((typep ctype 'member-type) + (apply #'type-union + (mapcar (lambda (x) (complex1 (ctype-of x))) + (member-type-members ctype)))) ((and (typep ctype 'intersection-type) ;; FIXME: This is very much a ;; not-quite-worst-effort, but we are required to do @@ -1751,62 +1751,62 @@ (null (cdr numbers)) (eq (numeric-type-complexp (car numbers)) :real) (complex1 (car numbers)))))) - (t - (multiple-value-bind (subtypep certainly) - (csubtypep ctype (specifier-type 'real)) - (if (and (not subtypep) certainly) - (not-real) - ;; ANSI just says that TYPESPEC is any subtype of - ;; type REAL, not necessarily a NUMERIC-TYPE. In - ;; particular, at this point TYPESPEC could legally - ;; be a hairy type like (AND NUMBER (SATISFIES - ;; REALP) (SATISFIES ZEROP)), in which case we fall - ;; through the logic above and end up here, - ;; stumped. - (bug "~@<(known bug #145): The type ~S is too hairy to be ~ + (t + (multiple-value-bind (subtypep certainly) + (csubtypep ctype (specifier-type 'real)) + (if (and (not subtypep) certainly) + (not-real) + ;; ANSI just says that TYPESPEC is any subtype of + ;; type REAL, not necessarily a NUMERIC-TYPE. In + ;; particular, at this point TYPESPEC could legally + ;; be a hairy type like (AND NUMBER (SATISFIES + ;; REALP) (SATISFIES ZEROP)), in which case we fall + ;; through the logic above and end up here, + ;; stumped. + (bug "~@<(known bug #145): The type ~S is too hairy to be ~ used for a COMPLEX component.~:@>" - typespec))))))))) + typespec))))))))) ;;; If X is *, return NIL, otherwise return the bound, which must be a ;;; member of TYPE or a one-element list of a member of TYPE. #!-sb-fluid (declaim (inline canonicalized-bound)) (defun canonicalized-bound (bound type) (cond ((eq bound '*) nil) - ((or (sb!xc:typep bound type) - (and (consp bound) - (sb!xc:typep (car bound) type) - (null (cdr bound)))) - bound) - (t - (error "Bound is not ~S, a ~S or a list of a ~S: ~S" - '* - type - type - bound)))) + ((or (sb!xc:typep bound type) + (and (consp bound) + (sb!xc:typep (car bound) type) + (null (cdr bound)))) + bound) + (t + (error "Bound is not ~S, a ~S or a list of a ~S: ~S" + '* + type + type + bound)))) (!def-type-translator integer (&optional (low '*) (high '*)) (let* ((l (canonicalized-bound low 'integer)) - (lb (if (consp l) (1+ (car l)) l)) - (h (canonicalized-bound high 'integer)) - (hb (if (consp h) (1- (car h)) h))) + (lb (if (consp l) (1+ (car l)) l)) + (h (canonicalized-bound high 'integer)) + (hb (if (consp h) (1- (car h)) h))) (if (and hb lb (< hb lb)) - *empty-type* + *empty-type* (make-numeric-type :class 'integer - :complexp :real - :enumerable (not (null (and l h))) - :low lb - :high hb)))) + :complexp :real + :enumerable (not (null (and l h))) + :low lb + :high hb)))) (defmacro !def-bounded-type (type class format) `(!def-type-translator ,type (&optional (low '*) (high '*)) (let ((lb (canonicalized-bound low ',type)) - (hb (canonicalized-bound high ',type))) + (hb (canonicalized-bound high ',type))) (if (not (numeric-bound-test* lb hb <= <)) - *empty-type* - (make-numeric-type :class ',class - :format ',format - :low lb - :high hb))))) + *empty-type* + (make-numeric-type :class ',class + :format ',format + :low lb + :high hb))))) (!def-bounded-type rational rational nil) @@ -1913,16 +1913,16 @@ (coerce-bound bound type upperp #'inner-coerce-float-bound)) (!def-type-translator real (&optional (low '*) (high '*)) (specifier-type `(or (float ,(coerced-real-bound low 'float nil) - ,(coerced-real-bound high 'float t)) - (rational ,(coerced-real-bound low 'rational nil) - ,(coerced-real-bound high 'rational t))))) + ,(coerced-real-bound high 'float t)) + (rational ,(coerced-real-bound low 'rational nil) + ,(coerced-real-bound high 'rational t))))) (!def-type-translator float (&optional (low '*) (high '*)) - (specifier-type + (specifier-type `(or (single-float ,(coerced-float-bound low 'single-float nil) - ,(coerced-float-bound high 'single-float t)) - (double-float ,(coerced-float-bound low 'double-float nil) - ,(coerced-float-bound high 'double-float t)) - #!+long-float ,(error "stub: no long float support yet")))) + ,(coerced-float-bound high 'single-float t)) + (double-float ,(coerced-float-bound low 'double-float nil) + ,(coerced-float-bound high 'double-float t)) + #!+long-float ,(error "stub: no long float support yet")))) (defmacro !define-float-format (f) `(!def-bounded-type ,f float ,f)) @@ -1935,43 +1935,43 @@ (defun numeric-types-intersect (type1 type2) (declare (type numeric-type type1 type2)) (let* ((class1 (numeric-type-class type1)) - (class2 (numeric-type-class type2)) - (complexp1 (numeric-type-complexp type1)) - (complexp2 (numeric-type-complexp type2)) - (format1 (numeric-type-format type1)) - (format2 (numeric-type-format type2)) - (low1 (numeric-type-low type1)) - (high1 (numeric-type-high type1)) - (low2 (numeric-type-low type2)) - (high2 (numeric-type-high type2))) + (class2 (numeric-type-class type2)) + (complexp1 (numeric-type-complexp type1)) + (complexp2 (numeric-type-complexp type2)) + (format1 (numeric-type-format type1)) + (format2 (numeric-type-format type2)) + (low1 (numeric-type-low type1)) + (high1 (numeric-type-high type1)) + (low2 (numeric-type-low type2)) + (high2 (numeric-type-high type2))) ;; If one is complex and the other isn't, then they are disjoint. (cond ((not (or (eq complexp1 complexp2) - (null complexp1) (null complexp2))) - nil) - ;; If either type is a float, then the other must either be - ;; specified to be a float or unspecified. Otherwise, they - ;; are disjoint. - ((and (eq class1 'float) - (not (member class2 '(float nil)))) nil) - ((and (eq class2 'float) - (not (member class1 '(float nil)))) nil) - ;; If the float formats are specified and different, the - ;; types are disjoint. - ((not (or (eq format1 format2) (null format1) (null format2))) - nil) - (t - ;; Check the bounds. This is a bit odd because we must - ;; always have the outer bound of the interval as the - ;; second arg. - (if (numeric-bound-test high1 high2 <= <) - (or (and (numeric-bound-test low1 low2 >= >) - (numeric-bound-test* low1 high2 <= <)) - (and (numeric-bound-test low2 low1 >= >) - (numeric-bound-test* low2 high1 <= <))) - (or (and (numeric-bound-test* low2 high1 <= <) - (numeric-bound-test low2 low1 >= >)) - (and (numeric-bound-test high2 high1 <= <) - (numeric-bound-test* high2 low1 >= >)))))))) + (null complexp1) (null complexp2))) + nil) + ;; If either type is a float, then the other must either be + ;; specified to be a float or unspecified. Otherwise, they + ;; are disjoint. + ((and (eq class1 'float) + (not (member class2 '(float nil)))) nil) + ((and (eq class2 'float) + (not (member class1 '(float nil)))) nil) + ;; If the float formats are specified and different, the + ;; types are disjoint. + ((not (or (eq format1 format2) (null format1) (null format2))) + nil) + (t + ;; Check the bounds. This is a bit odd because we must + ;; always have the outer bound of the interval as the + ;; second arg. + (if (numeric-bound-test high1 high2 <= <) + (or (and (numeric-bound-test low1 low2 >= >) + (numeric-bound-test* low1 high2 <= <)) + (and (numeric-bound-test low2 low1 >= >) + (numeric-bound-test* low2 high1 <= <))) + (or (and (numeric-bound-test* low2 high1 <= <) + (numeric-bound-test low2 low1 >= >)) + (and (numeric-bound-test high2 high1 <= <) + (numeric-bound-test* high2 low1 >= >)))))))) ;;; Take the numeric bound X and convert it into something that can be ;;; used as a bound in a numeric type with the specified CLASS and @@ -1996,15 +1996,15 @@ (defun round-numeric-bound (x class format up-p) (if x (let ((cx (if (consp x) (car x) x))) - (ecase class - ((nil rational) x) - (integer - (if (and (consp x) (integerp cx)) - (if up-p (1+ cx) (1- cx)) - (if up-p (ceiling cx) (floor cx)))) - (float - (let ((res (if format (coerce cx format) (float cx)))) - (if (consp x) (list res) res))))) + (ecase class + ((nil rational) x) + (integer + (if (and (consp x) (integerp cx)) + (if up-p (1+ cx) (1- cx)) + (if up-p (ceiling cx) (floor cx)))) + (float + (let ((res (if format (coerce cx format) (float cx)))) + (if (consp x) (list res) res))))) nil)) ;;; Handle the case of type intersection on two numeric types. We use @@ -2027,32 +2027,32 @@ (declare (type numeric-type type1 type2)) (if (numeric-types-intersect type1 type2) (let* ((class1 (numeric-type-class type1)) - (class2 (numeric-type-class type2)) - (class (ecase class1 - ((nil) class2) - ((integer float) class1) - (rational (if (eq class2 'integer) - 'integer - 'rational)))) - (format (or (numeric-type-format type1) - (numeric-type-format type2)))) - (make-numeric-type - :class class - :format format - :complexp (or (numeric-type-complexp type1) - (numeric-type-complexp type2)) - :low (numeric-bound-max - (round-numeric-bound (numeric-type-low type1) - class format t) - (round-numeric-bound (numeric-type-low type2) - class format t) - > >= nil) - :high (numeric-bound-max - (round-numeric-bound (numeric-type-high type1) - class format nil) - (round-numeric-bound (numeric-type-high type2) - class format nil) - < <= nil))) + (class2 (numeric-type-class type2)) + (class (ecase class1 + ((nil) class2) + ((integer float) class1) + (rational (if (eq class2 'integer) + 'integer + 'rational)))) + (format (or (numeric-type-format type1) + (numeric-type-format type2)))) + (make-numeric-type + :class class + :format format + :complexp (or (numeric-type-complexp type1) + (numeric-type-complexp type2)) + :low (numeric-bound-max + (round-numeric-bound (numeric-type-low type1) + class format t) + (round-numeric-bound (numeric-type-low type2) + class format t) + > >= nil) + :high (numeric-bound-max + (round-numeric-bound (numeric-type-high type1) + class format nil) + (round-numeric-bound (numeric-type-high type2) + class format nil) + < <= nil))) *empty-type*)) ;;; Given two float formats, return the one with more precision. If @@ -2061,7 +2061,7 @@ (when (and f1 f2) (dolist (f *float-formats* (error "bad float format: ~S" f1)) (when (or (eq f f1) (eq f f2)) - (return f))))) + (return f))))) ;;; Return the result of an operation on TYPE1 and TYPE2 according to ;;; the rules of numeric contagion. This is always NUMBER, some float @@ -2075,44 +2075,44 @@ (defun numeric-contagion (type1 type2) (if (and (numeric-type-p type1) (numeric-type-p type2)) (let ((class1 (numeric-type-class type1)) - (class2 (numeric-type-class type2)) - (format1 (numeric-type-format type1)) - (format2 (numeric-type-format type2)) - (complexp1 (numeric-type-complexp type1)) - (complexp2 (numeric-type-complexp type2))) - (cond ((or (null complexp1) - (null complexp2)) - (specifier-type 'number)) - ((eq class1 'float) - (make-numeric-type - :class 'float - :format (ecase class2 - (float (float-format-max format1 format2)) - ((integer rational) format1) - ((nil) - ;; A double-float with any real number is a - ;; double-float. - #!-long-float - (if (eq format1 'double-float) - 'double-float - nil) - ;; A long-float with any real number is a - ;; long-float. - #!+long-float - (if (eq format1 'long-float) - 'long-float - nil))) - :complexp (if (or (eq complexp1 :complex) - (eq complexp2 :complex)) - :complex - :real))) - ((eq class2 'float) (numeric-contagion type2 type1)) - ((and (eq complexp1 :real) (eq complexp2 :real)) - (make-numeric-type - :class (and class1 class2 'rational) - :complexp :real)) - (t - (specifier-type 'number)))) + (class2 (numeric-type-class type2)) + (format1 (numeric-type-format type1)) + (format2 (numeric-type-format type2)) + (complexp1 (numeric-type-complexp type1)) + (complexp2 (numeric-type-complexp type2))) + (cond ((or (null complexp1) + (null complexp2)) + (specifier-type 'number)) + ((eq class1 'float) + (make-numeric-type + :class 'float + :format (ecase class2 + (float (float-format-max format1 format2)) + ((integer rational) format1) + ((nil) + ;; A double-float with any real number is a + ;; double-float. + #!-long-float + (if (eq format1 'double-float) + 'double-float + nil) + ;; A long-float with any real number is a + ;; long-float. + #!+long-float + (if (eq format1 'long-float) + 'long-float + nil))) + :complexp (if (or (eq complexp1 :complex) + (eq complexp2 :complex)) + :complex + :real))) + ((eq class2 'float) (numeric-contagion type2 type1)) + ((and (eq complexp1 :real) (eq complexp2 :real)) + (make-numeric-type + :class (and class1 class2 'rational) + :complexp :real)) + (t + (specifier-type 'number)))) (specifier-type 'number))) ;;;; array types @@ -2130,22 +2130,22 @@ (!define-type-method (array :simple-=) (type1 type2) (if (or (unknown-type-p (array-type-element-type type1)) - (unknown-type-p (array-type-element-type type2))) + (unknown-type-p (array-type-element-type type2))) (multiple-value-bind (equalp certainp) - (type= (array-type-element-type type1) - (array-type-element-type type2)) - ;; By its nature, the call to TYPE= should never return NIL, - ;; T, as we don't know what the UNKNOWN-TYPE will grow up to - ;; be. -- CSR, 2002-08-19 - (aver (not (and (not equalp) certainp))) - (values equalp certainp)) + (type= (array-type-element-type type1) + (array-type-element-type type2)) + ;; By its nature, the call to TYPE= should never return NIL, + ;; T, as we don't know what the UNKNOWN-TYPE will grow up to + ;; be. -- CSR, 2002-08-19 + (aver (not (and (not equalp) certainp))) + (values equalp certainp)) (values (and (equal (array-type-dimensions type1) - (array-type-dimensions type2)) - (eq (array-type-complexp type1) - (array-type-complexp type2)) - (type= (specialized-element-type-maybe type1) - (specialized-element-type-maybe type2))) - t))) + (array-type-dimensions type2)) + (eq (array-type-complexp type1) + (array-type-complexp type2)) + (type= (specialized-element-type-maybe type1) + (specialized-element-type-maybe type2))) + t))) (!define-type-method (array :negate) (type) ;; FIXME (and hint to PFD): we're vulnerable here to attacks of the @@ -2155,81 +2155,81 @@ (!define-type-method (array :unparse) (type) (let ((dims (array-type-dimensions type)) - (eltype (type-specifier (array-type-element-type type))) - (complexp (array-type-complexp type))) + (eltype (type-specifier (array-type-element-type type))) + (complexp (array-type-complexp type))) (cond ((eq dims '*) - (if (eq eltype '*) - (if complexp 'array 'simple-array) - (if complexp `(array ,eltype) `(simple-array ,eltype)))) - ((= (length dims) 1) - (if complexp - (if (eq (car dims) '*) - (case eltype - (bit 'bit-vector) - ((base-char #!-sb-unicode character) 'base-string) - (* 'vector) - (t `(vector ,eltype))) - (case eltype - (bit `(bit-vector ,(car dims))) - ((base-char #!-sb-unicode character) + (if (eq eltype '*) + (if complexp 'array 'simple-array) + (if complexp `(array ,eltype) `(simple-array ,eltype)))) + ((= (length dims) 1) + (if complexp + (if (eq (car dims) '*) + (case eltype + (bit 'bit-vector) + ((base-char #!-sb-unicode character) 'base-string) + (* 'vector) + (t `(vector ,eltype))) + (case eltype + (bit `(bit-vector ,(car dims))) + ((base-char #!-sb-unicode character) `(base-string ,(car dims))) - (t `(vector ,eltype ,(car dims))))) - (if (eq (car dims) '*) - (case eltype - (bit 'simple-bit-vector) - ((base-char #!-sb-unicode character) 'simple-base-string) - ((t) 'simple-vector) - (t `(simple-array ,eltype (*)))) - (case eltype - (bit `(simple-bit-vector ,(car dims))) - ((base-char #!-sb-unicode character) + (t `(vector ,eltype ,(car dims))))) + (if (eq (car dims) '*) + (case eltype + (bit 'simple-bit-vector) + ((base-char #!-sb-unicode character) 'simple-base-string) + ((t) 'simple-vector) + (t `(simple-array ,eltype (*)))) + (case eltype + (bit `(simple-bit-vector ,(car dims))) + ((base-char #!-sb-unicode character) `(simple-base-string ,(car dims))) - ((t) `(simple-vector ,(car dims))) - (t `(simple-array ,eltype ,dims)))))) - (t - (if complexp - `(array ,eltype ,dims) - `(simple-array ,eltype ,dims)))))) + ((t) `(simple-vector ,(car dims))) + (t `(simple-array ,eltype ,dims)))))) + (t + (if complexp + `(array ,eltype ,dims) + `(simple-array ,eltype ,dims)))))) (!define-type-method (array :simple-subtypep) (type1 type2) (let ((dims1 (array-type-dimensions type1)) - (dims2 (array-type-dimensions type2)) - (complexp2 (array-type-complexp type2))) + (dims2 (array-type-dimensions type2)) + (complexp2 (array-type-complexp type2))) (cond (;; not subtypep unless dimensions are compatible - (not (or (eq dims2 '*) - (and (not (eq dims1 '*)) - ;; (sbcl-0.6.4 has trouble figuring out that - ;; DIMS1 and DIMS2 must be lists at this - ;; point, and knowing that is important to - ;; compiling EVERY efficiently.) - (= (length (the list dims1)) - (length (the list dims2))) - (every (lambda (x y) - (or (eq y '*) (eql x y))) - (the list dims1) - (the list dims2))))) - (values nil t)) - ;; not subtypep unless complexness is compatible - ((not (or (eq complexp2 :maybe) - (eq (array-type-complexp type1) complexp2))) - (values nil t)) - ;; Since we didn't fail any of the tests above, we win - ;; if the TYPE2 element type is wild. - ((eq (array-type-element-type type2) *wild-type*) - (values t t)) - (;; Since we didn't match any of the special cases above, we - ;; can't give a good answer unless both the element types - ;; have been defined. - (or (unknown-type-p (array-type-element-type type1)) - (unknown-type-p (array-type-element-type type2))) - (values nil nil)) - (;; Otherwise, the subtype relationship holds iff the - ;; types are equal, and they're equal iff the specialized - ;; element types are identical. - t - (values (type= (specialized-element-type-maybe type1) - (specialized-element-type-maybe type2)) - t))))) + (not (or (eq dims2 '*) + (and (not (eq dims1 '*)) + ;; (sbcl-0.6.4 has trouble figuring out that + ;; DIMS1 and DIMS2 must be lists at this + ;; point, and knowing that is important to + ;; compiling EVERY efficiently.) + (= (length (the list dims1)) + (length (the list dims2))) + (every (lambda (x y) + (or (eq y '*) (eql x y))) + (the list dims1) + (the list dims2))))) + (values nil t)) + ;; not subtypep unless complexness is compatible + ((not (or (eq complexp2 :maybe) + (eq (array-type-complexp type1) complexp2))) + (values nil t)) + ;; Since we didn't fail any of the tests above, we win + ;; if the TYPE2 element type is wild. + ((eq (array-type-element-type type2) *wild-type*) + (values t t)) + (;; Since we didn't match any of the special cases above, we + ;; can't give a good answer unless both the element types + ;; have been defined. + (or (unknown-type-p (array-type-element-type type1)) + (unknown-type-p (array-type-element-type type2))) + (values nil nil)) + (;; Otherwise, the subtype relationship holds iff the + ;; types are equal, and they're equal iff the specialized + ;; element types are identical. + t + (values (type= (specialized-element-type-maybe type1) + (specialized-element-type-maybe type2)) + t))))) ;;; FIXME: is this dead? (!define-superclasses array @@ -2241,71 +2241,71 @@ (defun array-types-intersect (type1 type2) (declare (type array-type type1 type2)) (let ((dims1 (array-type-dimensions type1)) - (dims2 (array-type-dimensions type2)) - (complexp1 (array-type-complexp type1)) - (complexp2 (array-type-complexp type2))) + (dims2 (array-type-dimensions type2)) + (complexp1 (array-type-complexp type1)) + (complexp2 (array-type-complexp type2))) ;; See whether dimensions are compatible. (cond ((not (or (eq dims1 '*) (eq dims2 '*) - (and (= (length dims1) (length dims2)) - (every (lambda (x y) - (or (eq x '*) (eq y '*) (= x y))) - dims1 dims2)))) - (values nil t)) - ;; See whether complexpness is compatible. - ((not (or (eq complexp1 :maybe) - (eq complexp2 :maybe) - (eq complexp1 complexp2))) - (values nil t)) - ;; Old comment: - ;; - ;; If either element type is wild, then they intersect. - ;; Otherwise, the types must be identical. - ;; - ;; FIXME: There seems to have been a fair amount of - ;; confusion about the distinction between requested element - ;; type and specialized element type; here is one of - ;; them. If we request an array to hold objects of an - ;; unknown type, we can do no better than represent that - ;; type as an array specialized on wild-type. We keep the - ;; requested element-type in the -ELEMENT-TYPE slot, and - ;; *WILD-TYPE* in the -SPECIALIZED-ELEMENT-TYPE. So, here, - ;; we must test for the SPECIALIZED slot being *WILD-TYPE*, - ;; not just the ELEMENT-TYPE slot. Maybe the return value - ;; in that specific case should be T, NIL? Or maybe this - ;; function should really be called - ;; ARRAY-TYPES-COULD-POSSIBLY-INTERSECT? In any case, this - ;; was responsible for bug #123, and this whole issue could - ;; do with a rethink and/or a rewrite. -- CSR, 2002-08-21 - ((or (eq (array-type-specialized-element-type type1) *wild-type*) - (eq (array-type-specialized-element-type type2) *wild-type*) - (type= (specialized-element-type-maybe type1) - (specialized-element-type-maybe type2))) - - (values t t)) - (t - (values nil t))))) + (and (= (length dims1) (length dims2)) + (every (lambda (x y) + (or (eq x '*) (eq y '*) (= x y))) + dims1 dims2)))) + (values nil t)) + ;; See whether complexpness is compatible. + ((not (or (eq complexp1 :maybe) + (eq complexp2 :maybe) + (eq complexp1 complexp2))) + (values nil t)) + ;; Old comment: + ;; + ;; If either element type is wild, then they intersect. + ;; Otherwise, the types must be identical. + ;; + ;; FIXME: There seems to have been a fair amount of + ;; confusion about the distinction between requested element + ;; type and specialized element type; here is one of + ;; them. If we request an array to hold objects of an + ;; unknown type, we can do no better than represent that + ;; type as an array specialized on wild-type. We keep the + ;; requested element-type in the -ELEMENT-TYPE slot, and + ;; *WILD-TYPE* in the -SPECIALIZED-ELEMENT-TYPE. So, here, + ;; we must test for the SPECIALIZED slot being *WILD-TYPE*, + ;; not just the ELEMENT-TYPE slot. Maybe the return value + ;; in that specific case should be T, NIL? Or maybe this + ;; function should really be called + ;; ARRAY-TYPES-COULD-POSSIBLY-INTERSECT? In any case, this + ;; was responsible for bug #123, and this whole issue could + ;; do with a rethink and/or a rewrite. -- CSR, 2002-08-21 + ((or (eq (array-type-specialized-element-type type1) *wild-type*) + (eq (array-type-specialized-element-type type2) *wild-type*) + (type= (specialized-element-type-maybe type1) + (specialized-element-type-maybe type2))) + + (values t t)) + (t + (values nil t))))) (!define-type-method (array :simple-intersection2) (type1 type2) (declare (type array-type type1 type2)) (if (array-types-intersect type1 type2) (let ((dims1 (array-type-dimensions type1)) - (dims2 (array-type-dimensions type2)) - (complexp1 (array-type-complexp type1)) - (complexp2 (array-type-complexp type2)) - (eltype1 (array-type-element-type type1)) - (eltype2 (array-type-element-type type2))) - (specialize-array-type - (make-array-type - :dimensions (cond ((eq dims1 '*) dims2) - ((eq dims2 '*) dims1) - (t - (mapcar (lambda (x y) (if (eq x '*) y x)) - dims1 dims2))) - :complexp (if (eq complexp1 :maybe) complexp2 complexp1) - :element-type (cond - ((eq eltype1 *wild-type*) eltype2) - ((eq eltype2 *wild-type*) eltype1) - (t (type-intersection eltype1 eltype2)))))) + (dims2 (array-type-dimensions type2)) + (complexp1 (array-type-complexp type1)) + (complexp2 (array-type-complexp type2)) + (eltype1 (array-type-element-type type1)) + (eltype2 (array-type-element-type type2))) + (specialize-array-type + (make-array-type + :dimensions (cond ((eq dims1 '*) dims2) + ((eq dims2 '*) dims1) + (t + (mapcar (lambda (x y) (if (eq x '*) y x)) + dims1 dims2))) + :complexp (if (eq complexp1 :maybe) complexp2 complexp1) + :element-type (cond + ((eq eltype1 *wild-type*) eltype2) + ((eq eltype2 *wild-type*) eltype1) + (t (type-intersection eltype1 eltype2)))))) *empty-type*)) ;;; Check a supplied dimension list to determine whether it is legal, @@ -2324,10 +2324,10 @@ (error "array type with too many dimensions: ~S" dims)) (dolist (dim dims) (unless (eq dim '*) - (unless (and (integerp dim) - (>= dim 0) - (< dim sb!xc:array-dimension-limit)) - (error "bad dimension in array type: ~S" dim)))) + (unless (and (integerp dim) + (>= dim 0) + (< dim sb!xc:array-dimension-limit)) + (error "bad dimension in array type: ~S" dim)))) dims) (t (error "Array dimensions is not a list, integer or *:~% ~S" dims)))) @@ -2339,38 +2339,38 @@ (!define-type-method (member :negate) (type) (let ((members (member-type-members type))) (if (some #'floatp members) - (let (floats) - (dolist (pair `((0.0f0 . ,(load-time-value (make-unportable-float :single-float-negative-zero))) - (0.0d0 . ,(load-time-value (make-unportable-float :double-float-negative-zero))) - #!+long-float - (0.0l0 . ,(load-time-value (make-unportable-float :long-float-negative-zero))))) - (when (member (car pair) members) - (aver (not (member (cdr pair) members))) - (push (cdr pair) floats) - (setf members (remove (car pair) members))) - (when (member (cdr pair) members) - (aver (not (member (car pair) members))) - (push (car pair) floats) - (setf members (remove (cdr pair) members)))) - (apply #'type-intersection - (if (null members) - *universal-type* - (make-negation-type - :type (make-member-type :members members))) - (mapcar - (lambda (x) - (let ((type (ctype-of x))) - (type-union - (make-negation-type - :type (modified-numeric-type type - :low nil :high nil)) - (modified-numeric-type type - :low nil :high (list x)) - (make-member-type :members (list x)) - (modified-numeric-type type - :low (list x) :high nil)))) - floats))) - (make-negation-type :type type)))) + (let (floats) + (dolist (pair `((0.0f0 . ,(load-time-value (make-unportable-float :single-float-negative-zero))) + (0.0d0 . ,(load-time-value (make-unportable-float :double-float-negative-zero))) + #!+long-float + (0.0l0 . ,(load-time-value (make-unportable-float :long-float-negative-zero))))) + (when (member (car pair) members) + (aver (not (member (cdr pair) members))) + (push (cdr pair) floats) + (setf members (remove (car pair) members))) + (when (member (cdr pair) members) + (aver (not (member (car pair) members))) + (push (car pair) floats) + (setf members (remove (cdr pair) members)))) + (apply #'type-intersection + (if (null members) + *universal-type* + (make-negation-type + :type (make-member-type :members members))) + (mapcar + (lambda (x) + (let ((type (ctype-of x))) + (type-union + (make-negation-type + :type (modified-numeric-type type + :low nil :high nil)) + (modified-numeric-type type + :low nil :high (list x)) + (make-member-type :members (list x)) + (modified-numeric-type type + :low (list x) :high nil)))) + floats))) + (make-negation-type :type type)))) (!define-type-method (member :unparse) (type) (let ((members (member-type-members type))) @@ -2381,94 +2381,94 @@ (!define-type-method (member :simple-subtypep) (type1 type2) (values (subsetp (member-type-members type1) (member-type-members type2)) - t)) + t)) (!define-type-method (member :complex-subtypep-arg1) (type1 type2) (every/type (swapped-args-fun #'ctypep) - type2 - (member-type-members type1))) + type2 + (member-type-members type1))) ;;; We punt if the odd type is enumerable and intersects with the ;;; MEMBER type. If not enumerable, then it is definitely not a ;;; subtype of the MEMBER type. (!define-type-method (member :complex-subtypep-arg2) (type1 type2) (cond ((not (type-enumerable type1)) (values nil t)) - ((types-equal-or-intersect type1 type2) - (invoke-complex-subtypep-arg1-method type1 type2)) - (t (values nil t)))) + ((types-equal-or-intersect type1 type2) + (invoke-complex-subtypep-arg1-method type1 type2)) + (t (values nil t)))) (!define-type-method (member :simple-intersection2) (type1 type2) (let ((mem1 (member-type-members type1)) - (mem2 (member-type-members type2))) + (mem2 (member-type-members type2))) (cond ((subsetp mem1 mem2) type1) - ((subsetp mem2 mem1) type2) - (t - (let ((res (intersection mem1 mem2))) - (if res - (make-member-type :members res) - *empty-type*)))))) + ((subsetp mem2 mem1) type2) + (t + (let ((res (intersection mem1 mem2))) + (if res + (make-member-type :members res) + *empty-type*)))))) (!define-type-method (member :complex-intersection2) (type1 type2) (block punt (collect ((members)) (let ((mem2 (member-type-members type2))) (dolist (member mem2) - (multiple-value-bind (val win) (ctypep member type1) - (unless win - (return-from punt nil)) - (when val (members member)))) - (cond ((subsetp mem2 (members)) type2) - ((null (members)) *empty-type*) - (t - (make-member-type :members (members)))))))) + (multiple-value-bind (val win) (ctypep member type1) + (unless win + (return-from punt nil)) + (when val (members member)))) + (cond ((subsetp mem2 (members)) type2) + ((null (members)) *empty-type*) + (t + (make-member-type :members (members)))))))) ;;; We don't need a :COMPLEX-UNION2, since the only interesting case is ;;; a union type, and the member/union interaction is handled by the ;;; union type method. (!define-type-method (member :simple-union2) (type1 type2) (let ((mem1 (member-type-members type1)) - (mem2 (member-type-members type2))) + (mem2 (member-type-members type2))) (cond ((subsetp mem1 mem2) type2) - ((subsetp mem2 mem1) type1) - (t - (make-member-type :members (union mem1 mem2)))))) + ((subsetp mem2 mem1) type1) + (t + (make-member-type :members (union mem1 mem2)))))) (!define-type-method (member :simple-=) (type1 type2) (let ((mem1 (member-type-members type1)) - (mem2 (member-type-members type2))) + (mem2 (member-type-members type2))) (values (and (subsetp mem1 mem2) - (subsetp mem2 mem1)) - t))) + (subsetp mem2 mem1)) + t))) (!define-type-method (member :complex-=) (type1 type2) (if (type-enumerable type1) (multiple-value-bind (val win) (csubtypep type2 type1) - (if (or val (not win)) - (values nil nil) - (values nil t))) + (if (or val (not win)) + (values nil nil) + (values nil t))) (values nil t))) (!def-type-translator member (&rest members) (if members (let (ms numbers char-codes) - (dolist (m (remove-duplicates members)) - (typecase m - (float (if (zerop m) - (push m ms) - (push (ctype-of m) numbers))) - (real (push (ctype-of m) numbers)) + (dolist (m (remove-duplicates members)) + (typecase m + (float (if (zerop m) + (push m ms) + (push (ctype-of m) numbers))) + (real (push (ctype-of m) numbers)) (character (push (sb!xc:char-code m) char-codes)) - (t (push m ms)))) - (apply #'type-union - (if ms - (make-member-type :members ms) - *empty-type*) + (t (push m ms)))) + (apply #'type-union + (if ms + (make-member-type :members ms) + *empty-type*) (if char-codes (make-character-set-type :pairs (mapcar (lambda (x) (cons x x)) (sort char-codes #'<))) *empty-type*) - (nreverse numbers))) + (nreverse numbers))) *empty-type*)) ;;;; intersection types @@ -2494,7 +2494,7 @@ (!define-type-method (intersection :negate) (type) (apply #'type-union - (mapcar #'type-negation (intersection-type-types type)))) + (mapcar #'type-negation (intersection-type-types type)))) ;;; A few intersection types have special names. The others just get ;;; mechanically unparsed. @@ -2507,8 +2507,8 @@ ;;; TYPES1 matches a type in the set TYPES2 and vice versa (defun type=-set (types1 types2) (flet ((type<=-set (x y) - (declare (type list x y)) - (every/type (lambda (x y-element) + (declare (type list x y)) + (every/type (lambda (x y-element) (any/type #'type= y-element x)) x y))) (and/type (type<=-set types1 types2) @@ -2523,19 +2523,19 @@ ;;; in this more obscure method? (!define-type-method (intersection :simple-=) (type1 type2) (type=-set (intersection-type-types type1) - (intersection-type-types type2))) + (intersection-type-types type2))) (defun %intersection-complex-subtypep-arg1 (type1 type2) (type= type1 (type-intersection type1 type2))) (defun %intersection-simple-subtypep (type1 type2) (every/type #'%intersection-complex-subtypep-arg1 - type1 - (intersection-type-types type2))) + type1 + (intersection-type-types type2))) (!define-type-method (intersection :simple-subtypep) (type1 type2) (%intersection-simple-subtypep type1 type2)) - + (!define-type-method (intersection :complex-subtypep-arg1) (type1 type2) (%intersection-complex-subtypep-arg1 type1 type2)) @@ -2553,70 +2553,70 @@ ;;; reflect those symmetries in code in a way that ties them together ;;; more strongly than having two independent near-copies :-/ (!define-type-method (intersection :simple-union2 :complex-union2) - (type1 type2) + (type1 type2) ;; Within this method, type2 is guaranteed to be an intersection ;; type: (aver (intersection-type-p type2)) ;; Make sure to call only the applicable methods... (cond ((and (intersection-type-p type1) - (%intersection-simple-subtypep type1 type2)) type2) - ((and (intersection-type-p type1) - (%intersection-simple-subtypep type2 type1)) type1) - ((and (not (intersection-type-p type1)) - (%intersection-complex-subtypep-arg2 type1 type2)) - type2) - ((and (not (intersection-type-p type1)) - (%intersection-complex-subtypep-arg1 type2 type1)) - type1) - ;; KLUDGE: This special (and somewhat hairy) magic is required - ;; to deal with the RATIONAL/INTEGER special case. The UNION - ;; of (INTEGER * -1) and (AND (RATIONAL * -1/2) (NOT INTEGER)) - ;; should be (RATIONAL * -1/2) -- CSR, 2003-02-28 - ((and (csubtypep type2 (specifier-type 'ratio)) - (numeric-type-p type1) - (csubtypep type1 (specifier-type 'integer)) - (csubtypep type2 - (make-numeric-type - :class 'rational - :complexp nil - :low (if (null (numeric-type-low type1)) - nil - (list (1- (numeric-type-low type1)))) - :high (if (null (numeric-type-high type1)) - nil - (list (1+ (numeric-type-high type1))))))) - (type-union type1 - (apply #'type-intersection - (remove (specifier-type '(not integer)) - (intersection-type-types type2) - :test #'type=)))) - (t - (let ((accumulator *universal-type*)) - (do ((t2s (intersection-type-types type2) (cdr t2s))) - ((null t2s) accumulator) - (let ((union (type-union type1 (car t2s)))) - (when (union-type-p union) - ;; we have to give up here -- there are all sorts of - ;; ordering worries, but it's better than before. - ;; Doing exactly the same as in the UNION - ;; :SIMPLE/:COMPLEX-INTERSECTION2 method causes stack - ;; overflow with the mutual recursion never bottoming - ;; out. - (if (and (eq accumulator *universal-type*) - (null (cdr t2s))) - ;; KLUDGE: if we get here, we have a partially - ;; simplified result. While this isn't by any - ;; means a universal simplification, including - ;; this logic here means that we can get (OR - ;; KEYWORD (NOT KEYWORD)) canonicalized to T. - (return union) - (return nil))) - (setf accumulator - (type-intersection accumulator union)))))))) + (%intersection-simple-subtypep type1 type2)) type2) + ((and (intersection-type-p type1) + (%intersection-simple-subtypep type2 type1)) type1) + ((and (not (intersection-type-p type1)) + (%intersection-complex-subtypep-arg2 type1 type2)) + type2) + ((and (not (intersection-type-p type1)) + (%intersection-complex-subtypep-arg1 type2 type1)) + type1) + ;; KLUDGE: This special (and somewhat hairy) magic is required + ;; to deal with the RATIONAL/INTEGER special case. The UNION + ;; of (INTEGER * -1) and (AND (RATIONAL * -1/2) (NOT INTEGER)) + ;; should be (RATIONAL * -1/2) -- CSR, 2003-02-28 + ((and (csubtypep type2 (specifier-type 'ratio)) + (numeric-type-p type1) + (csubtypep type1 (specifier-type 'integer)) + (csubtypep type2 + (make-numeric-type + :class 'rational + :complexp nil + :low (if (null (numeric-type-low type1)) + nil + (list (1- (numeric-type-low type1)))) + :high (if (null (numeric-type-high type1)) + nil + (list (1+ (numeric-type-high type1))))))) + (type-union type1 + (apply #'type-intersection + (remove (specifier-type '(not integer)) + (intersection-type-types type2) + :test #'type=)))) + (t + (let ((accumulator *universal-type*)) + (do ((t2s (intersection-type-types type2) (cdr t2s))) + ((null t2s) accumulator) + (let ((union (type-union type1 (car t2s)))) + (when (union-type-p union) + ;; we have to give up here -- there are all sorts of + ;; ordering worries, but it's better than before. + ;; Doing exactly the same as in the UNION + ;; :SIMPLE/:COMPLEX-INTERSECTION2 method causes stack + ;; overflow with the mutual recursion never bottoming + ;; out. + (if (and (eq accumulator *universal-type*) + (null (cdr t2s))) + ;; KLUDGE: if we get here, we have a partially + ;; simplified result. While this isn't by any + ;; means a universal simplification, including + ;; this logic here means that we can get (OR + ;; KEYWORD (NOT KEYWORD)) canonicalized to T. + (return union) + (return nil))) + (setf accumulator + (type-intersection accumulator union)))))))) (!def-type-translator and (&whole whole &rest type-specifiers) (apply #'type-intersection - (mapcar #'specifier-type type-specifiers))) + (mapcar #'specifier-type type-specifiers))) ;;;; union types @@ -2625,7 +2625,7 @@ (!define-type-method (union :negate) (type) (declare (type ctype type)) (apply #'type-intersection - (mapcar #'type-negation (union-type-types type)))) + (mapcar #'type-negation (union-type-types type)))) ;;; The LIST, FLOAT and REAL types have special names. Other union ;;; types just get mechanically unparsed. @@ -2657,19 +2657,19 @@ (multiple-value-bind (subtype certain?) (csubtypep type1 type2) (if subtype - (csubtypep type2 type1) - ;; we might as well become as certain as possible. - (if certain? - (values nil t) - (multiple-value-bind (subtype certain?) - (csubtypep type2 type1) - (declare (ignore subtype)) - (values nil certain?)))))) + (csubtypep type2 type1) + ;; we might as well become as certain as possible. + (if certain? + (values nil t) + (multiple-value-bind (subtype certain?) + (csubtypep type2 type1) + (declare (ignore subtype)) + (values nil certain?)))))) (!define-type-method (union :complex-=) (type1 type2) (declare (ignore type1)) - (if (some #'type-might-contain-other-types-p - (union-type-types type2)) + (if (some #'type-might-contain-other-types-p + (union-type-types type2)) (values nil nil) (values nil t))) @@ -2677,16 +2677,16 @@ ;;; every element of TYPE1 is a subtype of TYPE2. (defun union-simple-subtypep (type1 type2) (every/type (swapped-args-fun #'union-complex-subtypep-arg2) - type2 - (union-type-types type1))) + type2 + (union-type-types type1))) (!define-type-method (union :simple-subtypep) (type1 type2) (union-simple-subtypep type1 type2)) - + (defun union-complex-subtypep-arg1 (type1 type2) (every/type (swapped-args-fun #'csubtypep) - type2 - (union-type-types type1))) + type2 + (union-type-types type1))) (!define-type-method (union :complex-subtypep-arg1) (type1 type2) (union-complex-subtypep-arg1 type1 type2)) @@ -2700,45 +2700,45 @@ ;; dodgy. It depends on the union :complex-= method not doing ;; very much work -- certainly, not using subtypep. Reasoning: (progn - ;; At this stage, we know that type2 is a union type and type1 - ;; isn't. We might as well check this, though: - (aver (union-type-p type2)) - (aver (not (union-type-p type1))) - ;; A is a subset of (B1 u B2) - ;; <=> A n (B1 u B2) = A - ;; <=> (A n B1) u (A n B2) = A - ;; - ;; But, we have to be careful not to delegate this type= to - ;; something that could invoke subtypep, which might get us - ;; back here -> stack explosion. We therefore ensure that the - ;; second type (which is the one that's dispatched on) is - ;; either a union type (where we've ensured that the complex-= - ;; method will not call subtypep) or something with no union - ;; types involved, in which case we'll never come back here. - ;; - ;; If we don't do this, then e.g. - ;; (SUBTYPEP '(MEMBER 3) '(OR (SATISFIES FOO) (SATISFIES BAR))) - ;; would loop infinitely, as the member :complex-= method is - ;; implemented in terms of subtypep. - ;; - ;; Ouch. - CSR, 2002-04-10 - (type= type1 - (apply #'type-union - (mapcar (lambda (x) (type-intersection type1 x)) - (union-type-types type2))))) + ;; At this stage, we know that type2 is a union type and type1 + ;; isn't. We might as well check this, though: + (aver (union-type-p type2)) + (aver (not (union-type-p type1))) + ;; A is a subset of (B1 u B2) + ;; <=> A n (B1 u B2) = A + ;; <=> (A n B1) u (A n B2) = A + ;; + ;; But, we have to be careful not to delegate this type= to + ;; something that could invoke subtypep, which might get us + ;; back here -> stack explosion. We therefore ensure that the + ;; second type (which is the one that's dispatched on) is + ;; either a union type (where we've ensured that the complex-= + ;; method will not call subtypep) or something with no union + ;; types involved, in which case we'll never come back here. + ;; + ;; If we don't do this, then e.g. + ;; (SUBTYPEP '(MEMBER 3) '(OR (SATISFIES FOO) (SATISFIES BAR))) + ;; would loop infinitely, as the member :complex-= method is + ;; implemented in terms of subtypep. + ;; + ;; Ouch. - CSR, 2002-04-10 + (type= type1 + (apply #'type-union + (mapcar (lambda (x) (type-intersection type1 x)) + (union-type-types type2))))) (if sub-certain? - (values sub-value sub-certain?) - ;; The ANY/TYPE expression above is a sufficient condition for - ;; subsetness, but not a necessary one, so we might get a more - ;; certain answer by this CALL-NEXT-METHOD-ish step when the - ;; ANY/TYPE expression is uncertain. - (invoke-complex-subtypep-arg1-method type1 type2)))) + (values sub-value sub-certain?) + ;; The ANY/TYPE expression above is a sufficient condition for + ;; subsetness, but not a necessary one, so we might get a more + ;; certain answer by this CALL-NEXT-METHOD-ish step when the + ;; ANY/TYPE expression is uncertain. + (invoke-complex-subtypep-arg1-method type1 type2)))) (!define-type-method (union :complex-subtypep-arg2) (type1 type2) (union-complex-subtypep-arg2 type1 type2)) (!define-type-method (union :simple-intersection2 :complex-intersection2) - (type1 type2) + (type1 type2) ;; The CSUBTYPEP clauses here let us simplify e.g. ;; (TYPE-INTERSECTION2 (SPECIFIER-TYPE 'LIST) ;; (SPECIFIER-TYPE '(OR LIST VECTOR))) @@ -2756,38 +2756,38 @@ (aver (union-type-p type2)) ;; Make sure to call only the applicable methods... (cond ((and (union-type-p type1) - (union-simple-subtypep type1 type2)) type1) - ((and (union-type-p type1) - (union-simple-subtypep type2 type1)) type2) - ((and (not (union-type-p type1)) - (union-complex-subtypep-arg2 type1 type2)) - type1) - ((and (not (union-type-p type1)) - (union-complex-subtypep-arg1 type2 type1)) - type2) - (t - ;; KLUDGE: This code accumulates a sequence of TYPE-UNION2 - ;; operations in a particular order, and gives up if any of - ;; the sub-unions turn out not to be simple. In other cases - ;; ca. sbcl-0.6.11.15, that approach to taking a union was a - ;; bad idea, since it can overlook simplifications which - ;; might occur if the terms were accumulated in a different - ;; order. It's possible that that will be a problem here too. - ;; However, I can't think of a good example to demonstrate - ;; it, and without an example to demonstrate it I can't write - ;; test cases, and without test cases I don't want to - ;; complicate the code to address what's still a hypothetical - ;; problem. So I punted. -- WHN 2001-03-20 - (let ((accumulator *empty-type*)) - (dolist (t2 (union-type-types type2) accumulator) - (setf accumulator - (type-union accumulator - (type-intersection type1 t2)))))))) + (union-simple-subtypep type1 type2)) type1) + ((and (union-type-p type1) + (union-simple-subtypep type2 type1)) type2) + ((and (not (union-type-p type1)) + (union-complex-subtypep-arg2 type1 type2)) + type1) + ((and (not (union-type-p type1)) + (union-complex-subtypep-arg1 type2 type1)) + type2) + (t + ;; KLUDGE: This code accumulates a sequence of TYPE-UNION2 + ;; operations in a particular order, and gives up if any of + ;; the sub-unions turn out not to be simple. In other cases + ;; ca. sbcl-0.6.11.15, that approach to taking a union was a + ;; bad idea, since it can overlook simplifications which + ;; might occur if the terms were accumulated in a different + ;; order. It's possible that that will be a problem here too. + ;; However, I can't think of a good example to demonstrate + ;; it, and without an example to demonstrate it I can't write + ;; test cases, and without test cases I don't want to + ;; complicate the code to address what's still a hypothetical + ;; problem. So I punted. -- WHN 2001-03-20 + (let ((accumulator *empty-type*)) + (dolist (t2 (union-type-types type2) accumulator) + (setf accumulator + (type-union accumulator + (type-intersection type1 t2)))))))) (!def-type-translator or (&rest type-specifiers) (apply #'type-union - (mapcar #'specifier-type - type-specifiers))) + (mapcar #'specifier-type + type-specifiers))) ;;;; CONS types @@ -2795,124 +2795,124 @@ (!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*)) (let ((car-type (single-value-specifier-type car-type-spec)) - (cdr-type (single-value-specifier-type cdr-type-spec))) + (cdr-type (single-value-specifier-type cdr-type-spec))) (make-cons-type car-type cdr-type))) (!define-type-method (cons :negate) (type) (if (and (eq (cons-type-car-type type) *universal-type*) - (eq (cons-type-cdr-type type) *universal-type*)) + (eq (cons-type-cdr-type type) *universal-type*)) (make-negation-type :type type) (type-union (make-negation-type :type (specifier-type 'cons)) (cond - ((and (not (eq (cons-type-car-type type) *universal-type*)) - (not (eq (cons-type-cdr-type type) *universal-type*))) - (type-union - (make-cons-type - (type-negation (cons-type-car-type type)) - *universal-type*) - (make-cons-type - *universal-type* - (type-negation (cons-type-cdr-type type))))) - ((not (eq (cons-type-car-type type) *universal-type*)) - (make-cons-type - (type-negation (cons-type-car-type type)) - *universal-type*)) - ((not (eq (cons-type-cdr-type type) *universal-type*)) - (make-cons-type - *universal-type* - (type-negation (cons-type-cdr-type type)))) - (t (bug "Weird CONS type ~S" type)))))) + ((and (not (eq (cons-type-car-type type) *universal-type*)) + (not (eq (cons-type-cdr-type type) *universal-type*))) + (type-union + (make-cons-type + (type-negation (cons-type-car-type type)) + *universal-type*) + (make-cons-type + *universal-type* + (type-negation (cons-type-cdr-type type))))) + ((not (eq (cons-type-car-type type) *universal-type*)) + (make-cons-type + (type-negation (cons-type-car-type type)) + *universal-type*)) + ((not (eq (cons-type-cdr-type type) *universal-type*)) + (make-cons-type + *universal-type* + (type-negation (cons-type-cdr-type type)))) + (t (bug "Weird CONS type ~S" type)))))) (!define-type-method (cons :unparse) (type) (let ((car-eltype (type-specifier (cons-type-car-type type))) - (cdr-eltype (type-specifier (cons-type-cdr-type type)))) + (cdr-eltype (type-specifier (cons-type-cdr-type type)))) (if (and (member car-eltype '(t *)) - (member cdr-eltype '(t *))) - 'cons - `(cons ,car-eltype ,cdr-eltype)))) - + (member cdr-eltype '(t *))) + 'cons + `(cons ,car-eltype ,cdr-eltype)))) + (!define-type-method (cons :simple-=) (type1 type2) (declare (type cons-type type1 type2)) (and (type= (cons-type-car-type type1) (cons-type-car-type type2)) (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2)))) - + (!define-type-method (cons :simple-subtypep) (type1 type2) (declare (type cons-type type1 type2)) (multiple-value-bind (val-car win-car) (csubtypep (cons-type-car-type type1) (cons-type-car-type type2)) (multiple-value-bind (val-cdr win-cdr) - (csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2)) + (csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2)) (if (and val-car val-cdr) - (values t (and win-car win-cdr)) - (values nil (or win-car win-cdr)))))) - + (values t (and win-car win-cdr)) + (values nil (or win-car win-cdr)))))) + ;;; Give up if a precise type is not possible, to avoid returning ;;; overly general types. (!define-type-method (cons :simple-union2) (type1 type2) (declare (type cons-type type1 type2)) (let ((car-type1 (cons-type-car-type type1)) - (car-type2 (cons-type-car-type type2)) - (cdr-type1 (cons-type-cdr-type type1)) - (cdr-type2 (cons-type-cdr-type type2)) - car-not1 - car-not2) + (car-type2 (cons-type-car-type type2)) + (cdr-type1 (cons-type-cdr-type type1)) + (cdr-type2 (cons-type-cdr-type type2)) + car-not1 + car-not2) ;; UGH. -- CSR, 2003-02-24 (macrolet ((frob-car (car1 car2 cdr1 cdr2 - &optional (not1 nil not1p)) - `(type-union - (make-cons-type ,car1 (type-union ,cdr1 ,cdr2)) - (make-cons-type - (type-intersection ,car2 - ,(if not1p - not1 - `(type-negation ,car1))) - ,cdr2)))) + &optional (not1 nil not1p)) + `(type-union + (make-cons-type ,car1 (type-union ,cdr1 ,cdr2)) + (make-cons-type + (type-intersection ,car2 + ,(if not1p + not1 + `(type-negation ,car1))) + ,cdr2)))) (cond ((type= car-type1 car-type2) - (make-cons-type car-type1 - (type-union cdr-type1 cdr-type2))) - ((type= cdr-type1 cdr-type2) - (make-cons-type (type-union car-type1 car-type2) - cdr-type1)) - ((csubtypep car-type1 car-type2) - (frob-car car-type1 car-type2 cdr-type1 cdr-type2)) - ((csubtypep car-type2 car-type1) - (frob-car car-type2 car-type1 cdr-type2 cdr-type1)) - ;; more general case of the above, but harder to compute - ((progn - (setf car-not1 (type-negation car-type1)) - (not (csubtypep car-type2 car-not1))) - (frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1)) - ((progn - (setf car-not2 (type-negation car-type2)) - (not (csubtypep car-type1 car-not2))) - (frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2)) - ;; Don't put these in -- consider the effect of taking the - ;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and - ;; (CONS (INTEGER 0 3) (INTEGER 5 6)). - #+nil - ((csubtypep cdr-type1 cdr-type2) - (frob-cdr car-type1 car-type2 cdr-type1 cdr-type2)) - #+nil - ((csubtypep cdr-type2 cdr-type1) - (frob-cdr car-type2 car-type1 cdr-type2 cdr-type1)))))) - + (make-cons-type car-type1 + (type-union cdr-type1 cdr-type2))) + ((type= cdr-type1 cdr-type2) + (make-cons-type (type-union car-type1 car-type2) + cdr-type1)) + ((csubtypep car-type1 car-type2) + (frob-car car-type1 car-type2 cdr-type1 cdr-type2)) + ((csubtypep car-type2 car-type1) + (frob-car car-type2 car-type1 cdr-type2 cdr-type1)) + ;; more general case of the above, but harder to compute + ((progn + (setf car-not1 (type-negation car-type1)) + (not (csubtypep car-type2 car-not1))) + (frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1)) + ((progn + (setf car-not2 (type-negation car-type2)) + (not (csubtypep car-type1 car-not2))) + (frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2)) + ;; Don't put these in -- consider the effect of taking the + ;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and + ;; (CONS (INTEGER 0 3) (INTEGER 5 6)). + #+nil + ((csubtypep cdr-type1 cdr-type2) + (frob-cdr car-type1 car-type2 cdr-type1 cdr-type2)) + #+nil + ((csubtypep cdr-type2 cdr-type1) + (frob-cdr car-type2 car-type1 cdr-type2 cdr-type1)))))) + (!define-type-method (cons :simple-intersection2) (type1 type2) (declare (type cons-type type1 type2)) (let ((car-int2 (type-intersection2 (cons-type-car-type type1) - (cons-type-car-type type2))) - (cdr-int2 (type-intersection2 (cons-type-cdr-type type1) - (cons-type-cdr-type type2)))) + (cons-type-car-type type2))) + (cdr-int2 (type-intersection2 (cons-type-cdr-type type1) + (cons-type-cdr-type type2)))) (cond ((and car-int2 cdr-int2) (make-cons-type car-int2 cdr-int2)) (car-int2 (make-cons-type car-int2 - (type-intersection - (cons-type-cdr-type type1) - (cons-type-cdr-type type2)))) + (type-intersection + (cons-type-cdr-type type1) + (cons-type-cdr-type type2)))) (cdr-int2 (make-cons-type - (type-intersection (cons-type-car-type type1) - (cons-type-car-type type2)) - cdr-int2))))) + (type-intersection (cons-type-car-type type1) + (cons-type-car-type type2)) + cdr-int2))))) ;;;; CHARACTER-SET types @@ -2964,7 +2964,7 @@ (let ((pairs1 (character-set-type-pairs type1)) (pairs2 (character-set-type-pairs type2))) (values (equal pairs1 pairs2) t))) - + (!define-type-method (character-set :simple-subtypep) (type1 type2) (values (dolist (pair (character-set-type-pairs type1) t) @@ -3016,50 +3016,50 @@ ;;; worthwhile, given its low utility. (defun type-difference (x y) (let ((x-types (if (union-type-p x) (union-type-types x) (list x))) - (y-types (if (union-type-p y) (union-type-types y) (list y)))) + (y-types (if (union-type-p y) (union-type-types y) (list y)))) (collect ((res)) (dolist (x-type x-types) - (if (member-type-p x-type) - (collect ((members)) - (dolist (mem (member-type-members x-type)) - (multiple-value-bind (val win) (ctypep mem y) - (unless win (return-from type-difference nil)) - (unless val - (members mem)))) - (when (members) - (res (make-member-type :members (members))))) - (dolist (y-type y-types (res x-type)) - (multiple-value-bind (val win) (csubtypep x-type y-type) - (unless win (return-from type-difference nil)) - (when val (return)) - (when (types-equal-or-intersect x-type y-type) - (return-from type-difference nil)))))) + (if (member-type-p x-type) + (collect ((members)) + (dolist (mem (member-type-members x-type)) + (multiple-value-bind (val win) (ctypep mem y) + (unless win (return-from type-difference nil)) + (unless val + (members mem)))) + (when (members) + (res (make-member-type :members (members))))) + (dolist (y-type y-types (res x-type)) + (multiple-value-bind (val win) (csubtypep x-type y-type) + (unless win (return-from type-difference nil)) + (when val (return)) + (when (types-equal-or-intersect x-type y-type) + (return-from type-difference nil)))))) (let ((y-mem (find-if #'member-type-p y-types))) - (when y-mem - (let ((members (member-type-members y-mem))) - (dolist (x-type x-types) - (unless (member-type-p x-type) - (dolist (member members) - (multiple-value-bind (val win) (ctypep member x-type) - (when (or (not win) val) - (return-from type-difference nil))))))))) + (when y-mem + (let ((members (member-type-members y-mem))) + (dolist (x-type x-types) + (unless (member-type-p x-type) + (dolist (member members) + (multiple-value-bind (val win) (ctypep member x-type) + (when (or (not win) val) + (return-from type-difference nil))))))))) (apply #'type-union (res))))) (!def-type-translator array (&optional (element-type '*) - (dimensions '*)) + (dimensions '*)) (specialize-array-type (make-array-type :dimensions (canonical-array-dimensions dimensions) :complexp :maybe - :element-type (if (eq element-type '*) + :element-type (if (eq element-type '*) *wild-type* (specifier-type element-type))))) (!def-type-translator simple-array (&optional (element-type '*) - (dimensions '*)) + (dimensions '*)) (specialize-array-type (make-array-type :dimensions (canonical-array-dimensions dimensions) :complexp nil - :element-type (if (eq element-type '*) + :element-type (if (eq element-type '*) *wild-type* (specifier-type element-type))))) @@ -3070,57 +3070,57 @@ (defun defined-ftype-matches-declared-ftype-p (defined-ftype declared-ftype) (declare (type ctype defined-ftype declared-ftype)) (flet ((is-built-in-class-function-p (ctype) - (and (built-in-classoid-p ctype) - (eq (built-in-classoid-name ctype) 'function)))) + (and (built-in-classoid-p ctype) + (eq (built-in-classoid-name ctype) 'function)))) (cond (;; DECLARED-FTYPE could certainly be #; - ;; that's what happens when we (DECLAIM (FTYPE FUNCTION FOO)). - (is-built-in-class-function-p declared-ftype) - ;; In that case, any definition satisfies the declaration. - t) - (;; It's not clear whether or how DEFINED-FTYPE might be - ;; #, but it's not obviously - ;; invalid, so let's handle that case too, just in case. - (is-built-in-class-function-p defined-ftype) - ;; No matter what DECLARED-FTYPE might be, we can't prove - ;; that an object of type FUNCTION doesn't satisfy it, so - ;; we return success no matter what. - t) - (;; Otherwise both of them must be FUN-TYPE objects. - t - ;; FIXME: For now we only check compatibility of the return - ;; type, not argument types, and we don't even check the - ;; return type very precisely (as per bug 94a). It would be - ;; good to do a better job. Perhaps to check the - ;; compatibility of the arguments, we should (1) redo - ;; VALUES-TYPES-EQUAL-OR-INTERSECT as - ;; ARGS-TYPES-EQUAL-OR-INTERSECT, and then (2) apply it to - ;; the ARGS-TYPE slices of the FUN-TYPEs. (ARGS-TYPE - ;; is a base class both of VALUES-TYPE and of FUN-TYPE.) - (values-types-equal-or-intersect - (fun-type-returns defined-ftype) - (fun-type-returns declared-ftype)))))) - + ;; that's what happens when we (DECLAIM (FTYPE FUNCTION FOO)). + (is-built-in-class-function-p declared-ftype) + ;; In that case, any definition satisfies the declaration. + t) + (;; It's not clear whether or how DEFINED-FTYPE might be + ;; #, but it's not obviously + ;; invalid, so let's handle that case too, just in case. + (is-built-in-class-function-p defined-ftype) + ;; No matter what DECLARED-FTYPE might be, we can't prove + ;; that an object of type FUNCTION doesn't satisfy it, so + ;; we return success no matter what. + t) + (;; Otherwise both of them must be FUN-TYPE objects. + t + ;; FIXME: For now we only check compatibility of the return + ;; type, not argument types, and we don't even check the + ;; return type very precisely (as per bug 94a). It would be + ;; good to do a better job. Perhaps to check the + ;; compatibility of the arguments, we should (1) redo + ;; VALUES-TYPES-EQUAL-OR-INTERSECT as + ;; ARGS-TYPES-EQUAL-OR-INTERSECT, and then (2) apply it to + ;; the ARGS-TYPE slices of the FUN-TYPEs. (ARGS-TYPE + ;; is a base class both of VALUES-TYPE and of FUN-TYPE.) + (values-types-equal-or-intersect + (fun-type-returns defined-ftype) + (fun-type-returns declared-ftype)))))) + ;;; This messy case of CTYPE for NUMBER is shared between the ;;; cross-compiler and the target system. (defun ctype-of-number (x) (let ((num (if (complexp x) (realpart x) x))) (multiple-value-bind (complexp low high) - (if (complexp x) - (let ((imag (imagpart x))) - (values :complex (min num imag) (max num imag))) - (values :real num num)) + (if (complexp x) + (let ((imag (imagpart x))) + (values :complex (min num imag) (max num imag))) + (values :real num num)) (make-numeric-type :class (etypecase num - (integer (if (complexp x) + (integer (if (complexp x) (if (integerp (imagpart x)) 'integer 'rational) 'integer)) - (rational 'rational) - (float 'float)) - :format (and (floatp num) (float-format-name num)) - :complexp complexp - :low low - :high high)))) + (rational 'rational) + (float 'float)) + :format (and (floatp num) (float-format-name num)) + :complexp complexp + :low low + :high high)))) (locally ;; Why SAFETY 0? To suppress the is-it-the-right-structure-type diff --git a/src/code/linkage-table.lisp b/src/code/linkage-table.lisp index aebb35b..8380d6d 100644 --- a/src/code/linkage-table.lisp +++ b/src/code/linkage-table.lisp @@ -36,19 +36,19 @@ (defun write-linkage-table-entry (table-address real-address datap) (/show0 "write-linkage-table-entry") (let ((reloc (int-sap table-address)) - (target (int-sap real-address))) + (target (int-sap real-address))) (if datap - (arch-write-linkage-table-ref reloc target) - (arch-write-linkage-table-jmp reloc target)))) + (arch-write-linkage-table-ref reloc target) + (arch-write-linkage-table-jmp reloc target)))) ;;; Add the linkage information about a foreign symbol in the ;;; persistent table, and write the linkage-table entry. (defun link-foreign-symbol (name datap) (/show0 "link-foreign-symbol") (let ((table-address (+ (* (hash-table-count *linkage-info*) - sb!vm:linkage-table-entry-size) - sb!vm:linkage-table-space-start)) - (real-address (ensure-dynamic-foreign-symbol-address name datap))) + sb!vm:linkage-table-entry-size) + sb!vm:linkage-table-space-start)) + (real-address (ensure-dynamic-foreign-symbol-address name datap))) (aver real-address) (unless (< table-address sb!vm:linkage-table-space-end) (error "Linkage-table full (~D entries): cannot link ~S." @@ -74,12 +74,12 @@ ;; Doesn't take care of its own locking -- callers are responsible (maphash (lambda (name-and-datap info) (let* ((name (car name-and-datap)) - (datap (cdr name-and-datap)) - (table-address (linkage-info-address info)) - (real-address - (ensure-dynamic-foreign-symbol-address name datap))) - (aver (and table-address real-address)) - (write-linkage-table-entry table-address - real-address - datap))) + (datap (cdr name-and-datap)) + (table-address (linkage-info-address info)) + (real-address + (ensure-dynamic-foreign-symbol-address name datap))) + (aver (and table-address real-address)) + (write-linkage-table-entry table-address + real-address + datap))) *linkage-info*)) diff --git a/src/code/linux-os.lisp b/src/code/linux-os.lisp index 3ce6930..585401e 100644 --- a/src/code/linux-os.lisp +++ b/src/code/linux-os.lisp @@ -30,10 +30,10 @@ if not available." (or *software-version* (setf *software-version* - (string-trim '(#\newline) - (with-output-to-string (stream) - (sb!ext:run-program "/bin/uname" `("-r") - :output stream)))))) + (string-trim '(#\newline) + (with-output-to-string (stream) + (sb!ext:run-program "/bin/uname" `("-r") + :output stream)))))) ;;; FIXME: This logic is duplicated in other backends: ;;; abstract, abstract. OS-COMMON-COLD-INIT-OR-REINIT, mayhaps? @@ -42,12 +42,12 @@ (setf *software-version* nil) (/show0 "setting *DEFAULT-PATHNAME-DEFAULTS*") (setf *default-pathname-defaults* - ;; (temporary value, so that #'PATHNAME won't blow up when - ;; we call it below:) - (make-trivial-default-pathname) - *default-pathname-defaults* - ;; (final value, constructed using #'PATHNAME:) - (pathname (sb!unix:posix-getcwd/))) + ;; (temporary value, so that #'PATHNAME won't blow up when + ;; we call it below:) + (make-trivial-default-pathname) + *default-pathname-defaults* + ;; (final value, constructed using #'PATHNAME:) + (pathname (sb!unix:posix-getcwd/))) (/show0 "leaving linux-os.lisp OS-COLD-INIT-OR-REINIT")) ;;; Return system time, user time and number of page faults. diff --git a/src/code/list.lisp b/src/code/list.lisp index edcda97..e21535c 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -18,12 +18,12 @@ ;;;; -- WHN 20000127 (declaim (maybe-inline - tree-equal nth %setnth nthcdr last make-list append - nconc member member-if member-if-not tailp adjoin union - nunion intersection nintersection set-difference nset-difference - set-exclusive-or nset-exclusive-or subsetp acons assoc - assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if - subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis)) + tree-equal nth %setnth nthcdr last make-list append + nconc member member-if member-if-not tailp adjoin union + nunion intersection nintersection set-difference nset-difference + set-exclusive-or nset-exclusive-or subsetp acons assoc + assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if + subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis)) ;;; These functions perform basic list operations. (defun car (list) #!+sb-doc "Return the 1st object in a list." (car list)) @@ -117,22 +117,22 @@ (defun tree-equal-test-not (x y test-not) (declare (type function test-not)) (cond ((consp x) - (and (consp y) - (tree-equal-test-not (car x) (car y) test-not) - (tree-equal-test-not (cdr x) (cdr y) test-not))) - ((consp y) nil) - ((not (funcall test-not x y)) t) - (t ()))) + (and (consp y) + (tree-equal-test-not (car x) (car y) test-not) + (tree-equal-test-not (cdr x) (cdr y) test-not))) + ((consp y) nil) + ((not (funcall test-not x y)) t) + (t ()))) (defun tree-equal-test (x y test) (declare (type function test)) - (cond ((consp x) - (and (consp y) - (tree-equal-test (car x) (car y) test) - (tree-equal-test (cdr x) (cdr y) test))) - ((consp y) nil) - ((funcall test x y) t) - (t ()))) + (cond ((consp x) + (and (consp y) + (tree-equal-test (car x) (car y) test) + (tree-equal-test (cdr x) (cdr y) test))) + ((consp y) nil) + ((funcall test x y) t) + (t ()))) (defun tree-equal (x y &key (test #'eql testp) (test-not nil notp)) #!+sb-doc @@ -255,10 +255,10 @@ #!+sb-doc "Return a list of the arguments with last cons a dotted pair" (cond ((atom others) arg) - ((atom (cdr others)) (cons arg (car others))) - (t (do ((x others (cdr x))) - ((null (cddr x)) (rplacd x (cadr x)))) - (cons arg others)))) + ((atom (cdr others)) (cons arg (car others))) + (t (do ((x others (cdr x))) + ((null (cddr x)) (rplacd x (cadr x)))) + (cons arg others)))) (defun make-list (size &key initial-element) #!+sb-doc @@ -311,13 +311,13 @@ (if (atom list) list (let ((result (list (car list)))) - (do ((x (cdr list) (cdr x)) - (splice result - (cdr (rplacd splice (cons (car x) '()))))) - ((atom x) - (unless (null x) - (rplacd splice x)))) - result))) + (do ((x (cdr list) (cdr x)) + (splice result + (cdr (rplacd splice (cons (car x) '()))))) + ((atom x) + (unless (null x) + (rplacd splice x)))) + result))) (defun copy-alist (alist) #!+sb-doc @@ -325,20 +325,20 @@ (if (endp alist) alist (let ((result - (cons (if (atom (car alist)) - (car alist) - (cons (caar alist) (cdar alist))) - nil))) - (do ((x (cdr alist) (cdr x)) - (splice result - (cdr (rplacd splice - (cons - (if (atom (car x)) - (car x) - (cons (caar x) (cdar x))) - nil))))) - ((endp x))) - result))) + (cons (if (atom (car alist)) + (car alist) + (cons (caar alist) (cdar alist))) + nil))) + (do ((x (cdr alist) (cdr x)) + (splice result + (cdr (rplacd splice + (cons + (if (atom (car x)) + (car x) + (cons (caar x) (cdar x))) + nil))))) + ((endp x))) + result))) (defun copy-tree (object) #!+sb-doc @@ -413,11 +413,11 @@ ;; possibly-improper list LIST. (Or if LIST is circular, you ;; lose.) (count-conses (list) - (do ((in-list list (cdr in-list)) - (result 0 (1+ result))) - ((atom in-list) - result) - (declare (type index result))))) + (do ((in-list list (cdr in-list)) + (result 0 (1+ result))) + ((atom in-list) + result) + (declare (type index result))))) (declare (ftype (function (t) index) count-conses)) (defun butlast (list &optional (n 1)) (if (typep n 'index) @@ -454,15 +454,15 @@ OBJECT. If OBJECT is not a tail of LIST, a copy of LIST is returned. LIST must be a proper list or a dotted list." (do* ((list list (cdr list)) - (result (list ())) - (splice result)) + (result (list ())) + (splice result)) ((atom list) - (if (eql list object) - (cdr result) - (progn (rplacd splice list) (cdr result)))) + (if (eql list object) + (cdr result) + (progn (rplacd splice list) (cdr result)))) (if (eql list object) - (return (cdr result)) - (setq splice (cdr (rplacd splice (list (car list)))))))) + (return (cdr result)) + (setq splice (cdr (rplacd splice (list (car list)))))))) ;;;; functions to alter list structure @@ -522,8 +522,8 @@ (let ((key-tmp (gensym))) `(let ((,key-tmp (apply-key key ,elt))) (cond (testp (funcall test ,item ,key-tmp)) - (notp (not (funcall test-not ,item ,key-tmp))) - (t (funcall test ,item ,key-tmp)))))) + (notp (not (funcall test-not ,item ,key-tmp))) + (t (funcall test ,item ,key-tmp)))))) ;;;; substitution of expressions @@ -671,8 +671,8 @@ (let ((key-tmp (gensym))) `(let ((,key-tmp (apply-key key subtree))) (if notp - (assoc ,key-tmp alist :test-not test-not) - (assoc ,key-tmp alist :test test))))) + (assoc ,key-tmp alist :test-not test-not) + (assoc ,key-tmp alist :test test))))) (defun nsublis (alist tree &key key (test #'eql testp) (test-not #'eql notp)) #!+sb-doc @@ -744,7 +744,7 @@ (do ((list list (cdr list))) ((atom list) (eql list object)) (if (eql object list) - (return t)))) + (return t)))) (defun adjoin (item list &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc @@ -784,8 +784,8 @@ (defmacro steve-splice (source destination) `(let ((temp ,source)) (setf ,source (cdr ,source) - (cdr temp) ,destination - ,destination temp))) + (cdr temp) ,destination + ,destination temp))) (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc @@ -879,7 +879,7 @@ (declare (type function test test-not)) (dolist (elt list1) (unless (with-set-keys (member (apply-key key elt) list2)) - (setq result (cons elt result)))) + (setq result (cons elt result)))) (let ((test (if testp (lambda (x y) (funcall test y x)) test)) @@ -977,7 +977,7 @@ (y data (cdr y))) ((and (endp x) (endp y)) alist) (if (or (endp x) (endp y)) - (error "The lists of keys and data are of unequal length.")) + (error "The lists of keys and data are of unequal length.")) (setq alist (acons (car x) (car y) alist)))) ;;; This is defined in the run-time environment, not just the compile-time diff --git a/src/code/load.lisp b/src/code/load.lisp index 2c3371b..eafe8a0 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -30,8 +30,8 @@ (fresh-line) (let ((semicolons ";;;;;;;;;;;;;;;;")) (do ((count *load-depth* (- count (length semicolons)))) - ((< count (length semicolons)) - (write-string semicolons *standard-output* :end count)) + ((< count (length semicolons)) + (write-string semicolons *standard-output* :end count)) (declare (fixnum count)) (write-string semicolons)) (write-char #\space))) @@ -42,10 +42,10 @@ (when verbose (load-fresh-line) (let ((name #-sb-xc-host (file-name stream-we-are-loading-from) - #+sb-xc-host nil)) + #+sb-xc-host nil)) (if name - (format t "loading ~S~%" name) - (format t "loading stuff from ~S~%" stream-we-are-loading-from))))) + (format t "loading ~S~%" name) + (format t "loading stuff from ~S~%" stream-we-are-loading-from))))) ;;;; utilities for reading from fasl files @@ -60,22 +60,22 @@ (defmacro fast-read-u-integer (n) (declare (optimize (speed 0))) (do ((res '(fast-read-byte) - `(logior (fast-read-byte) - (ash ,res 8))) + `(logior (fast-read-byte) + (ash ,res 8))) (cnt 1 (1+ cnt))) ((>= cnt n) res))) ;;; like FAST-READ-U-INTEGER, but the size may be determined at run time (defmacro fast-read-var-u-integer (n) (let ((n-pos (gensym)) - (n-res (gensym)) - (n-cnt (gensym))) + (n-res (gensym)) + (n-cnt (gensym))) `(do ((,n-pos 8 (+ ,n-pos 8)) - (,n-cnt (1- ,n) (1- ,n-cnt)) - (,n-res - (fast-read-byte) - (dpb (fast-read-byte) (byte 8 ,n-pos) ,n-res))) - ((zerop ,n-cnt) ,n-res) + (,n-cnt (1- ,n) (1- ,n-cnt)) + (,n-res + (fast-read-byte) + (dpb (fast-read-byte) (byte 8 ,n-pos) ,n-res))) + ((zerop ,n-cnt) ,n-res) (declare (type index ,n-pos ,n-cnt))))) ;;; Read a signed integer. @@ -83,13 +83,13 @@ (declare (optimize (speed 0))) (let ((n-last (gensym))) (do ((res `(let ((,n-last (fast-read-byte))) - (if (zerop (logand ,n-last #x80)) - ,n-last - (logior ,n-last #x-100))) - `(logior (fast-read-byte) - (ash (the (signed-byte ,(* cnt 8)) ,res) 8))) - (cnt 1 (1+ cnt))) - ((>= cnt n) res)))) + (if (zerop (logand ,n-last #x80)) + ,n-last + (logior ,n-last #x-100))) + `(logior (fast-read-byte) + (ash (the (signed-byte ,(* cnt 8)) ,res) 8))) + (cnt 1 (1+ cnt))) + ((>= cnt n) res)))) ;;; Read an N-byte unsigned integer from the *FASL-INPUT-STREAM*. (defmacro read-arg (n) @@ -97,9 +97,9 @@ (if (= n 1) `(the (unsigned-byte 8) (read-byte *fasl-input-stream*)) `(prepare-for-fast-read-byte *fasl-input-stream* - (prog1 - (fast-read-u-integer ,n) - (done-with-fast-read-byte))))) + (prog1 + (fast-read-u-integer ,n) + (done-with-fast-read-byte))))) (declaim (inline read-byte-arg read-halfword-arg read-word-arg)) (defun read-byte-arg () @@ -141,7 +141,7 @@ (defun grow-fop-table () (let* ((new-size (* *current-fop-table-size* 2)) - (new-table (make-array new-size))) + (new-table (make-array new-size))) (declare (fixnum new-size) (simple-vector new-table)) (replace new-table (the simple-vector *current-fop-table*)) (setq *current-fop-table* new-table) @@ -152,7 +152,7 @@ `(let ((,n-index *current-fop-table-index*)) (declare (fixnum ,n-index)) (when (= ,n-index (the fixnum *current-fop-table-size*)) - (grow-fop-table)) + (grow-fop-table)) (setq *current-fop-table-index* (1+ ,n-index)) (setf (svref *current-fop-table* ,n-index) ,thing)))) @@ -172,12 +172,12 @@ `(let ((,fop-stack *fop-stack*)) (declare (type (vector t) ,fop-stack)) (macrolet ((pop-stack () - `(vector-pop ,',fop-stack)) - (call-with-popped-args (fun n) - `(%call-with-popped-args ,fun ,n ,',fop-stack))) - ,(if pushp - `(vector-push-extend (progn ,@forms) ,fop-stack) - `(progn ,@forms)))))) + `(vector-pop ,',fop-stack)) + (call-with-popped-args (fun n) + `(%call-with-popped-args ,fun ,n ,',fop-stack))) + ,(if pushp + `(vector-push-extend (progn ,@forms) ,fop-stack) + `(progn ,@forms)))))) ;;; Call FUN with N arguments popped from STACK. (defmacro %call-with-popped-args (fun n stack) @@ -186,19 +186,19 @@ (with-unique-names (n-stack old-length new-length) (let ((argtmps (make-gensym-list n))) `(let* ((,n-stack ,stack) - (,old-length (fill-pointer ,n-stack)) - (,new-length (- ,old-length ,n)) - ,@(loop for i from 0 below n collecting - `(,(nth i argtmps) - (aref ,n-stack (+ ,new-length ,i))))) - (declare (type (vector t) ,n-stack)) - (setf (fill-pointer ,n-stack) ,new-length) - ;; (For some applications it might be appropriate to FILL the - ;; popped area with NIL here, to avoid holding onto garbage. For - ;; sbcl-0.8.7.something, though, it shouldn't matter, because - ;; we're using this only to pop stuff off *FOP-STACK*, and the - ;; entire *FOP-STACK* can be GCed as soon as LOAD returns.) - (,fun ,@argtmps))))) + (,old-length (fill-pointer ,n-stack)) + (,new-length (- ,old-length ,n)) + ,@(loop for i from 0 below n collecting + `(,(nth i argtmps) + (aref ,n-stack (+ ,new-length ,i))))) + (declare (type (vector t) ,n-stack)) + (setf (fill-pointer ,n-stack) ,new-length) + ;; (For some applications it might be appropriate to FILL the + ;; popped area with NIL here, to avoid holding onto garbage. For + ;; sbcl-0.8.7.something, though, it shouldn't matter, because + ;; we're using this only to pop stuff off *FOP-STACK*, and the + ;; entire *FOP-STACK* can be GCed as soon as LOAD returns.) + (,fun ,@argtmps))))) ;;;; Conditions signalled on invalid fasls (wrong fasl version, etc), ;;;; so that user code (esp. ASDF) can reasonably handle attempts to @@ -212,7 +212,7 @@ (:report (lambda (condition stream) (format stream "~S is an invalid fasl file." - (invalid-fasl-stream condition))))) + (invalid-fasl-stream condition))))) (define-condition invalid-fasl-header (invalid-fasl) ((byte :reader invalid-fasl-byte :initarg :byte) @@ -221,10 +221,10 @@ (lambda (condition stream) (format stream "~@<~S contains an illegal byte in the FASL header at ~ position ~A: Expected ~A, got ~A.~:@>" - (invalid-fasl-stream condition) - (invalid-fasl-byte-nr condition) - (invalid-fasl-byte condition) - (invalid-fasl-expected condition))))) + (invalid-fasl-stream condition) + (invalid-fasl-byte-nr condition) + (invalid-fasl-byte condition) + (invalid-fasl-expected condition))))) (define-condition invalid-fasl-version (invalid-fasl) ((variant :reader invalid-fasl-variant :initarg :variant) @@ -233,24 +233,24 @@ (lambda (condition stream) (format stream "~@<~S is in ~A fasl file format version ~W, ~ but this version of SBCL uses format version ~W.~:@>" - (invalid-fasl-stream condition) - (invalid-fasl-variant condition) - (invalid-fasl-version condition) - (invalid-fasl-expected condition))))) + (invalid-fasl-stream condition) + (invalid-fasl-variant condition) + (invalid-fasl-version condition) + (invalid-fasl-expected condition))))) (define-condition invalid-fasl-implementation (invalid-fasl) ((implementation :reader invalid-fasl-implementation - :initarg :implementation)) - (:report + :initarg :implementation)) + (:report (lambda (condition stream) (format stream "~S was compiled for implementation ~A, but this is a ~A." - (invalid-fasl-stream condition) - (invalid-fasl-implementation condition) - (invalid-fasl-expected condition))))) + (invalid-fasl-stream condition) + (invalid-fasl-implementation condition) + (invalid-fasl-expected condition))))) (define-condition invalid-fasl-features (invalid-fasl) ((potential-features :reader invalid-fasl-potential-features - :initarg :potential-features) + :initarg :potential-features) (features :reader invalid-fasl-features :initarg :features)) (:report (lambda (condition stream) @@ -258,11 +258,11 @@ Of features affecting binary compatibility, ~4I~_~S~2I~_~ the fasl has ~4I~_~A,~2I~_~ while the runtime expects ~4I~_~A.~:>" - '*features* - (invalid-fasl-stream condition) - (invalid-fasl-potential-features condition) - (invalid-fasl-features condition) - (invalid-fasl-expected condition))))) + '*features* + (invalid-fasl-stream condition) + (invalid-fasl-potential-features condition) + (invalid-fasl-features condition) + (invalid-fasl-expected condition))))) ;;;; LOAD-AS-FASL ;;;; @@ -283,65 +283,65 @@ ;; Read and validate constant string prefix in fasl header. (let* ((fhsss *fasl-header-string-start-string*) - (fhsss-length (length fhsss))) - (unless (= byte (char-code (schar fhsss 0))) - (error 'invalid-fasl-header - :stream stream - :first-byte-p t - :byte byte - :expected (char-code (schar fhsss 0)))) - (do ((byte (read-byte stream) (read-byte stream)) - (count 1 (1+ count))) - ((= byte +fasl-header-string-stop-char-code+) - t) - (declare (fixnum byte count)) - (when (and (< count fhsss-length) - (not (eql byte (char-code (schar fhsss count))))) - (error 'invalid-fasl-header - :stream stream - :byte-nr count - :byte byte - :expected (char-code (schar fhsss count)))))) + (fhsss-length (length fhsss))) + (unless (= byte (char-code (schar fhsss 0))) + (error 'invalid-fasl-header + :stream stream + :first-byte-p t + :byte byte + :expected (char-code (schar fhsss 0)))) + (do ((byte (read-byte stream) (read-byte stream)) + (count 1 (1+ count))) + ((= byte +fasl-header-string-stop-char-code+) + t) + (declare (fixnum byte count)) + (when (and (< count fhsss-length) + (not (eql byte (char-code (schar fhsss count))))) + (error 'invalid-fasl-header + :stream stream + :byte-nr count + :byte byte + :expected (char-code (schar fhsss count)))))) ;; Read and validate version-specific compatibility stuff. (flet ((string-from-stream () (let* ((length (read-word-arg)) - (result (make-string length))) - (read-string-as-bytes stream result) - result))) - ;; Read and validate implementation and version. - (let* ((implementation (keywordicate (string-from-stream))) - ;; FIXME: The logic above to read a keyword from the fasl file - ;; could probably be shared with the read-a-keyword fop. - (version (read-word-arg))) - (flet ((check-version (variant - possible-implementation - needed-version) - (when (string= possible-implementation implementation) - (or (= version needed-version) - (error 'invalid-fasl-version - ;; :error :wrong-version - :stream stream - :variant variant - :version version - :expected needed-version))))) - (or (check-version "native code" - +backend-fasl-file-implementation+ - +fasl-file-version+) - (error 'invalid-fasl-implementation - :stream stream - :implementation implementation - :expected +backend-fasl-file-implementation+)))) - ;; Read and validate *FEATURES* which affect binary compatibility. - (let ((faff-in-this-file (string-from-stream))) - (unless (string= faff-in-this-file *features-affecting-fasl-format*) - (error 'invalid-fasl-features - :stream stream - :potential-features *features-potentially-affecting-fasl-format* - :expected *features-affecting-fasl-format* - :features faff-in-this-file))) - ;; success - t)))) + (result (make-string length))) + (read-string-as-bytes stream result) + result))) + ;; Read and validate implementation and version. + (let* ((implementation (keywordicate (string-from-stream))) + ;; FIXME: The logic above to read a keyword from the fasl file + ;; could probably be shared with the read-a-keyword fop. + (version (read-word-arg))) + (flet ((check-version (variant + possible-implementation + needed-version) + (when (string= possible-implementation implementation) + (or (= version needed-version) + (error 'invalid-fasl-version + ;; :error :wrong-version + :stream stream + :variant variant + :version version + :expected needed-version))))) + (or (check-version "native code" + +backend-fasl-file-implementation+ + +fasl-file-version+) + (error 'invalid-fasl-implementation + :stream stream + :implementation implementation + :expected +backend-fasl-file-implementation+)))) + ;; Read and validate *FEATURES* which affect binary compatibility. + (let ((faff-in-this-file (string-from-stream))) + (unless (string= faff-in-this-file *features-affecting-fasl-format*) + (error 'invalid-fasl-features + :stream stream + :potential-features *features-potentially-affecting-fasl-format* + :expected *features-affecting-fasl-format* + :features faff-in-this-file))) + ;; success + t)))) ;; Setting this variable gives you a trace of fops as they are loaded and ;; executed. @@ -352,22 +352,22 @@ (defvar *fasl-symbol-buffer*) (declaim (simple-string *fasl-symbol-buffer*)) -;;; +;;; ;;; a helper function for LOAD-AS-FASL ;;; ;;; Return true if we successfully load a group from the stream, or ;;; NIL if EOF was encountered while trying to read from the stream. -;;; Dispatch to the right function for each fop. +;;; Dispatch to the right function for each fop. (defun load-fasl-group (stream) (when (check-fasl-header stream) (catch 'fasl-group-end (let ((*current-fop-table-index* 0)) - (loop - (let ((byte (read-byte stream))) + (loop + (let ((byte (read-byte stream))) - ;; Do some debugging output. - #!+sb-show - (when *show-fops-p* + ;; Do some debugging output. + #!+sb-show + (when *show-fops-p* (let* ((stack *fop-stack*) (ptr (1- (fill-pointer *fop-stack*)))) (fresh-line *trace-output*) @@ -386,8 +386,8 @@ (1- (file-position stream)) (svref *fop-funs* byte)))) - ;; Actually execute the fop. - (funcall (the function (svref *fop-funs* byte))))))))) + ;; Actually execute the fop. + (funcall (the function (svref *fop-funs* byte))))))))) (defun load-as-fasl (stream verbose print) ;; KLUDGE: ANSI says it's good to do something with the :PRINT @@ -401,17 +401,17 @@ (sb!thread:with-recursive-lock (sb!c::*big-compiler-lock*) (let* ((*fasl-input-stream* stream) (*fasl-symbol-buffer* (make-string 100)) - (*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000))) - (*current-fop-table-size* (length *current-fop-table*)) - (*fop-stack* (make-array 100 :fill-pointer 0 :adjustable t))) + (*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000))) + (*current-fop-table-size* (length *current-fop-table*)) + (*fop-stack* (make-array 100 :fill-pointer 0 :adjustable t))) (unwind-protect - (loop while (load-fasl-group stream)) - (push *current-fop-table* *free-fop-tables*) - ;; NIL out the table, so that we don't hold onto garbage. - ;; - ;; FIXME: Could we just get rid of the free fop table pool so - ;; that this would go away? - (fill *current-fop-table* nil)))) + (loop while (load-fasl-group stream)) + (push *current-fop-table* *free-fop-tables*) + ;; NIL out the table, so that we don't hold onto garbage. + ;; + ;; FIXME: Could we just get rid of the free fop table pool so + ;; that this would go away? + (fill *current-fop-table* nil)))) t) ;;;; stuff for debugging/tuning by collecting statistics on FOPs (?) @@ -428,27 +428,27 @@ (defun analyze-counts () (let ((counts ()) - (total-count 0) - (times ()) - (total-time 0)) + (total-count 0) + (times ()) + (total-time 0)) (macrolet ((breakdown (lvar tvar vec) - `(progn - (dotimes (i 255) - (declare (fixnum i)) - (let ((n (svref ,vec i))) - (push (cons (svref *fop-names* i) n) ,lvar) - (incf ,tvar n))) - (setq ,lvar (subseq (sort ,lvar (lambda (x y) - (> (cdr x) (cdr y)))) - 0 10))))) + `(progn + (dotimes (i 255) + (declare (fixnum i)) + (let ((n (svref ,vec i))) + (push (cons (svref *fop-names* i) n) ,lvar) + (incf ,tvar n))) + (setq ,lvar (subseq (sort ,lvar (lambda (x y) + (> (cdr x) (cdr y)))) + 0 10))))) (breakdown counts total-count *fop-counts*) (breakdown times total-time *fop-times*) (format t "Total fop count is ~D~%" total-count) (dolist (c counts) - (format t "~30S: ~4D~%" (car c) (cdr c))) + (format t "~30S: ~4D~%" (car c) (cdr c))) (format t "~%Total fop time is ~D~%" (/ (float total-time) 60.0)) (dolist (m times) - (format t "~30S: ~6,2F~%" (car m) (/ (float (cdr m)) 60.0)))))) + (format t "~30S: ~6,2F~%" (car m) (/ (float (cdr m)) 60.0)))))) |# diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 3d9a363..68f1741 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -105,50 +105,50 @@ (&environment env (head-var tail-var &optional user-head-var) form) (setq form (sb!xc:macroexpand form env)) (flet ((cdr-wrap (form n) - (declare (fixnum n)) - (do () ((<= n 4) (setq form `(,(case n - (1 'cdr) - (2 'cddr) - (3 'cdddr) - (4 'cddddr)) - ,form))) - (setq form `(cddddr ,form) n (- n 4))))) + (declare (fixnum n)) + (do () ((<= n 4) (setq form `(,(case n + (1 'cdr) + (2 'cddr) + (3 'cdddr) + (4 'cddddr)) + ,form))) + (setq form `(cddddr ,form) n (- n 4))))) (let ((tail-form form) (ncdrs nil)) ;; Determine whether the form being constructed is a list of known ;; length. (when (consp form) - (cond ((eq (car form) 'list) - (setq ncdrs (1- (length (cdr form))))) - ((member (car form) '(list* cons)) - (when (and (cddr form) (member (car (last form)) '(nil 'nil))) - (setq ncdrs (- (length (cdr form)) 2)))))) + (cond ((eq (car form) 'list) + (setq ncdrs (1- (length (cdr form))))) + ((member (car form) '(list* cons)) + (when (and (cddr form) (member (car (last form)) '(nil 'nil))) + (setq ncdrs (- (length (cdr form)) 2)))))) (let ((answer - (cond ((null ncdrs) - `(when (setf (cdr ,tail-var) ,tail-form) - (setq ,tail-var (last (cdr ,tail-var))))) - ((< ncdrs 0) (return-from loop-collect-rplacd nil)) - ((= ncdrs 0) - ;; @@@@ Here we have a choice of two idioms: - ;; (RPLACD TAIL (SETQ TAIL TAIL-FORM)) - ;; (SETQ TAIL (SETF (CDR TAIL) TAIL-FORM)). - ;; Genera and most others I have seen do better with the - ;; former. - `(rplacd ,tail-var (setq ,tail-var ,tail-form))) - (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) - ,tail-form) - ncdrs)))))) - ;; If not using locatives or something similar to update the - ;; user's head variable, we've got to set it... It's harmless - ;; to repeatedly set it unconditionally, and probably faster - ;; than checking. - (when user-head-var - (setq answer - `(progn ,answer - (setq ,user-head-var (cdr ,head-var))))) - answer)))) + (cond ((null ncdrs) + `(when (setf (cdr ,tail-var) ,tail-form) + (setq ,tail-var (last (cdr ,tail-var))))) + ((< ncdrs 0) (return-from loop-collect-rplacd nil)) + ((= ncdrs 0) + ;; @@@@ Here we have a choice of two idioms: + ;; (RPLACD TAIL (SETQ TAIL TAIL-FORM)) + ;; (SETQ TAIL (SETF (CDR TAIL) TAIL-FORM)). + ;; Genera and most others I have seen do better with the + ;; former. + `(rplacd ,tail-var (setq ,tail-var ,tail-form))) + (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) + ,tail-form) + ncdrs)))))) + ;; If not using locatives or something similar to update the + ;; user's head variable, we've got to set it... It's harmless + ;; to repeatedly set it unconditionally, and probably faster + ;; than checking. + (when user-head-var + (setq answer + `(progn ,answer + (setq ,user-head-var (cdr ,head-var))))) + answer)))) (sb!int:defmacro-mundanely loop-collect-answer (head-var - &optional user-head-var) + &optional user-head-var) (or user-head-var `(cdr ,head-var))) @@ -169,9 +169,9 @@ constructed. |# (defstruct (loop-minimax - (:constructor make-loop-minimax-internal) - (:copier nil) - (:predicate nil)) + (:constructor make-loop-minimax-internal) + (:copier nil) + (:predicate nil)) answer-variable type temp-variable @@ -186,57 +186,57 @@ constructed. (defun make-loop-minimax (answer-variable type) (let ((infinity-data (cdr (assoc type - *loop-minimax-type-infinities-alist* - :test #'sb!xc:subtypep)))) + *loop-minimax-type-infinities-alist* + :test #'sb!xc:subtypep)))) (make-loop-minimax-internal :answer-variable answer-variable :type type :temp-variable (gensym "LOOP-MAXMIN-TEMP-") :flag-variable (and (not infinity-data) - (gensym "LOOP-MAXMIN-FLAG-")) + (gensym "LOOP-MAXMIN-FLAG-")) :operations nil :infinity-data infinity-data))) (defun loop-note-minimax-operation (operation minimax) (pushnew (the symbol operation) (loop-minimax-operations minimax)) (when (and (cdr (loop-minimax-operations minimax)) - (not (loop-minimax-flag-variable minimax))) + (not (loop-minimax-flag-variable minimax))) (setf (loop-minimax-flag-variable minimax) - (gensym "LOOP-MAXMIN-FLAG-"))) + (gensym "LOOP-MAXMIN-FLAG-"))) operation) (sb!int:defmacro-mundanely with-minimax-value (lm &body body) (let ((init (loop-typed-init (loop-minimax-type lm))) - (which (car (loop-minimax-operations lm))) - (infinity-data (loop-minimax-infinity-data lm)) - (answer-var (loop-minimax-answer-variable lm)) - (temp-var (loop-minimax-temp-variable lm)) - (flag-var (loop-minimax-flag-variable lm)) - (type (loop-minimax-type lm))) + (which (car (loop-minimax-operations lm))) + (infinity-data (loop-minimax-infinity-data lm)) + (answer-var (loop-minimax-answer-variable lm)) + (temp-var (loop-minimax-temp-variable lm)) + (flag-var (loop-minimax-flag-variable lm)) + (type (loop-minimax-type lm))) (if flag-var - `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil)) - (declare (type ,type ,answer-var ,temp-var)) - ,@body) - `(let ((,answer-var ,(if (eq which 'min) - (first infinity-data) - (second infinity-data))) - (,temp-var ,init)) - (declare (type ,type ,answer-var ,temp-var)) - ,@body)))) + `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil)) + (declare (type ,type ,answer-var ,temp-var)) + ,@body) + `(let ((,answer-var ,(if (eq which 'min) + (first infinity-data) + (second infinity-data))) + (,temp-var ,init)) + (declare (type ,type ,answer-var ,temp-var)) + ,@body)))) (sb!int:defmacro-mundanely loop-accumulate-minimax-value (lm operation form) (let* ((answer-var (loop-minimax-answer-variable lm)) - (temp-var (loop-minimax-temp-variable lm)) - (flag-var (loop-minimax-flag-variable lm)) - (test `(,(ecase operation - (min '<) - (max '>)) - ,temp-var ,answer-var))) + (temp-var (loop-minimax-temp-variable lm)) + (flag-var (loop-minimax-flag-variable lm)) + (test `(,(ecase operation + (min '<) + (max '>)) + ,temp-var ,answer-var))) `(progn (setq ,temp-var ,form) (when ,(if flag-var `(or (not ,flag-var) ,test) test) - (setq ,@(and flag-var `(,flag-var t)) - ,answer-var ,temp-var))))) + (setq ,@(and flag-var `(,flag-var t)) + ,answer-var ,temp-var))))) ;;;; LOOP keyword tables @@ -273,8 +273,8 @@ code to be loaded. `(setf (gethash (symbol-name ,symbol) ,table) ,datum)) (defstruct (loop-universe - (:copier nil) - (:predicate nil)) + (:copier nil) + (:predicate nil)) keywords ; hash table, value = (fn-name . extra-data) iteration-keywords ; hash table, value = (fn-name . extra-data) for-keywords ; hash table, value = (fn-name . extra-data) @@ -287,10 +287,10 @@ code to be loaded. implicit-for-required) ; see loop-hack-iteration (sb!int:def!method print-object ((u loop-universe) stream) (let ((string (case (loop-universe-ansi u) - ((nil) "non-ANSI") - ((t) "ANSI") - (:extended "extended-ANSI") - (t (loop-universe-ansi u))))) + ((nil) "non-ANSI") + ((t) "ANSI") + (:extended "extended-ANSI") + (t (loop-universe-ansi u))))) (print-unreadable-object (u stream :type t) (write-string string stream)))) @@ -299,16 +299,16 @@ code to be loaded. (defvar *loop-universe*) (defun make-standard-loop-universe (&key keywords for-keywords - iteration-keywords path-keywords - type-keywords type-symbols ansi) + iteration-keywords path-keywords + type-keywords type-symbols ansi) (declare (type (member nil t :extended) ansi)) (flet ((maketable (entries) - (let* ((size (length entries)) - (ht (make-hash-table :size (if (< size 10) 10 size) - :test 'equal))) - (dolist (x entries) - (setf (gethash (symbol-name (car x)) ht) (cadr x))) - ht))) + (let* ((size (length entries)) + (ht (make-hash-table :size (if (< size 10) 10 size) + :test 'equal))) + (dolist (x entries) + (setf (gethash (symbol-name (car x)) ht) (cadr x))) + ht))) (make-loop-universe :keywords (maketable keywords) :for-keywords (maketable for-keywords) @@ -318,23 +318,23 @@ code to be loaded. :implicit-for-required (not (null ansi)) :type-keywords (maketable type-keywords) :type-symbols (let* ((size (length type-symbols)) - (ht (make-hash-table :size (if (< size 10) 10 size) - :test 'eq))) - (dolist (x type-symbols) - (if (atom x) - (setf (gethash x ht) x) - (setf (gethash (car x) ht) (cadr x)))) - ht)))) + (ht (make-hash-table :size (if (< size 10) 10 size) + :test 'eq))) + (dolist (x type-symbols) + (if (atom x) + (setf (gethash x ht) x) + (setf (gethash (car x) ht) (cadr x)))) + ht)))) ;;;; SETQ hackery, including destructuring ("DESETQ") (defun loop-make-psetq (frobs) (and frobs (loop-make-desetq - (list (car frobs) - (if (null (cddr frobs)) (cadr frobs) - `(prog1 ,(cadr frobs) - ,(loop-make-psetq (cddr frobs)))))))) + (list (car frobs) + (if (null (cddr frobs)) (cadr frobs) + `(prog1 ,(cadr frobs) + ,(loop-make-psetq (cddr frobs)))))))) (defun loop-make-desetq (var-val-pairs) (if (null var-val-pairs) @@ -342,66 +342,66 @@ code to be loaded. (cons 'loop-really-desetq var-val-pairs))) (defvar *loop-desetq-temporary* - (make-symbol "LOOP-DESETQ-TEMP")) + (make-symbol "LOOP-DESETQ-TEMP")) (sb!int:defmacro-mundanely loop-really-desetq (&environment env - &rest var-val-pairs) + &rest var-val-pairs) (labels ((find-non-null (var) - ;; See whether there's any non-null thing here. Recurse - ;; if the list element is itself a list. - (do ((tail var)) ((not (consp tail)) tail) - (when (find-non-null (pop tail)) (return t)))) - (loop-desetq-internal (var val &optional temp) - ;; returns a list of actions to be performed - (typecase var - (null - (when (consp val) - ;; Don't lose possible side effects. - (if (eq (car val) 'prog1) - ;; These can come from PSETQ or DESETQ below. - ;; Throw away the value, keep the side effects. - ;; Special case is for handling an expanded POP. - (mapcan (lambda (x) - (and (consp x) - (or (not (eq (car x) 'car)) - (not (symbolp (cadr x))) - (not (symbolp (setq x (sb!xc:macroexpand x env))))) - (cons x nil))) - (cdr val)) - `(,val)))) - (cons - (let* ((car (car var)) - (cdr (cdr var)) - (car-non-null (find-non-null car)) - (cdr-non-null (find-non-null cdr))) - (when (or car-non-null cdr-non-null) - (if cdr-non-null - (let* ((temp-p temp) - (temp (or temp *loop-desetq-temporary*)) - (body `(,@(loop-desetq-internal car - `(car ,temp)) - (setq ,temp (cdr ,temp)) - ,@(loop-desetq-internal cdr - temp - temp)))) - (if temp-p - `(,@(unless (eq temp val) - `((setq ,temp ,val))) - ,@body) - `((let ((,temp ,val)) - ,@body)))) - ;; no CDRing to do - (loop-desetq-internal car `(car ,val) temp))))) - (otherwise - (unless (eq var val) - `((setq ,var ,val))))))) + ;; See whether there's any non-null thing here. Recurse + ;; if the list element is itself a list. + (do ((tail var)) ((not (consp tail)) tail) + (when (find-non-null (pop tail)) (return t)))) + (loop-desetq-internal (var val &optional temp) + ;; returns a list of actions to be performed + (typecase var + (null + (when (consp val) + ;; Don't lose possible side effects. + (if (eq (car val) 'prog1) + ;; These can come from PSETQ or DESETQ below. + ;; Throw away the value, keep the side effects. + ;; Special case is for handling an expanded POP. + (mapcan (lambda (x) + (and (consp x) + (or (not (eq (car x) 'car)) + (not (symbolp (cadr x))) + (not (symbolp (setq x (sb!xc:macroexpand x env))))) + (cons x nil))) + (cdr val)) + `(,val)))) + (cons + (let* ((car (car var)) + (cdr (cdr var)) + (car-non-null (find-non-null car)) + (cdr-non-null (find-non-null cdr))) + (when (or car-non-null cdr-non-null) + (if cdr-non-null + (let* ((temp-p temp) + (temp (or temp *loop-desetq-temporary*)) + (body `(,@(loop-desetq-internal car + `(car ,temp)) + (setq ,temp (cdr ,temp)) + ,@(loop-desetq-internal cdr + temp + temp)))) + (if temp-p + `(,@(unless (eq temp val) + `((setq ,temp ,val))) + ,@body) + `((let ((,temp ,val)) + ,@body)))) + ;; no CDRing to do + (loop-desetq-internal car `(car ,val) temp))))) + (otherwise + (unless (eq var val) + `((setq ,var ,val))))))) (do ((actions)) - ((null var-val-pairs) - (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions)))) + ((null var-val-pairs) + (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions)))) (setq actions (revappend - (loop-desetq-internal (pop var-val-pairs) - (pop var-val-pairs)) - actions))))) + (loop-desetq-internal (pop var-val-pairs) + (pop var-val-pairs)) + actions))))) ;;;; LOOP-local variables @@ -508,10 +508,10 @@ code to be loaded. (setq constant-value (eval new-form))) (when (and constantp expected-type) (unless (sb!xc:typep constant-value expected-type) - (loop-warn "~@" - form constant-value expected-type) - (setq constantp nil constant-value nil))) + form constant-value expected-type) + (setq constantp nil constant-value nil))) (values new-form constantp constant-value))) (defun loop-constantp (form) @@ -520,58 +520,58 @@ code to be loaded. ;;;; LOOP iteration optimization (defvar *loop-duplicate-code* - nil) + nil) (defvar *loop-iteration-flag-var* - (make-symbol "LOOP-NOT-FIRST-TIME")) + (make-symbol "LOOP-NOT-FIRST-TIME")) (defun loop-code-duplication-threshold (env) (declare (ignore env)) (let (;; If we could read optimization declaration information (as - ;; with the DECLARATION-INFORMATION function (present in - ;; CLTL2, removed from ANSI standard) we could set these - ;; values flexibly. Without DECLARATION-INFORMATION, we have - ;; to set them to constants. - ;; - ;; except FIXME: we've lost all pretence of portability, - ;; considering this instead an internal implementation, so - ;; we're free to couple to our own representation of the - ;; environment. - (speed 1) - (space 1)) + ;; with the DECLARATION-INFORMATION function (present in + ;; CLTL2, removed from ANSI standard) we could set these + ;; values flexibly. Without DECLARATION-INFORMATION, we have + ;; to set them to constants. + ;; + ;; except FIXME: we've lost all pretence of portability, + ;; considering this instead an internal implementation, so + ;; we're free to couple to our own representation of the + ;; environment. + (speed 1) + (space 1)) (+ 40 (* (- speed space) 10)))) (sb!int:defmacro-mundanely loop-body (&environment env - prologue - before-loop - main-body - after-loop - epilogue - &aux rbefore rafter flagvar) + prologue + before-loop + main-body + after-loop + epilogue + &aux rbefore rafter flagvar) (unless (= (length before-loop) (length after-loop)) (error "LOOP-BODY called with non-synched before- and after-loop lists")) ;;All our work is done from these copies, working backwards from the end: (setq rbefore (reverse before-loop) rafter (reverse after-loop)) (labels ((psimp (l) - (let ((ans nil)) - (dolist (x l) - (when x - (push x ans) - (when (and (consp x) - (member (car x) '(go return return-from))) - (return nil)))) - (nreverse ans))) - (pify (l) (if (null (cdr l)) (car l) `(progn ,@l))) - (makebody () - (let ((form `(tagbody - ,@(psimp (append prologue (nreverse rbefore))) - next-loop - ,@(psimp (append main-body - (nreconc rafter - `((go next-loop))))) - end-loop - ,@(psimp epilogue)))) - (if flagvar `(let ((,flagvar nil)) ,form) form)))) + (let ((ans nil)) + (dolist (x l) + (when x + (push x ans) + (when (and (consp x) + (member (car x) '(go return return-from))) + (return nil)))) + (nreverse ans))) + (pify (l) (if (null (cdr l)) (car l) `(progn ,@l))) + (makebody () + (let ((form `(tagbody + ,@(psimp (append prologue (nreverse rbefore))) + next-loop + ,@(psimp (append main-body + (nreconc rafter + `((go next-loop))))) + end-loop + ,@(psimp epilogue)))) + (if flagvar `(let ((,flagvar nil)) ,form) form)))) (when (or *loop-duplicate-code* (not rbefore)) (return-from loop-body (makebody))) ;; This outer loop iterates once for each not-first-time flag test @@ -581,8 +581,8 @@ code to be loaded. ;; Go backwards from the ends of before-loop and after-loop ;; merging all the equivalent forms into the body. (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter))))) - (push (pop rbefore) main-body) - (pop rafter)) + (push (pop rbefore) main-body) + (pop rafter)) (unless rbefore (return (makebody))) ;; The first forms in RBEFORE & RAFTER (which are the ;; chronologically last forms in the list) differ, therefore @@ -597,71 +597,71 @@ code to be loaded. ;; chronologically precedes the non-duplicatable form will be ;; handled the next time around the outer loop. (do ((bb rbefore (cdr bb)) - (aa rafter (cdr aa)) - (lastdiff nil) - (count 0) - (inc nil)) - ((null bb) (return-from loop-body (makebody))) ; Did it. - (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0)) - ((or (not (setq inc (estimate-code-size (car bb) env))) - (> (incf count inc) threshold)) - ;; Ok, we have found a non-duplicatable piece of code. - ;; Everything chronologically after it must be in the - ;; central body. Everything chronologically at and - ;; after LASTDIFF goes into the central body under a - ;; flag test. - (let ((then nil) (else nil)) - (do () (nil) - (push (pop rbefore) else) - (push (pop rafter) then) - (when (eq rbefore (cdr lastdiff)) (return))) - (unless flagvar - (push `(setq ,(setq flagvar *loop-iteration-flag-var*) - t) - else)) - (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else))) - main-body)) - ;; Everything chronologically before lastdiff until the - ;; non-duplicatable form (CAR BB) is the same in - ;; RBEFORE and RAFTER, so just copy it into the body. - (do () (nil) - (pop rafter) - (push (pop rbefore) main-body) - (when (eq rbefore (cdr bb)) (return))) - (return))))))) + (aa rafter (cdr aa)) + (lastdiff nil) + (count 0) + (inc nil)) + ((null bb) (return-from loop-body (makebody))) ; Did it. + (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0)) + ((or (not (setq inc (estimate-code-size (car bb) env))) + (> (incf count inc) threshold)) + ;; Ok, we have found a non-duplicatable piece of code. + ;; Everything chronologically after it must be in the + ;; central body. Everything chronologically at and + ;; after LASTDIFF goes into the central body under a + ;; flag test. + (let ((then nil) (else nil)) + (do () (nil) + (push (pop rbefore) else) + (push (pop rafter) then) + (when (eq rbefore (cdr lastdiff)) (return))) + (unless flagvar + (push `(setq ,(setq flagvar *loop-iteration-flag-var*) + t) + else)) + (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else))) + main-body)) + ;; Everything chronologically before lastdiff until the + ;; non-duplicatable form (CAR BB) is the same in + ;; RBEFORE and RAFTER, so just copy it into the body. + (do () (nil) + (pop rafter) + (push (pop rbefore) main-body) + (when (eq rbefore (cdr bb)) (return))) + (return))))))) (defun duplicatable-code-p (expr env) (if (null expr) 0 (let ((ans (estimate-code-size expr env))) - (declare (fixnum ans)) - ;; @@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to - ;; get an alist of optimize quantities back to help quantify - ;; how much code we are willing to duplicate. - ans))) + (declare (fixnum ans)) + ;; @@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to + ;; get an alist of optimize quantities back to help quantify + ;; how much code we are willing to duplicate. + ans))) (defvar *special-code-sizes* - '((return 0) (progn 0) - (null 1) (not 1) (eq 1) (car 1) (cdr 1) - (when 1) (unless 1) (if 1) - (caar 2) (cadr 2) (cdar 2) (cddr 2) - (caaar 3) (caadr 3) (cadar 3) (caddr 3) - (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3) - (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4) - (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4) - (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4) - (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4))) + '((return 0) (progn 0) + (null 1) (not 1) (eq 1) (car 1) (cdr 1) + (when 1) (unless 1) (if 1) + (caar 2) (cadr 2) (cdar 2) (cddr 2) + (caaar 3) (caadr 3) (cadar 3) (caddr 3) + (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3) + (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4) + (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4) + (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4) + (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4))) (defvar *estimate-code-size-punt* - '(block - do do* dolist - flet - labels lambda let let* locally - macrolet multiple-value-bind - prog prog* - symbol-macrolet - tagbody - unwind-protect - with-open-file)) + '(block + do do* dolist + flet + labels lambda let let* locally + macrolet multiple-value-bind + prog prog* + symbol-macrolet + tagbody + unwind-protect + with-open-file)) (defun destructuring-size (x) (do ((x x (cdr x)) (n 0 (+ (destructuring-size (car x)) n))) @@ -673,63 +673,63 @@ code to be loaded. (defun estimate-code-size-1 (x env) (flet ((list-size (l) - (let ((n 0)) - (declare (fixnum n)) - (dolist (x l n) (incf n (estimate-code-size-1 x env)))))) + (let ((n 0)) + (declare (fixnum n)) + (dolist (x l n) (incf n (estimate-code-size-1 x env)))))) ;;@@@@ ???? (declare (function list-size (list) fixnum)) (cond ((constantp x) 1) - ((symbolp x) (multiple-value-bind (new-form expanded-p) - (sb!xc:macroexpand-1 x env) - (if expanded-p - (estimate-code-size-1 new-form env) - 1))) - ((atom x) 1) ;; ??? self-evaluating??? - ((symbolp (car x)) - (let ((fn (car x)) (tem nil) (n 0)) - (declare (symbol fn) (fixnum n)) - (macrolet ((f (overhead &optional (args nil args-p)) - `(the fixnum (+ (the fixnum ,overhead) - (the fixnum - (list-size ,(if args-p - args - '(cdr x)))))))) - (cond ((setq tem (get fn 'estimate-code-size)) - (typecase tem - (fixnum (f tem)) - (t (funcall tem x env)))) - ((setq tem (assoc fn *special-code-sizes*)) - (f (second tem))) - ((eq fn 'cond) - (dolist (clause (cdr x) n) - (incf n (list-size clause)) (incf n))) - ((eq fn 'desetq) - (do ((l (cdr x) (cdr l))) ((null l) n) - (setq n (+ n - (destructuring-size (car l)) - (estimate-code-size-1 (cadr l) env))))) - ((member fn '(setq psetq)) - (do ((l (cdr x) (cdr l))) ((null l) n) - (setq n (+ n (estimate-code-size-1 (cadr l) env) 1)))) - ((eq fn 'go) 1) - ((eq fn 'function) - (if (sb!int:legal-fun-name-p (cadr x)) - 1 - ;; FIXME: This tag appears not to be present - ;; anywhere. - (throw 'duplicatable-code-p nil))) - ((eq fn 'multiple-value-setq) - (f (length (second x)) (cddr x))) - ((eq fn 'return-from) - (1+ (estimate-code-size-1 (third x) env))) - ((or (special-operator-p fn) - (member fn *estimate-code-size-punt*)) - (throw 'estimate-code-size nil)) - (t (multiple-value-bind (new-form expanded-p) - (sb!xc:macroexpand-1 x env) - (if expanded-p - (estimate-code-size-1 new-form env) - (f 3)))))))) - (t (throw 'estimate-code-size nil))))) + ((symbolp x) (multiple-value-bind (new-form expanded-p) + (sb!xc:macroexpand-1 x env) + (if expanded-p + (estimate-code-size-1 new-form env) + 1))) + ((atom x) 1) ;; ??? self-evaluating??? + ((symbolp (car x)) + (let ((fn (car x)) (tem nil) (n 0)) + (declare (symbol fn) (fixnum n)) + (macrolet ((f (overhead &optional (args nil args-p)) + `(the fixnum (+ (the fixnum ,overhead) + (the fixnum + (list-size ,(if args-p + args + '(cdr x)))))))) + (cond ((setq tem (get fn 'estimate-code-size)) + (typecase tem + (fixnum (f tem)) + (t (funcall tem x env)))) + ((setq tem (assoc fn *special-code-sizes*)) + (f (second tem))) + ((eq fn 'cond) + (dolist (clause (cdr x) n) + (incf n (list-size clause)) (incf n))) + ((eq fn 'desetq) + (do ((l (cdr x) (cdr l))) ((null l) n) + (setq n (+ n + (destructuring-size (car l)) + (estimate-code-size-1 (cadr l) env))))) + ((member fn '(setq psetq)) + (do ((l (cdr x) (cdr l))) ((null l) n) + (setq n (+ n (estimate-code-size-1 (cadr l) env) 1)))) + ((eq fn 'go) 1) + ((eq fn 'function) + (if (sb!int:legal-fun-name-p (cadr x)) + 1 + ;; FIXME: This tag appears not to be present + ;; anywhere. + (throw 'duplicatable-code-p nil))) + ((eq fn 'multiple-value-setq) + (f (length (second x)) (cddr x))) + ((eq fn 'return-from) + (1+ (estimate-code-size-1 (third x) env))) + ((or (special-operator-p fn) + (member fn *estimate-code-size-punt*)) + (throw 'estimate-code-size nil)) + (t (multiple-value-bind (new-form expanded-p) + (sb!xc:macroexpand-1 x env) + (if expanded-p + (estimate-code-size-1 new-form env) + (f 3)))))))) + (t (throw 'estimate-code-size nil))))) ;;;; loop errors @@ -739,27 +739,27 @@ code to be loaded. (defun loop-error (format-string &rest format-args) (error 'sb!int:simple-program-error - :format-control "~?~%current LOOP context:~{ ~S~}." - :format-arguments (list format-string format-args (loop-context)))) + :format-control "~?~%current LOOP context:~{ ~S~}." + :format-arguments (list format-string format-args (loop-context)))) (defun loop-warn (format-string &rest format-args) (warn "~?~%current LOOP context:~{ ~S~}." - format-string - format-args - (loop-context))) + format-string + format-args + (loop-context))) (defun loop-check-data-type (specified-type required-type - &optional (default-type required-type)) + &optional (default-type required-type)) (if (null specified-type) default-type (multiple-value-bind (a b) (sb!xc:subtypep specified-type required-type) - (cond ((not b) - (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S." - specified-type required-type)) - ((not a) - (loop-error "The specified data type ~S is not a subtype of ~S." - specified-type required-type))) - specified-type))) + (cond ((not b) + (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S." + specified-type required-type)) + ((not a) + (loop-error "The specified data type ~S is not a subtype of ~S." + specified-type required-type))) + specified-type))) (defun subst-gensyms-for-nil (tree) (declare (special *ignores*)) @@ -767,16 +767,16 @@ code to be loaded. ((null tree) (car (push (gensym "LOOP-IGNORED-VAR-") *ignores*))) ((atom tree) tree) (t (cons (subst-gensyms-for-nil (car tree)) - (subst-gensyms-for-nil (cdr tree)))))) - + (subst-gensyms-for-nil (cdr tree)))))) + (sb!int:defmacro-mundanely loop-destructuring-bind (lambda-list arg-list &rest body) (let ((*ignores* nil)) (declare (special *ignores*)) (let ((d-var-lambda-list (subst-gensyms-for-nil lambda-list))) `(destructuring-bind ,d-var-lambda-list - ,arg-list - (declare (ignore ,@*ignores*)) + ,arg-list + (declare (ignore ,@*ignores*)) ,@body)))) (defun loop-build-destructuring-bindings (crocks forms) @@ -786,85 +786,85 @@ code to be loaded. forms)) (defun loop-translate (*loop-source-code* - *loop-macro-environment* - *loop-universe*) + *loop-macro-environment* + *loop-universe*) (let ((*loop-original-source-code* *loop-source-code*) - (*loop-source-context* nil) - (*loop-vars* nil) - (*loop-named-vars* nil) - (*loop-declarations* nil) - (*loop-desetq-crocks* nil) - (*loop-bind-stack* nil) - (*loop-prologue* nil) - (*loop-wrappers* nil) - (*loop-before-loop* nil) - (*loop-body* nil) - (*loop-emitted-body* nil) - (*loop-after-body* nil) - (*loop-epilogue* nil) - (*loop-after-epilogue* nil) - (*loop-final-value-culprit* nil) - (*loop-inside-conditional* nil) - (*loop-when-it-var* nil) - (*loop-never-stepped-var* nil) - (*loop-names* nil) - (*loop-collection-cruft* nil)) + (*loop-source-context* nil) + (*loop-vars* nil) + (*loop-named-vars* nil) + (*loop-declarations* nil) + (*loop-desetq-crocks* nil) + (*loop-bind-stack* nil) + (*loop-prologue* nil) + (*loop-wrappers* nil) + (*loop-before-loop* nil) + (*loop-body* nil) + (*loop-emitted-body* nil) + (*loop-after-body* nil) + (*loop-epilogue* nil) + (*loop-after-epilogue* nil) + (*loop-final-value-culprit* nil) + (*loop-inside-conditional* nil) + (*loop-when-it-var* nil) + (*loop-never-stepped-var* nil) + (*loop-names* nil) + (*loop-collection-cruft* nil)) (loop-iteration-driver) (loop-bind-block) (let ((answer `(loop-body - ,(nreverse *loop-prologue*) - ,(nreverse *loop-before-loop*) - ,(nreverse *loop-body*) - ,(nreverse *loop-after-body*) - ,(nreconc *loop-epilogue* - (nreverse *loop-after-epilogue*))))) + ,(nreverse *loop-prologue*) + ,(nreverse *loop-before-loop*) + ,(nreverse *loop-body*) + ,(nreverse *loop-after-body*) + ,(nreconc *loop-epilogue* + (nreverse *loop-after-epilogue*))))) (dolist (entry *loop-bind-stack*) - (let ((vars (first entry)) - (dcls (second entry)) - (crocks (third entry)) - (wrappers (fourth entry))) - (dolist (w wrappers) - (setq answer (append w (list answer)))) - (when (or vars dcls crocks) - (let ((forms (list answer))) - ;;(when crocks (push crocks forms)) - (when dcls (push `(declare ,@dcls) forms)) - (setq answer `(,(if vars 'let 'locally) - ,vars - ,@(loop-build-destructuring-bindings crocks - forms))))))) + (let ((vars (first entry)) + (dcls (second entry)) + (crocks (third entry)) + (wrappers (fourth entry))) + (dolist (w wrappers) + (setq answer (append w (list answer)))) + (when (or vars dcls crocks) + (let ((forms (list answer))) + ;;(when crocks (push crocks forms)) + (when dcls (push `(declare ,@dcls) forms)) + (setq answer `(,(if vars 'let 'locally) + ,vars + ,@(loop-build-destructuring-bindings crocks + forms))))))) (do () (nil) - (setq answer `(block ,(pop *loop-names*) ,answer)) - (unless *loop-names* (return nil))) + (setq answer `(block ,(pop *loop-names*) ,answer)) + (unless *loop-names* (return nil))) answer))) (defun loop-iteration-driver () - (do () + (do () ((null *loop-source-code*)) (let ((keyword (car *loop-source-code*)) (tem nil)) (cond ((not (symbolp keyword)) - (loop-error "~S found where LOOP keyword expected" keyword)) - (t (setq *loop-source-context* *loop-source-code*) - (loop-pop-source) - (cond ((setq tem - (loop-lookup-keyword keyword - (loop-universe-keywords - *loop-universe*))) - ;; It's a "miscellaneous" toplevel LOOP keyword (DO, - ;; COLLECT, NAMED, etc.) - (apply (symbol-function (first tem)) (rest tem))) - ((setq tem - (loop-lookup-keyword keyword - (loop-universe-iteration-keywords *loop-universe*))) - (loop-hack-iteration tem)) - ((loop-tmember keyword '(and else)) - ;; The alternative is to ignore it, i.e. let it go - ;; around to the next keyword... - (loop-error "secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..." - keyword - (car *loop-source-code*) - (cadr *loop-source-code*))) - (t (loop-error "unknown LOOP keyword: ~S" keyword)))))))) + (loop-error "~S found where LOOP keyword expected" keyword)) + (t (setq *loop-source-context* *loop-source-code*) + (loop-pop-source) + (cond ((setq tem + (loop-lookup-keyword keyword + (loop-universe-keywords + *loop-universe*))) + ;; It's a "miscellaneous" toplevel LOOP keyword (DO, + ;; COLLECT, NAMED, etc.) + (apply (symbol-function (first tem)) (rest tem))) + ((setq tem + (loop-lookup-keyword keyword + (loop-universe-iteration-keywords *loop-universe*))) + (loop-hack-iteration tem)) + ((loop-tmember keyword '(and else)) + ;; The alternative is to ignore it, i.e. let it go + ;; around to the next keyword... + (loop-error "secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..." + keyword + (car *loop-source-code*) + (cadr *loop-source-code*))) + (t (loop-error "unknown LOOP keyword: ~S" keyword)))))))) (defun loop-pop-source () (if *loop-source-code* @@ -895,8 +895,8 @@ code to be loaded. (defun loop-pseudo-body (form) (cond ((or *loop-emitted-body* *loop-inside-conditional*) - (push form *loop-body*)) - (t (push form *loop-before-loop*) (push form *loop-after-body*)))) + (push form *loop-body*)) + (t (push form *loop-before-loop*) (push form *loop-after-body*)))) (defun loop-emit-body (form) (setq *loop-emitted-body* t) @@ -924,91 +924,91 @@ code to be loaded. (defun loop-typed-init (data-type &optional step-var-p) (when (and data-type (sb!xc:subtypep data-type 'number)) (if (or (sb!xc:subtypep data-type 'float) - (sb!xc:subtypep data-type '(complex float))) - (coerce (if step-var-p 1 0) data-type) - (if step-var-p 1 0)))) + (sb!xc:subtypep data-type '(complex float))) + (coerce (if step-var-p 1 0) data-type) + (if step-var-p 1 0)))) (defun loop-optional-type (&optional variable) ;; No variable specified implies that no destructuring is permissible. (and *loop-source-code* ; Don't get confused by NILs.. (let ((z (car *loop-source-code*))) - (cond ((loop-tequal z 'of-type) - ;; This is the syntactically unambigous form in that - ;; the form of the type specifier does not matter. - ;; Also, it is assumed that the type specifier is - ;; unambiguously, and without need of translation, a - ;; common lisp type specifier or pattern (matching the - ;; variable) thereof. - (loop-pop-source) - (loop-pop-source)) - - ((symbolp z) - ;; This is the (sort of) "old" syntax, even though we - ;; didn't used to support all of these type symbols. - (let ((type-spec (or (gethash z - (loop-universe-type-symbols - *loop-universe*)) - (gethash (symbol-name z) - (loop-universe-type-keywords - *loop-universe*))))) - (when type-spec - (loop-pop-source) - type-spec))) - (t - ;; This is our sort-of old syntax. But this is only - ;; valid for when we are destructuring, so we will be - ;; compulsive (should we really be?) and require that - ;; we in fact be doing variable destructuring here. We - ;; must translate the old keyword pattern typespec - ;; into a fully-specified pattern of real type - ;; specifiers here. - (if (consp variable) - (unless (consp z) - (loop-error - "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected" - z)) - (loop-error "~S found where a LOOP keyword or LOOP type keyword expected" z)) - (loop-pop-source) - (labels ((translate (k v) - (cond ((null k) nil) - ((atom k) - (replicate - (or (gethash k - (loop-universe-type-symbols - *loop-universe*)) - (gethash (symbol-name k) - (loop-universe-type-keywords - *loop-universe*)) - (loop-error - "The destructuring type pattern ~S contains the unrecognized type keyword ~S." - z k)) - v)) - ((atom v) - (loop-error - "The destructuring type pattern ~S doesn't match the variable pattern ~S." - z variable)) - (t (cons (translate (car k) (car v)) - (translate (cdr k) (cdr v)))))) - (replicate (typ v) - (if (atom v) - typ - (cons (replicate typ (car v)) - (replicate typ (cdr v)))))) - (translate z variable))))))) + (cond ((loop-tequal z 'of-type) + ;; This is the syntactically unambigous form in that + ;; the form of the type specifier does not matter. + ;; Also, it is assumed that the type specifier is + ;; unambiguously, and without need of translation, a + ;; common lisp type specifier or pattern (matching the + ;; variable) thereof. + (loop-pop-source) + (loop-pop-source)) + + ((symbolp z) + ;; This is the (sort of) "old" syntax, even though we + ;; didn't used to support all of these type symbols. + (let ((type-spec (or (gethash z + (loop-universe-type-symbols + *loop-universe*)) + (gethash (symbol-name z) + (loop-universe-type-keywords + *loop-universe*))))) + (when type-spec + (loop-pop-source) + type-spec))) + (t + ;; This is our sort-of old syntax. But this is only + ;; valid for when we are destructuring, so we will be + ;; compulsive (should we really be?) and require that + ;; we in fact be doing variable destructuring here. We + ;; must translate the old keyword pattern typespec + ;; into a fully-specified pattern of real type + ;; specifiers here. + (if (consp variable) + (unless (consp z) + (loop-error + "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected" + z)) + (loop-error "~S found where a LOOP keyword or LOOP type keyword expected" z)) + (loop-pop-source) + (labels ((translate (k v) + (cond ((null k) nil) + ((atom k) + (replicate + (or (gethash k + (loop-universe-type-symbols + *loop-universe*)) + (gethash (symbol-name k) + (loop-universe-type-keywords + *loop-universe*)) + (loop-error + "The destructuring type pattern ~S contains the unrecognized type keyword ~S." + z k)) + v)) + ((atom v) + (loop-error + "The destructuring type pattern ~S doesn't match the variable pattern ~S." + z variable)) + (t (cons (translate (car k) (car v)) + (translate (cdr k) (cdr v)))))) + (replicate (typ v) + (if (atom v) + typ + (cons (replicate typ (car v)) + (replicate typ (cdr v)))))) + (translate z variable))))))) ;;;; loop variables (defun loop-bind-block () (when (or *loop-vars* *loop-declarations* *loop-wrappers*) (push (list (nreverse *loop-vars*) - *loop-declarations* - *loop-desetq-crocks* - *loop-wrappers*) - *loop-bind-stack*) + *loop-declarations* + *loop-desetq-crocks* + *loop-wrappers*) + *loop-bind-stack*) (setq *loop-vars* nil - *loop-declarations* nil - *loop-desetq-crocks* nil - *loop-wrappers* nil))) + *loop-declarations* nil + *loop-desetq-crocks* nil + *loop-wrappers* nil))) (defun loop-var-p (name) (do ((entry *loop-bind-stack* (cdr entry))) @@ -1019,52 +1019,52 @@ code to be loaded. (defun loop-make-var (name initialization dtype &optional step-var-p) (cond ((null name) - (setq name (gensym "LOOP-IGNORE-")) - (push (list name initialization) *loop-vars*) - (if (null initialization) - (push `(ignore ,name) *loop-declarations*) - (loop-declare-var name dtype))) - ((atom name) + (setq name (gensym "LOOP-IGNORE-")) + (push (list name initialization) *loop-vars*) + (if (null initialization) + (push `(ignore ,name) *loop-declarations*) + (loop-declare-var name dtype))) + ((atom name) (when (or (assoc name *loop-vars*) (loop-var-p name)) (loop-error "duplicated variable ~S in a LOOP binding" name)) - (unless (symbolp name) - (loop-error "bad variable ~S somewhere in LOOP" name)) - (loop-declare-var name dtype step-var-p) - ;; We use ASSOC on this list to check for duplications (above), - ;; so don't optimize out this list: - (push (list name (or initialization (loop-typed-init dtype step-var-p))) - *loop-vars*)) - (initialization - (let ((newvar (gensym "LOOP-DESTRUCTURE-"))) + (unless (symbolp name) + (loop-error "bad variable ~S somewhere in LOOP" name)) + (loop-declare-var name dtype step-var-p) + ;; We use ASSOC on this list to check for duplications (above), + ;; so don't optimize out this list: + (push (list name (or initialization (loop-typed-init dtype step-var-p))) + *loop-vars*)) + (initialization + (let ((newvar (gensym "LOOP-DESTRUCTURE-"))) (loop-declare-var name dtype) (push (list newvar initialization) *loop-vars*) ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. (setq *loop-desetq-crocks* (list* name newvar *loop-desetq-crocks*)))) - (t (let ((tcar nil) (tcdr nil)) - (if (atom dtype) (setq tcar (setq tcdr dtype)) - (setq tcar (car dtype) tcdr (cdr dtype))) - (loop-make-var (car name) nil tcar) - (loop-make-var (cdr name) nil tcdr)))) + (t (let ((tcar nil) (tcdr nil)) + (if (atom dtype) (setq tcar (setq tcdr dtype)) + (setq tcar (car dtype) tcdr (cdr dtype))) + (loop-make-var (car name) nil tcar) + (loop-make-var (cdr name) nil tcdr)))) name) (defun loop-declare-var (name dtype &optional step-var-p) (cond ((or (null name) (null dtype) (eq dtype t)) nil) - ((symbolp name) - (unless (sb!xc:subtypep t dtype) - (let ((dtype (let ((init (loop-typed-init dtype step-var-p))) - (if (sb!xc:typep init dtype) - dtype - `(or (member ,init) ,dtype))))) - (push `(type ,dtype ,name) *loop-declarations*)))) - ((consp name) - (cond ((consp dtype) - (loop-declare-var (car name) (car dtype)) - (loop-declare-var (cdr name) (cdr dtype))) - (t (loop-declare-var (car name) dtype) - (loop-declare-var (cdr name) dtype)))) - (t (error "invalid LOOP variable passed in: ~S" name)))) + ((symbolp name) + (unless (sb!xc:subtypep t dtype) + (let ((dtype (let ((init (loop-typed-init dtype step-var-p))) + (if (sb!xc:typep init dtype) + dtype + `(or (member ,init) ,dtype))))) + (push `(type ,dtype ,name) *loop-declarations*)))) + ((consp name) + (cond ((consp dtype) + (loop-declare-var (car name) (car dtype)) + (loop-declare-var (cdr name) (cdr dtype))) + (t (loop-declare-var (car name) dtype) + (loop-declare-var (cdr name) dtype)))) + (t (error "invalid LOOP variable passed in: ~S" name)))) (defun loop-maybe-bind-form (form data-type) (if (loop-constantp form) @@ -1073,51 +1073,51 @@ code to be loaded. (defun loop-do-if (for negatep) (let ((form (loop-get-form)) - (*loop-inside-conditional* t) - (it-p nil) - (first-clause-p t)) + (*loop-inside-conditional* t) + (it-p nil) + (first-clause-p t)) (flet ((get-clause (for) - (do ((body nil)) (nil) - (let ((key (car *loop-source-code*)) (*loop-body* nil) data) - (cond ((not (symbolp key)) - (loop-error - "~S found where keyword expected getting LOOP clause after ~S" - key for)) - (t (setq *loop-source-context* *loop-source-code*) - (loop-pop-source) - (when (and (loop-tequal (car *loop-source-code*) 'it) - first-clause-p) - (setq *loop-source-code* - (cons (or it-p - (setq it-p - (loop-when-it-var))) - (cdr *loop-source-code*)))) - (cond ((or (not (setq data (loop-lookup-keyword - key (loop-universe-keywords *loop-universe*)))) - (progn (apply (symbol-function (car data)) - (cdr data)) - (null *loop-body*))) - (loop-error - "~S does not introduce a LOOP clause that can follow ~S." - key for)) - (t (setq body (nreconc *loop-body* body))))))) - (setq first-clause-p nil) - (if (loop-tequal (car *loop-source-code*) :and) - (loop-pop-source) - (return (if (cdr body) - `(progn ,@(nreverse body)) - (car body))))))) + (do ((body nil)) (nil) + (let ((key (car *loop-source-code*)) (*loop-body* nil) data) + (cond ((not (symbolp key)) + (loop-error + "~S found where keyword expected getting LOOP clause after ~S" + key for)) + (t (setq *loop-source-context* *loop-source-code*) + (loop-pop-source) + (when (and (loop-tequal (car *loop-source-code*) 'it) + first-clause-p) + (setq *loop-source-code* + (cons (or it-p + (setq it-p + (loop-when-it-var))) + (cdr *loop-source-code*)))) + (cond ((or (not (setq data (loop-lookup-keyword + key (loop-universe-keywords *loop-universe*)))) + (progn (apply (symbol-function (car data)) + (cdr data)) + (null *loop-body*))) + (loop-error + "~S does not introduce a LOOP clause that can follow ~S." + key for)) + (t (setq body (nreconc *loop-body* body))))))) + (setq first-clause-p nil) + (if (loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (return (if (cdr body) + `(progn ,@(nreverse body)) + (car body))))))) (let ((then (get-clause for)) - (else (when (loop-tequal (car *loop-source-code*) :else) - (loop-pop-source) - (list (get-clause :else))))) - (when (loop-tequal (car *loop-source-code*) :end) - (loop-pop-source)) - (when it-p (setq form `(setq ,it-p ,form))) - (loop-pseudo-body - `(if ,(if negatep `(not ,form) form) - ,then - ,@else)))))) + (else (when (loop-tequal (car *loop-source-code*) :else) + (loop-pop-source) + (list (get-clause :else))))) + (when (loop-tequal (car *loop-source-code*) :end) + (loop-pop-source)) + (when it-p (setq form `(setq ,it-p ,form))) + (loop-pseudo-body + `(if ,(if negatep `(not ,form) form) + ,then + ,@else)))))) (defun loop-do-initially () (loop-disallow-conditional :initially) @@ -1138,7 +1138,7 @@ code to be loaded. (loop-error "The NAMED ~S clause occurs too late." name)) (when *loop-names* (loop-error "You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S." - (car *loop-names*) name)) + (car *loop-names*) name)) (setq *loop-names* (list name)))) (defun loop-do-return () @@ -1147,8 +1147,8 @@ code to be loaded. ;;;; value accumulation: LIST (defstruct (loop-collector - (:copier nil) - (:predicate nil)) + (:copier nil) + (:predicate nil)) name class (history nil) @@ -1158,10 +1158,10 @@ code to be loaded. (defun loop-get-collection-info (collector class default-type) (let ((form (loop-get-form)) - (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type))) - (name (when (loop-tequal (car *loop-source-code*) 'into) - (loop-pop-source) - (loop-pop-source)))) + (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type))) + (name (when (loop-tequal (car *loop-source-code*) 'into) + (loop-pop-source) + (loop-pop-source)))) (when (not (symbolp name)) (loop-error "The value accumulation recipient name, ~S, is not a symbol." name)) (unless name @@ -1169,48 +1169,48 @@ code to be loaded. (unless dtype (setq dtype (or (loop-optional-type) default-type))) (let ((cruft (find (the symbol name) *loop-collection-cruft* - :key #'loop-collector-name))) + :key #'loop-collector-name))) (cond ((not cruft) - (when (and name (loop-var-p name)) - (loop-error "Variable ~S in INTO clause is a duplicate" name)) - (push (setq cruft (make-loop-collector - :name name :class class - :history (list collector) :dtype dtype)) - *loop-collection-cruft*)) - (t (unless (eq (loop-collector-class cruft) class) - (loop-error - "incompatible kinds of LOOP value accumulation specified for collecting~@ + (when (and name (loop-var-p name)) + (loop-error "Variable ~S in INTO clause is a duplicate" name)) + (push (setq cruft (make-loop-collector + :name name :class class + :history (list collector) :dtype dtype)) + *loop-collection-cruft*)) + (t (unless (eq (loop-collector-class cruft) class) + (loop-error + "incompatible kinds of LOOP value accumulation specified for collecting~@ ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S" - name (car (loop-collector-history cruft)) collector)) - (unless (equal dtype (loop-collector-dtype cruft)) - (loop-warn - "unequal datatypes specified in different LOOP value accumulations~@ + name (car (loop-collector-history cruft)) collector)) + (unless (equal dtype (loop-collector-dtype cruft)) + (loop-warn + "unequal datatypes specified in different LOOP value accumulations~@ into ~S: ~S and ~S" - name dtype (loop-collector-dtype cruft)) - (when (eq (loop-collector-dtype cruft) t) - (setf (loop-collector-dtype cruft) dtype))) - (push collector (loop-collector-history cruft)))) + name dtype (loop-collector-dtype cruft)) + (when (eq (loop-collector-dtype cruft) t) + (setf (loop-collector-dtype cruft) dtype))) + (push collector (loop-collector-history cruft)))) (values cruft form)))) -(defun loop-list-collection (specifically) ; NCONC, LIST, or APPEND +(defun loop-list-collection (specifically) ; NCONC, LIST, or APPEND (multiple-value-bind (lc form) (loop-get-collection-info specifically 'list 'list) (let ((tempvars (loop-collector-tempvars lc))) (unless tempvars - (setf (loop-collector-tempvars lc) - (setq tempvars (list* (gensym "LOOP-LIST-HEAD-") - (gensym "LOOP-LIST-TAIL-") - (and (loop-collector-name lc) - (list (loop-collector-name lc)))))) - (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*) - (unless (loop-collector-name lc) - (loop-emit-final-value `(loop-collect-answer ,(car tempvars) - ,@(cddr tempvars))))) + (setf (loop-collector-tempvars lc) + (setq tempvars (list* (gensym "LOOP-LIST-HEAD-") + (gensym "LOOP-LIST-TAIL-") + (and (loop-collector-name lc) + (list (loop-collector-name lc)))))) + (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*) + (unless (loop-collector-name lc) + (loop-emit-final-value `(loop-collect-answer ,(car tempvars) + ,@(cddr tempvars))))) (ecase specifically - (list (setq form `(list ,form))) - (nconc nil) - (append (unless (and (consp form) (eq (car form) 'list)) - (setq form `(copy-list ,form))))) + (list (setq form `(list ,form))) + (nconc nil) + (append (unless (and (consp form) (eq (car form) 'list)) + (setq form `(copy-list ,form))))) (loop-emit-body `(loop-collect-rplacd ,tempvars ,form))))) ;;;; value accumulation: MAX, MIN, SUM, COUNT @@ -1221,21 +1221,21 @@ code to be loaded. (loop-check-data-type (loop-collector-dtype lc) required-type) (let ((tempvars (loop-collector-tempvars lc))) (unless tempvars - (setf (loop-collector-tempvars lc) - (setq tempvars (list (loop-make-var - (or (loop-collector-name lc) - (gensym "LOOP-SUM-")) - nil (loop-collector-dtype lc))))) - (unless (loop-collector-name lc) - (loop-emit-final-value (car (loop-collector-tempvars lc))))) + (setf (loop-collector-tempvars lc) + (setq tempvars (list (loop-make-var + (or (loop-collector-name lc) + (gensym "LOOP-SUM-")) + nil (loop-collector-dtype lc))))) + (unless (loop-collector-name lc) + (loop-emit-final-value (car (loop-collector-tempvars lc))))) (loop-emit-body - (if (eq specifically 'count) - `(when ,form - (setq ,(car tempvars) - (1+ ,(car tempvars)))) - `(setq ,(car tempvars) - (+ ,(car tempvars) - ,form))))))) + (if (eq specifically 'count) + `(when ,form + (setq ,(car tempvars) + (1+ ,(car tempvars)))) + `(setq ,(car tempvars) + (+ ,(car tempvars) + ,form))))))) (defun loop-maxmin-collection (specifically) (multiple-value-bind (lc form) @@ -1243,18 +1243,18 @@ code to be loaded. (loop-check-data-type (loop-collector-dtype lc) 'real) (let ((data (loop-collector-data lc))) (unless data - (setf (loop-collector-data lc) - (setq data (make-loop-minimax - (or (loop-collector-name lc) - (gensym "LOOP-MAXMIN-")) - (loop-collector-dtype lc)))) - (unless (loop-collector-name lc) - (loop-emit-final-value (loop-minimax-answer-variable data)))) + (setf (loop-collector-data lc) + (setq data (make-loop-minimax + (or (loop-collector-name lc) + (gensym "LOOP-MAXMIN-")) + (loop-collector-dtype lc)))) + (unless (loop-collector-name lc) + (loop-emit-final-value (loop-minimax-answer-variable data)))) (loop-note-minimax-operation specifically data) (push `(with-minimax-value ,data) *loop-wrappers*) (loop-emit-body `(loop-accumulate-minimax-value ,data - ,specifically - ,form))))) + ,specifically + ,form))))) ;;;; value accumulation: aggregate booleans @@ -1266,7 +1266,7 @@ code to be loaded. (when restrictive (loop-disallow-conditional)) (loop-disallow-anonymous-collectors) (loop-emit-body `(,(if negate 'when 'unless) ,form - ,(loop-construct-return nil))) + ,(loop-construct-return nil))) (loop-emit-final-value t))) ;;; handling the THEREIS loop keyword @@ -1277,7 +1277,7 @@ code to be loaded. (loop-disallow-anonymous-collectors) (loop-emit-final-value) (loop-emit-body `(when (setq ,(loop-when-it-var) ,(loop-get-form)) - ,(loop-construct-return *loop-when-it-var*)))) + ,(loop-construct-return *loop-when-it-var*)))) (defun loop-do-while (negate kwd &aux (form (loop-get-form))) (loop-disallow-conditional kwd) @@ -1286,7 +1286,7 @@ code to be loaded. (defun loop-do-repeat () (loop-disallow-conditional :repeat) (let ((form (loop-get-form)) - (type 'integer)) + (type 'integer)) (let ((var (loop-make-var (gensym "LOOP-REPEAT-") `(ceiling ,form) type))) (push `(if (<= ,var 0) (go end-loop) (decf ,var)) *loop-before-loop*) (push `(if (<= ,var 0) (go end-loop) (decf ,var)) *loop-after-body*) @@ -1301,112 +1301,112 @@ code to be loaded. (defun loop-do-with () (loop-disallow-conditional :with) - (do ((var) (val) (dtype)) + (do ((var) (val) (dtype)) (nil) (setq var (loop-pop-source) - dtype (loop-optional-type var) - val (cond ((loop-tequal (car *loop-source-code*) :=) - (loop-pop-source) - (loop-get-form)) - (t nil))) + dtype (loop-optional-type var) + val (cond ((loop-tequal (car *loop-source-code*) :=) + (loop-pop-source) + (loop-get-form)) + (t nil))) (when (and var (loop-var-p var)) (loop-error "Variable ~S has already been used" var)) (loop-make-var var val dtype) (if (loop-tequal (car *loop-source-code*) :and) - (loop-pop-source) - (return (loop-bind-block))))) + (loop-pop-source) + (return (loop-bind-block))))) ;;;; the iteration driver (defun loop-hack-iteration (entry) (flet ((make-endtest (list-of-forms) - (cond ((null list-of-forms) nil) - ((member t list-of-forms) '(go end-loop)) - (t `(when ,(if (null (cdr (setq list-of-forms - (nreverse list-of-forms)))) - (car list-of-forms) - (cons 'or list-of-forms)) - (go end-loop)))))) + (cond ((null list-of-forms) nil) + ((member t list-of-forms) '(go end-loop)) + (t `(when ,(if (null (cdr (setq list-of-forms + (nreverse list-of-forms)))) + (car list-of-forms) + (cons 'or list-of-forms)) + (go end-loop)))))) (do ((pre-step-tests nil) - (steps nil) - (post-step-tests nil) - (pseudo-steps nil) - (pre-loop-pre-step-tests nil) - (pre-loop-steps nil) - (pre-loop-post-step-tests nil) - (pre-loop-pseudo-steps nil) - (tem) (data)) - (nil) + (steps nil) + (post-step-tests nil) + (pseudo-steps nil) + (pre-loop-pre-step-tests nil) + (pre-loop-steps nil) + (pre-loop-post-step-tests nil) + (pre-loop-pseudo-steps nil) + (tem) (data)) + (nil) ;; Note that we collect endtests in reverse order, but steps in correct ;; order. MAKE-ENDTEST does the nreverse for us. (setq tem (setq data - (apply (symbol-function (first entry)) (rest entry)))) + (apply (symbol-function (first entry)) (rest entry)))) (and (car tem) (push (car tem) pre-step-tests)) (setq steps (nconc steps (copy-list (car (setq tem (cdr tem)))))) (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests)) (setq pseudo-steps - (nconc pseudo-steps (copy-list (car (setq tem (cdr tem)))))) + (nconc pseudo-steps (copy-list (car (setq tem (cdr tem)))))) (setq tem (cdr tem)) (when *loop-emitted-body* - (loop-error "iteration in LOOP follows body code")) + (loop-error "iteration in LOOP follows body code")) (unless tem (setq tem data)) (when (car tem) (push (car tem) pre-loop-pre-step-tests)) ;; FIXME: This (SETF FOO (NCONC FOO BAR)) idiom appears often enough ;; that it might be worth making it into an NCONCF macro. (setq pre-loop-steps - (nconc pre-loop-steps (copy-list (car (setq tem (cdr tem)))))) + (nconc pre-loop-steps (copy-list (car (setq tem (cdr tem)))))) (when (car (setq tem (cdr tem))) - (push (car tem) pre-loop-post-step-tests)) + (push (car tem) pre-loop-post-step-tests)) (setq pre-loop-pseudo-steps - (nconc pre-loop-pseudo-steps (copy-list (cadr tem)))) + (nconc pre-loop-pseudo-steps (copy-list (cadr tem)))) (unless (loop-tequal (car *loop-source-code*) :and) - (setq *loop-before-loop* - (list* (loop-make-desetq pre-loop-pseudo-steps) - (make-endtest pre-loop-post-step-tests) - (loop-make-psetq pre-loop-steps) - (make-endtest pre-loop-pre-step-tests) - *loop-before-loop*)) - (setq *loop-after-body* - (list* (loop-make-desetq pseudo-steps) - (make-endtest post-step-tests) - (loop-make-psetq steps) - (make-endtest pre-step-tests) - *loop-after-body*)) - (loop-bind-block) - (return nil)) - (loop-pop-source) ; Flush the "AND". + (setq *loop-before-loop* + (list* (loop-make-desetq pre-loop-pseudo-steps) + (make-endtest pre-loop-post-step-tests) + (loop-make-psetq pre-loop-steps) + (make-endtest pre-loop-pre-step-tests) + *loop-before-loop*)) + (setq *loop-after-body* + (list* (loop-make-desetq pseudo-steps) + (make-endtest post-step-tests) + (loop-make-psetq steps) + (make-endtest pre-step-tests) + *loop-after-body*)) + (loop-bind-block) + (return nil)) + (loop-pop-source) ; Flush the "AND". (when (and (not (loop-universe-implicit-for-required *loop-universe*)) - (setq tem - (loop-lookup-keyword - (car *loop-source-code*) - (loop-universe-iteration-keywords *loop-universe*)))) - ;; The latest ANSI clarification is that the FOR/AS after the AND must - ;; NOT be supplied. - (loop-pop-source) - (setq entry tem))))) + (setq tem + (loop-lookup-keyword + (car *loop-source-code*) + (loop-universe-iteration-keywords *loop-universe*)))) + ;; The latest ANSI clarification is that the FOR/AS after the AND must + ;; NOT be supplied. + (loop-pop-source) + (setq entry tem))))) ;;;; main iteration drivers ;;; FOR variable keyword ..args.. (defun loop-do-for () (let* ((var (loop-pop-source)) - (data-type (loop-optional-type var)) - (keyword (loop-pop-source)) - (first-arg nil) - (tem nil)) + (data-type (loop-optional-type var)) + (keyword (loop-pop-source)) + (first-arg nil) + (tem nil)) (setq first-arg (loop-get-form)) (unless (and (symbolp keyword) - (setq tem (loop-lookup-keyword - keyword - (loop-universe-for-keywords *loop-universe*)))) + (setq tem (loop-lookup-keyword + keyword + (loop-universe-for-keywords *loop-universe*)))) (loop-error "~S is an unknown keyword in FOR or AS clause in LOOP." - keyword)) + keyword)) (apply (car tem) var first-arg data-type (cdr tem)))) (defun loop-when-it-var () (or *loop-when-it-var* (setq *loop-when-it-var* - (loop-make-var (gensym "LOOP-IT-") nil nil)))) + (loop-make-var (gensym "LOOP-IT-") nil nil)))) ;;;; various FOR/AS subdispatches @@ -1418,44 +1418,44 @@ code to be loaded. (defun loop-ansi-for-equals (var val data-type) (loop-make-var var nil data-type) (cond ((loop-tequal (car *loop-source-code*) :then) - ;; Then we are the same as "FOR x FIRST y THEN z". - (loop-pop-source) - `(() (,var ,(loop-get-form)) () () - () (,var ,val) () ())) - (t ;; We are the same as "FOR x = y". - `(() (,var ,val) () ())))) + ;; Then we are the same as "FOR x FIRST y THEN z". + (loop-pop-source) + `(() (,var ,(loop-get-form)) () () + () (,var ,val) () ())) + (t ;; We are the same as "FOR x = y". + `(() (,var ,val) () ())))) (defun loop-for-across (var val data-type) (loop-make-var var nil data-type) (let ((vector-var (gensym "LOOP-ACROSS-VECTOR-")) - (index-var (gensym "LOOP-ACROSS-INDEX-"))) + (index-var (gensym "LOOP-ACROSS-INDEX-"))) (multiple-value-bind (vector-form constantp vector-value) - (loop-constant-fold-if-possible val 'vector) + (loop-constant-fold-if-possible val 'vector) (loop-make-var - vector-var vector-form - (if (and (consp vector-form) (eq (car vector-form) 'the)) - (cadr vector-form) - 'vector)) + vector-var vector-form + (if (and (consp vector-form) (eq (car vector-form) 'the)) + (cadr vector-form) + 'vector)) (loop-make-var index-var 0 'fixnum) (let* ((length 0) - (length-form (cond ((not constantp) - (let ((v (gensym "LOOP-ACROSS-LIMIT-"))) - (push `(setq ,v (length ,vector-var)) - *loop-prologue*) - (loop-make-var v 0 'fixnum))) - (t (setq length (length vector-value))))) - (first-test `(>= ,index-var ,length-form)) - (other-test first-test) - (step `(,var (aref ,vector-var ,index-var))) - (pstep `(,index-var (1+ ,index-var)))) - (declare (fixnum length)) - (when constantp - (setq first-test (= length 0)) - (when (<= length 1) - (setq other-test t))) - `(,other-test ,step () ,pstep - ,@(and (not (eq first-test other-test)) - `(,first-test ,step () ,pstep))))))) + (length-form (cond ((not constantp) + (let ((v (gensym "LOOP-ACROSS-LIMIT-"))) + (push `(setq ,v (length ,vector-var)) + *loop-prologue*) + (loop-make-var v 0 'fixnum))) + (t (setq length (length vector-value))))) + (first-test `(>= ,index-var ,length-form)) + (other-test first-test) + (step `(,var (aref ,vector-var ,index-var))) + (pstep `(,index-var (1+ ,index-var)))) + (declare (fixnum length)) + (when constantp + (setq first-test (= length 0)) + (when (<= length 1) + (setq other-test t))) + `(,other-test ,step () ,pstep + ,@(and (not (eq first-test other-test)) + `(,first-test ,step () ,pstep))))))) ;;;; list iteration @@ -1468,46 +1468,46 @@ code to be loaded. ;; (FUNCALL 'FOO ...), not recognizing FOO may defeat some LOOP ;; optimizations. (let ((stepper (cond ((loop-tequal (car *loop-source-code*) :by) - (loop-pop-source) - (loop-get-form)) - (t '(function cdr))))) + (loop-pop-source) + (loop-get-form)) + (t '(function cdr))))) (cond ((and (consp stepper) (eq (car stepper) 'quote)) - (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.") - `(funcall ,stepper ,listvar)) - ((and (consp stepper) (eq (car stepper) 'function)) - (list (cadr stepper) listvar)) - (t - `(funcall ,(loop-make-var (gensym "LOOP-FN-") stepper 'function) - ,listvar))))) + (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.") + `(funcall ,stepper ,listvar)) + ((and (consp stepper) (eq (car stepper) 'function)) + (list (cadr stepper) listvar)) + (t + `(funcall ,(loop-make-var (gensym "LOOP-FN-") stepper 'function) + ,listvar))))) (defun loop-for-on (var val data-type) (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) (let ((listvar var)) (cond ((and var (symbolp var)) - (loop-make-var var list data-type)) - (t + (loop-make-var var list data-type)) + (t (loop-make-var (setq listvar (gensym)) list 't) (loop-make-var var nil data-type))) (let ((list-step (loop-list-step listvar))) - (let* ((first-endtest - ;; mysterious comment from original CMU CL sources: - ;; the following should use `atom' instead of `endp', - ;; per [bug2428] - `(atom ,listvar)) - (other-endtest first-endtest)) - (when (and constantp (listp list-value)) - (setq first-endtest (null list-value))) - (cond ((eq var listvar) - ;; The contour of the loop is different because we - ;; use the user's variable... - `(() (,listvar ,list-step) - ,other-endtest () () () ,first-endtest ())) - (t (let ((step `(,var ,listvar)) - (pseudo `(,listvar ,list-step))) - `(,other-endtest ,step () ,pseudo - ,@(and (not (eq first-endtest other-endtest)) - `(,first-endtest ,step () ,pseudo))))))))))) + (let* ((first-endtest + ;; mysterious comment from original CMU CL sources: + ;; the following should use `atom' instead of `endp', + ;; per [bug2428] + `(atom ,listvar)) + (other-endtest first-endtest)) + (when (and constantp (listp list-value)) + (setq first-endtest (null list-value))) + (cond ((eq var listvar) + ;; The contour of the loop is different because we + ;; use the user's variable... + `(() (,listvar ,list-step) + ,other-endtest () () () ,first-endtest ())) + (t (let ((step `(,var ,listvar)) + (pseudo `(,listvar ,list-step))) + `(,other-endtest ,step () ,pseudo + ,@(and (not (eq first-endtest other-endtest)) + `(,first-endtest ,step () ,pseudo))))))))))) (defun loop-for-in (var val data-type) (multiple-value-bind (list constantp list-value) @@ -1516,21 +1516,21 @@ code to be loaded. (loop-make-var var nil data-type) (loop-make-var listvar list 'list) (let ((list-step (loop-list-step listvar))) - (let* ((first-endtest `(endp ,listvar)) - (other-endtest first-endtest) - (step `(,var (car ,listvar))) - (pseudo-step `(,listvar ,list-step))) - (when (and constantp (listp list-value)) - (setq first-endtest (null list-value))) - `(,other-endtest ,step () ,pseudo-step - ,@(and (not (eq first-endtest other-endtest)) - `(,first-endtest ,step () ,pseudo-step)))))))) + (let* ((first-endtest `(endp ,listvar)) + (other-endtest first-endtest) + (step `(,var (car ,listvar))) + (pseudo-step `(,listvar ,list-step))) + (when (and constantp (listp list-value)) + (setq first-endtest (null list-value))) + `(,other-endtest ,step () ,pseudo-step + ,@(and (not (eq first-endtest other-endtest)) + `(,first-endtest ,step () ,pseudo-step)))))))) ;;;; iteration paths (defstruct (loop-path - (:copier nil) - (:predicate nil)) + (:copier nil) + (:predicate nil)) names preposition-groups inclusive-permitted @@ -1538,19 +1538,19 @@ code to be loaded. user-data) (defun add-loop-path (names function universe - &key preposition-groups inclusive-permitted user-data) + &key preposition-groups inclusive-permitted user-data) (declare (type loop-universe universe)) (unless (listp names) (setq names (list names))) (let ((ht (loop-universe-path-keywords universe)) - (lp (make-loop-path - :names (mapcar #'symbol-name names) - :function function - :user-data user-data - :preposition-groups (mapcar (lambda (x) - (if (listp x) x (list x))) - preposition-groups) - :inclusive-permitted inclusive-permitted))) + (lp (make-loop-path + :names (mapcar #'symbol-name names) + :function function + :user-data user-data + :preposition-groups (mapcar (lambda (x) + (if (listp x) x (list x))) + preposition-groups) + :inclusive-permitted inclusive-permitted))) (dolist (name names) (setf (gethash (symbol-name name) ht) lp)) lp)) @@ -1561,51 +1561,51 @@ code to be loaded. ;; FOR var BEING each/the pathname prep-phrases using-stuff... each/the = ;; EACH or THE. Not clear if it is optional, so I guess we'll warn. (let ((path nil) - (data nil) - (inclusive nil) - (stuff nil) - (initial-prepositions nil)) + (data nil) + (inclusive nil) + (stuff nil) + (initial-prepositions nil)) (cond ((loop-tmember val '(:each :the)) (setq path (loop-pop-source))) - ((loop-tequal (car *loop-source-code*) :and) - (loop-pop-source) - (setq inclusive t) - (unless (loop-tmember (car *loop-source-code*) - '(:its :each :his :her)) - (loop-error "~S was found where ITS or EACH expected in LOOP iteration path syntax." - (car *loop-source-code*))) - (loop-pop-source) - (setq path (loop-pop-source)) - (setq initial-prepositions `((:in ,val)))) - (t (loop-error "unrecognizable LOOP iteration path syntax: missing EACH or THE?"))) + ((loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (setq inclusive t) + (unless (loop-tmember (car *loop-source-code*) + '(:its :each :his :her)) + (loop-error "~S was found where ITS or EACH expected in LOOP iteration path syntax." + (car *loop-source-code*))) + (loop-pop-source) + (setq path (loop-pop-source)) + (setq initial-prepositions `((:in ,val)))) + (t (loop-error "unrecognizable LOOP iteration path syntax: missing EACH or THE?"))) (cond ((not (symbolp path)) - (loop-error - "~S was found where a LOOP iteration path name was expected." - path)) - ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*)))) - (loop-error "~S is not the name of a LOOP iteration path." path)) - ((and inclusive (not (loop-path-inclusive-permitted data))) - (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path))) + (loop-error + "~S was found where a LOOP iteration path name was expected." + path)) + ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*)))) + (loop-error "~S is not the name of a LOOP iteration path." path)) + ((and inclusive (not (loop-path-inclusive-permitted data))) + (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path))) (let ((fun (loop-path-function data)) - (preps (nconc initial-prepositions - (loop-collect-prepositional-phrases - (loop-path-preposition-groups data) - t))) - (user-data (loop-path-user-data data))) + (preps (nconc initial-prepositions + (loop-collect-prepositional-phrases + (loop-path-preposition-groups data) + t))) + (user-data (loop-path-user-data data))) (when (symbolp fun) (setq fun (symbol-function fun))) (setq stuff (if inclusive - (apply fun var data-type preps :inclusive t user-data) - (apply fun var data-type preps user-data)))) + (apply fun var data-type preps :inclusive t user-data) + (apply fun var data-type preps user-data)))) (when *loop-named-vars* (loop-error "Unused USING vars: ~S." *loop-named-vars*)) ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). ;; Protect the system from the user and the user from himself. (unless (member (length stuff) '(6 10)) (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length." - path)) + path)) (do ((l (car stuff) (cdr l)) (x)) ((null l)) (if (atom (setq x (car l))) - (loop-make-var x nil nil) - (loop-make-var (car x) (cadr x) (caddr x)))) + (loop-make-var x nil nil) + (loop-make-var (car x) (cadr x) (caddr x)))) (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*)) (cddr stuff))) @@ -1613,197 +1613,197 @@ code to be loaded. (let ((tem (loop-tassoc name *loop-named-vars*))) (declare (list tem)) (cond ((null tem) (values (gensym) nil)) - (t (setq *loop-named-vars* (delete tem *loop-named-vars*)) - (values (cdr tem) t))))) + (t (setq *loop-named-vars* (delete tem *loop-named-vars*)) + (values (cdr tem) t))))) (defun loop-collect-prepositional-phrases (preposition-groups - &optional - using-allowed - initial-phrases) + &optional + using-allowed + initial-phrases) (flet ((in-group-p (x group) (car (loop-tmember x group)))) (do ((token nil) - (prepositional-phrases initial-phrases) - (this-group nil nil) - (this-prep nil nil) - (disallowed-prepositions - (mapcan (lambda (x) - (copy-list - (find (car x) preposition-groups :test #'in-group-p))) - initial-phrases)) - (used-prepositions (mapcar #'car initial-phrases))) - ((null *loop-source-code*) (nreverse prepositional-phrases)) + (prepositional-phrases initial-phrases) + (this-group nil nil) + (this-prep nil nil) + (disallowed-prepositions + (mapcan (lambda (x) + (copy-list + (find (car x) preposition-groups :test #'in-group-p))) + initial-phrases)) + (used-prepositions (mapcar #'car initial-phrases))) + ((null *loop-source-code*) (nreverse prepositional-phrases)) (declare (symbol this-prep)) (setq token (car *loop-source-code*)) (dolist (group preposition-groups) - (when (setq this-prep (in-group-p token group)) - (return (setq this-group group)))) + (when (setq this-prep (in-group-p token group)) + (return (setq this-group group)))) (cond (this-group - (when (member this-prep disallowed-prepositions) - (loop-error - (if (member this-prep used-prepositions) - "A ~S prepositional phrase occurs multiply for some LOOP clause." - "Preposition ~S was used when some other preposition has subsumed it.") - token)) - (setq used-prepositions (if (listp this-group) - (append this-group used-prepositions) - (cons this-group used-prepositions))) - (loop-pop-source) - (push (list this-prep (loop-get-form)) prepositional-phrases)) - ((and using-allowed (loop-tequal token 'using)) - (loop-pop-source) - (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil) - (when (cadr z) - (if (setq tem (loop-tassoc (car z) *loop-named-vars*)) - (loop-error - "The variable substitution for ~S occurs twice in a USING phrase,~@ + (when (member this-prep disallowed-prepositions) + (loop-error + (if (member this-prep used-prepositions) + "A ~S prepositional phrase occurs multiply for some LOOP clause." + "Preposition ~S was used when some other preposition has subsumed it.") + token)) + (setq used-prepositions (if (listp this-group) + (append this-group used-prepositions) + (cons this-group used-prepositions))) + (loop-pop-source) + (push (list this-prep (loop-get-form)) prepositional-phrases)) + ((and using-allowed (loop-tequal token 'using)) + (loop-pop-source) + (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil) + (when (cadr z) + (if (setq tem (loop-tassoc (car z) *loop-named-vars*)) + (loop-error + "The variable substitution for ~S occurs twice in a USING phrase,~@ with ~S and ~S." - (car z) (cadr z) (cadr tem)) - (push (cons (car z) (cadr z)) *loop-named-vars*))) - (when (or (null *loop-source-code*) - (symbolp (car *loop-source-code*))) - (return nil)))) - (t (return (nreverse prepositional-phrases))))))) + (car z) (cadr z) (cadr tem)) + (push (cons (car z) (cadr z)) *loop-named-vars*))) + (when (or (null *loop-source-code*) + (symbolp (car *loop-source-code*))) + (return nil)))) + (t (return (nreverse prepositional-phrases))))))) ;;;; master sequencer function -(defun loop-sequencer (indexv indexv-type - variable variable-type - sequence-variable sequence-type - step-hack default-top - prep-phrases) +(defun loop-sequencer (indexv indexv-type + variable variable-type + sequence-variable sequence-type + step-hack default-top + prep-phrases) (let ((endform nil) ; form (constant or variable) with limit value - (sequencep nil) ; T if sequence arg has been provided - (testfn nil) ; endtest function - (test nil) ; endtest form - (stepby (1+ (or (loop-typed-init indexv-type) 0))) ; our increment - (stepby-constantp t) - (step nil) ; step form - (dir nil) ; direction of stepping: NIL, :UP, :DOWN - (inclusive-iteration nil) ; T if include last index - (start-given nil) ; T when prep phrase has specified start - (start-value nil) - (start-constantp nil) - (limit-given nil) ; T when prep phrase has specified end - (limit-constantp nil) - (limit-value nil) - ) + (sequencep nil) ; T if sequence arg has been provided + (testfn nil) ; endtest function + (test nil) ; endtest form + (stepby (1+ (or (loop-typed-init indexv-type) 0))) ; our increment + (stepby-constantp t) + (step nil) ; step form + (dir nil) ; direction of stepping: NIL, :UP, :DOWN + (inclusive-iteration nil) ; T if include last index + (start-given nil) ; T when prep phrase has specified start + (start-value nil) + (start-constantp nil) + (limit-given nil) ; T when prep phrase has specified end + (limit-constantp nil) + (limit-value nil) + ) (flet ((assert-index-for-arithmetic (index) - (unless (atom index) - (loop-error "Arithmetic index must be an atom.")))) + (unless (atom index) + (loop-error "Arithmetic index must be an atom.")))) (when variable (loop-make-var variable nil variable-type)) (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l)) - (setq prep (caar l) form (cadar l)) - (case prep - ((:of :in) - (setq sequencep t) - (loop-make-var sequence-variable form sequence-type)) - ((:from :downfrom :upfrom) - (setq start-given t) - (cond ((eq prep :downfrom) (setq dir ':down)) - ((eq prep :upfrom) (setq dir ':up))) - (multiple-value-setq (form start-constantp start-value) - (loop-constant-fold-if-possible form indexv-type)) - (assert-index-for-arithmetic indexv) - ;; KLUDGE: loop-make-var generates a temporary symbol for - ;; indexv if it is NIL. We have to use it to have the index - ;; actually count - (setq indexv (loop-make-var indexv form indexv-type))) - ((:upto :to :downto :above :below) - (cond ((loop-tequal prep :upto) (setq inclusive-iteration - (setq dir ':up))) - ((loop-tequal prep :to) (setq inclusive-iteration t)) - ((loop-tequal prep :downto) (setq inclusive-iteration - (setq dir ':down))) - ((loop-tequal prep :above) (setq dir ':down)) - ((loop-tequal prep :below) (setq dir ':up))) - (setq limit-given t) - (multiple-value-setq (form limit-constantp limit-value) - (loop-constant-fold-if-possible form `(and ,indexv-type real))) - (setq endform (if limit-constantp - `',limit-value - (loop-make-var - (gensym "LOOP-LIMIT-") form - `(and ,indexv-type real))))) - (:by - (multiple-value-setq (form stepby-constantp stepby) - (loop-constant-fold-if-possible form `(and ,indexv-type (real (0))))) - (unless stepby-constantp - (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-")) - form - `(and ,indexv-type (real (0))) - t))) - (t (loop-error - "~S invalid preposition in sequencing or sequence path;~@ + (setq prep (caar l) form (cadar l)) + (case prep + ((:of :in) + (setq sequencep t) + (loop-make-var sequence-variable form sequence-type)) + ((:from :downfrom :upfrom) + (setq start-given t) + (cond ((eq prep :downfrom) (setq dir ':down)) + ((eq prep :upfrom) (setq dir ':up))) + (multiple-value-setq (form start-constantp start-value) + (loop-constant-fold-if-possible form indexv-type)) + (assert-index-for-arithmetic indexv) + ;; KLUDGE: loop-make-var generates a temporary symbol for + ;; indexv if it is NIL. We have to use it to have the index + ;; actually count + (setq indexv (loop-make-var indexv form indexv-type))) + ((:upto :to :downto :above :below) + (cond ((loop-tequal prep :upto) (setq inclusive-iteration + (setq dir ':up))) + ((loop-tequal prep :to) (setq inclusive-iteration t)) + ((loop-tequal prep :downto) (setq inclusive-iteration + (setq dir ':down))) + ((loop-tequal prep :above) (setq dir ':down)) + ((loop-tequal prep :below) (setq dir ':up))) + (setq limit-given t) + (multiple-value-setq (form limit-constantp limit-value) + (loop-constant-fold-if-possible form `(and ,indexv-type real))) + (setq endform (if limit-constantp + `',limit-value + (loop-make-var + (gensym "LOOP-LIMIT-") form + `(and ,indexv-type real))))) + (:by + (multiple-value-setq (form stepby-constantp stepby) + (loop-constant-fold-if-possible form `(and ,indexv-type (real (0))))) + (unless stepby-constantp + (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-")) + form + `(and ,indexv-type (real (0))) + t))) + (t (loop-error + "~S invalid preposition in sequencing or sequence path;~@ maybe invalid prepositions were specified in iteration path descriptor?" - prep))) - (when (and odir dir (not (eq dir odir))) - (loop-error "conflicting stepping directions in LOOP sequencing path")) - (setq odir dir)) + prep))) + (when (and odir dir (not (eq dir odir))) + (loop-error "conflicting stepping directions in LOOP sequencing path")) + (setq odir dir)) (when (and sequence-variable (not sequencep)) - (loop-error "missing OF or IN phrase in sequence path")) + (loop-error "missing OF or IN phrase in sequence path")) ;; Now fill in the defaults. (if start-given - (when limit-given - ;; if both start and limit are given, they had better both - ;; be REAL. We already enforce the REALness of LIMIT, - ;; above; here's the KLUDGE to enforce the type of START. - (flet ((type-declaration-of (x) - (and (eq (car x) 'type) (caddr x)))) - (let ((decl (find indexv *loop-declarations* - :key #'type-declaration-of)) - (%decl (find indexv *loop-declarations* - :key #'type-declaration-of - :from-end t))) - (sb!int:aver (eq decl %decl)) - (setf (cadr decl) - `(and real ,(cadr decl)))))) - ;; default start - ;; DUPLICATE KLUDGE: loop-make-var generates a temporary - ;; symbol for indexv if it is NIL. See also the comment in - ;; the (:from :downfrom :upfrom) case - (progn - (assert-index-for-arithmetic indexv) - (setq indexv - (loop-make-var - indexv - (setq start-constantp t - start-value (or (loop-typed-init indexv-type) 0)) - `(and ,indexv-type real))))) + (when limit-given + ;; if both start and limit are given, they had better both + ;; be REAL. We already enforce the REALness of LIMIT, + ;; above; here's the KLUDGE to enforce the type of START. + (flet ((type-declaration-of (x) + (and (eq (car x) 'type) (caddr x)))) + (let ((decl (find indexv *loop-declarations* + :key #'type-declaration-of)) + (%decl (find indexv *loop-declarations* + :key #'type-declaration-of + :from-end t))) + (sb!int:aver (eq decl %decl)) + (setf (cadr decl) + `(and real ,(cadr decl)))))) + ;; default start + ;; DUPLICATE KLUDGE: loop-make-var generates a temporary + ;; symbol for indexv if it is NIL. See also the comment in + ;; the (:from :downfrom :upfrom) case + (progn + (assert-index-for-arithmetic indexv) + (setq indexv + (loop-make-var + indexv + (setq start-constantp t + start-value (or (loop-typed-init indexv-type) 0)) + `(and ,indexv-type real))))) (cond ((member dir '(nil :up)) - (when (or limit-given default-top) - (unless limit-given - (loop-make-var (setq endform (gensym "LOOP-SEQ-LIMIT-")) - nil - indexv-type) - (push `(setq ,endform ,default-top) *loop-prologue*)) - (setq testfn (if inclusive-iteration '> '>=))) - (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby)))) - (t (unless start-given - (unless default-top - (loop-error "don't know where to start stepping")) - (push `(setq ,indexv (1- ,default-top)) *loop-prologue*)) - (when (and default-top (not endform)) - (setq endform (loop-typed-init indexv-type) - inclusive-iteration t)) - (when endform (setq testfn (if inclusive-iteration '< '<=))) - (setq step - (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby))))) + (when (or limit-given default-top) + (unless limit-given + (loop-make-var (setq endform (gensym "LOOP-SEQ-LIMIT-")) + nil + indexv-type) + (push `(setq ,endform ,default-top) *loop-prologue*)) + (setq testfn (if inclusive-iteration '> '>=))) + (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby)))) + (t (unless start-given + (unless default-top + (loop-error "don't know where to start stepping")) + (push `(setq ,indexv (1- ,default-top)) *loop-prologue*)) + (when (and default-top (not endform)) + (setq endform (loop-typed-init indexv-type) + inclusive-iteration t)) + (when endform (setq testfn (if inclusive-iteration '< '<=))) + (setq step + (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby))))) (when testfn - (setq test - `(,testfn ,indexv ,endform))) + (setq test + `(,testfn ,indexv ,endform))) (when step-hack - (setq step-hack - `(,variable ,step-hack))) + (setq step-hack + `(,variable ,step-hack))) (let ((first-test test) (remaining-tests test)) - (when (and stepby-constantp start-constantp limit-constantp - (realp start-value) (realp limit-value)) - (when (setq first-test - (funcall (symbol-function testfn) - start-value - limit-value)) - (setq remaining-tests t))) - `(() (,indexv ,step) - ,remaining-tests ,step-hack () () ,first-test ,step-hack))))) + (when (and stepby-constantp start-constantp limit-constantp + (realp start-value) (realp limit-value)) + (when (setq first-test + (funcall (symbol-function testfn) + start-value + limit-value)) + (setq remaining-tests t))) + `(() (,indexv ,step) + ,remaining-tests ,step-hack () () ,first-test ,step-hack))))) ;;;; interfaces to the master sequencer @@ -1816,21 +1816,21 @@ code to be loaded. nil (list (list kwd val))))) (defun loop-sequence-elements-path (variable data-type prep-phrases - &key - fetch-function - size-function - sequence-type - element-type) + &key + fetch-function + size-function + sequence-type + element-type) (multiple-value-bind (indexv) (loop-named-var 'index) (let ((sequencev (loop-named-var 'sequence))) - (list* nil nil ; dummy bindings and prologue - (loop-sequencer - indexv 'fixnum - variable (or data-type element-type) - sequencev sequence-type - `(,fetch-function ,sequencev ,indexv) - `(,size-function ,sequencev) - prep-phrases))))) + (list* nil nil ; dummy bindings and prologue + (loop-sequencer + indexv 'fixnum + variable (or data-type element-type) + sequencev sequence-type + `(,fetch-function ,sequencev ,indexv) + `(,size-function ,sequencev) + prep-phrases))))) ;;;; builtin LOOP iteration paths @@ -1842,39 +1842,39 @@ code to be loaded. ||# (defun loop-hash-table-iteration-path (variable data-type prep-phrases - &key (which (sb!int:missing-arg))) + &key (which (sb!int:missing-arg))) (declare (type (member :hash-key :hash-value) which)) (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) - (loop-error "too many prepositions!")) - ((null prep-phrases) - (loop-error "missing OF or IN in ~S iteration path"))) + (loop-error "too many prepositions!")) + ((null prep-phrases) + (loop-error "missing OF or IN in ~S iteration path"))) (let ((ht-var (gensym "LOOP-HASHTAB-")) - (next-fn (gensym "LOOP-HASHTAB-NEXT-")) - (dummy-predicate-var nil) - (post-steps nil)) + (next-fn (gensym "LOOP-HASHTAB-NEXT-")) + (dummy-predicate-var nil) + (post-steps nil)) (multiple-value-bind (other-var other-p) - (loop-named-var (ecase which - (:hash-key 'hash-value) - (:hash-value 'hash-key))) + (loop-named-var (ecase which + (:hash-key 'hash-value) + (:hash-value 'hash-key))) ;; @@@@ LOOP-NAMED-VAR returns a second value of T if the name ;; was actually specified, so clever code can throw away the ;; GENSYM'ed-up variable if it isn't really needed. The ;; following is for those implementations in which we cannot put ;; dummy NILs into MULTIPLE-VALUE-SETQ variable lists. (setq other-p t - dummy-predicate-var (loop-when-it-var)) + dummy-predicate-var (loop-when-it-var)) (let* ((key-var nil) - (val-var nil) - (variable (or variable (gensym "LOOP-HASH-VAR-TEMP-"))) - (bindings `((,variable nil ,data-type) - (,ht-var ,(cadar prep-phrases)) - ,@(and other-p other-var `((,other-var nil)))))) - (ecase which - (:hash-key (setq key-var variable - val-var (and other-p other-var))) - (:hash-value (setq key-var (and other-p other-var) - val-var variable))) - (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*) + (val-var nil) + (variable (or variable (gensym "LOOP-HASH-VAR-TEMP-"))) + (bindings `((,variable nil ,data-type) + (,ht-var ,(cadar prep-phrases)) + ,@(and other-p other-var `((,other-var nil)))))) + (ecase which + (:hash-key (setq key-var variable + val-var (and other-p other-var))) + (:hash-value (setq key-var (and other-p other-var) + val-var variable))) + (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*) (when (or (consp key-var) data-type) (setq post-steps `(,key-var ,(setq key-var (gensym "LOOP-HASH-KEY-TEMP-")) @@ -1885,127 +1885,127 @@ code to be loaded. `(,val-var ,(setq val-var (gensym "LOOP-HASH-VAL-TEMP-")) ,@post-steps)) (push `(,val-var nil) bindings)) - `(,bindings ;bindings - () ;prologue - () ;pre-test - () ;parallel steps - (not (multiple-value-setq (,dummy-predicate-var ,key-var ,val-var) - (,next-fn))) ;post-test - ,post-steps))))) + `(,bindings ;bindings + () ;prologue + () ;pre-test + () ;parallel steps + (not (multiple-value-setq (,dummy-predicate-var ,key-var ,val-var) + (,next-fn))) ;post-test + ,post-steps))))) (defun loop-package-symbols-iteration-path (variable data-type prep-phrases - &key symbol-types) + &key symbol-types) (cond ((and prep-phrases (cdr prep-phrases)) - (loop-error "Too many prepositions!")) + (loop-error "Too many prepositions!")) ((and prep-phrases (not (member (caar prep-phrases) '(:in :of)))) (sb!int:bug "Unknown preposition ~S." (caar prep-phrases)))) (unless (symbolp variable) (loop-error "Destructuring is not valid for package symbol iteration.")) (let ((pkg-var (gensym "LOOP-PKGSYM-")) - (next-fn (gensym "LOOP-PKGSYM-NEXT-")) - (variable (or variable (gensym "LOOP-PKGSYM-VAR-"))) + (next-fn (gensym "LOOP-PKGSYM-NEXT-")) + (variable (or variable (gensym "LOOP-PKGSYM-VAR-"))) (package (or (cadar prep-phrases) '*package*))) (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) - *loop-wrappers*) + *loop-wrappers*) `(((,variable nil ,data-type) (,pkg-var ,package)) () () () (not (multiple-value-setq (,(loop-when-it-var) - ,variable) - (,next-fn))) + ,variable) + (,next-fn))) ()))) ;;;; ANSI LOOP (defun make-ansi-loop-universe (extended-p) (let ((w (make-standard-loop-universe - :keywords '((named (loop-do-named)) - (initially (loop-do-initially)) - (finally (loop-do-finally)) - (do (loop-do-do)) - (doing (loop-do-do)) - (return (loop-do-return)) - (collect (loop-list-collection list)) - (collecting (loop-list-collection list)) - (append (loop-list-collection append)) - (appending (loop-list-collection append)) - (nconc (loop-list-collection nconc)) - (nconcing (loop-list-collection nconc)) - (count (loop-sum-collection count - real - fixnum)) - (counting (loop-sum-collection count - real - fixnum)) - (sum (loop-sum-collection sum number number)) - (summing (loop-sum-collection sum number number)) - (maximize (loop-maxmin-collection max)) - (minimize (loop-maxmin-collection min)) - (maximizing (loop-maxmin-collection max)) - (minimizing (loop-maxmin-collection min)) - (always (loop-do-always t nil)) ; Normal, do always - (never (loop-do-always t t)) ; Negate test on always. - (thereis (loop-do-thereis t)) - (while (loop-do-while nil :while)) ; Normal, do while - (until (loop-do-while t :until)) ;Negate test on while - (when (loop-do-if when nil)) ; Normal, do when - (if (loop-do-if if nil)) ; synonymous - (unless (loop-do-if unless t)) ; Negate test on when - (with (loop-do-with)) + :keywords '((named (loop-do-named)) + (initially (loop-do-initially)) + (finally (loop-do-finally)) + (do (loop-do-do)) + (doing (loop-do-do)) + (return (loop-do-return)) + (collect (loop-list-collection list)) + (collecting (loop-list-collection list)) + (append (loop-list-collection append)) + (appending (loop-list-collection append)) + (nconc (loop-list-collection nconc)) + (nconcing (loop-list-collection nconc)) + (count (loop-sum-collection count + real + fixnum)) + (counting (loop-sum-collection count + real + fixnum)) + (sum (loop-sum-collection sum number number)) + (summing (loop-sum-collection sum number number)) + (maximize (loop-maxmin-collection max)) + (minimize (loop-maxmin-collection min)) + (maximizing (loop-maxmin-collection max)) + (minimizing (loop-maxmin-collection min)) + (always (loop-do-always t nil)) ; Normal, do always + (never (loop-do-always t t)) ; Negate test on always. + (thereis (loop-do-thereis t)) + (while (loop-do-while nil :while)) ; Normal, do while + (until (loop-do-while t :until)) ;Negate test on while + (when (loop-do-if when nil)) ; Normal, do when + (if (loop-do-if if nil)) ; synonymous + (unless (loop-do-if unless t)) ; Negate test on when + (with (loop-do-with)) (repeat (loop-do-repeat))) - :for-keywords '((= (loop-ansi-for-equals)) - (across (loop-for-across)) - (in (loop-for-in)) - (on (loop-for-on)) - (from (loop-for-arithmetic :from)) - (downfrom (loop-for-arithmetic :downfrom)) - (upfrom (loop-for-arithmetic :upfrom)) - (below (loop-for-arithmetic :below)) + :for-keywords '((= (loop-ansi-for-equals)) + (across (loop-for-across)) + (in (loop-for-in)) + (on (loop-for-on)) + (from (loop-for-arithmetic :from)) + (downfrom (loop-for-arithmetic :downfrom)) + (upfrom (loop-for-arithmetic :upfrom)) + (below (loop-for-arithmetic :below)) (above (loop-for-arithmetic :above)) - (to (loop-for-arithmetic :to)) - (upto (loop-for-arithmetic :upto)) - (downto (loop-for-arithmetic :downto)) - (by (loop-for-arithmetic :by)) - (being (loop-for-being))) - :iteration-keywords '((for (loop-do-for)) - (as (loop-do-for))) - :type-symbols '(array atom bignum bit bit-vector character - compiled-function complex cons double-float - fixnum float function hash-table integer - keyword list long-float nil null number - package pathname random-state ratio rational - readtable sequence short-float simple-array - simple-bit-vector simple-string simple-vector - single-float standard-char stream string - base-char symbol t vector) - :type-keywords nil - :ansi (if extended-p :extended t)))) + (to (loop-for-arithmetic :to)) + (upto (loop-for-arithmetic :upto)) + (downto (loop-for-arithmetic :downto)) + (by (loop-for-arithmetic :by)) + (being (loop-for-being))) + :iteration-keywords '((for (loop-do-for)) + (as (loop-do-for))) + :type-symbols '(array atom bignum bit bit-vector character + compiled-function complex cons double-float + fixnum float function hash-table integer + keyword list long-float nil null number + package pathname random-state ratio rational + readtable sequence short-float simple-array + simple-bit-vector simple-string simple-vector + single-float standard-char stream string + base-char symbol t vector) + :type-keywords nil + :ansi (if extended-p :extended t)))) (add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w - :preposition-groups '((:of :in)) - :inclusive-permitted nil - :user-data '(:which :hash-key)) + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:which :hash-key)) (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w - :preposition-groups '((:of :in)) - :inclusive-permitted nil - :user-data '(:which :hash-value)) + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:which :hash-value)) (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w - :preposition-groups '((:of :in)) - :inclusive-permitted nil - :user-data '(:symbol-types (:internal - :external - :inherited))) + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:internal + :external + :inherited))) (add-loop-path '(external-symbol external-symbols) - 'loop-package-symbols-iteration-path w - :preposition-groups '((:of :in)) - :inclusive-permitted nil - :user-data '(:symbol-types (:external))) + 'loop-package-symbols-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:external))) (add-loop-path '(present-symbol present-symbols) - 'loop-package-symbols-iteration-path w - :preposition-groups '((:of :in)) - :inclusive-permitted nil - :user-data '(:symbol-types (:internal - :external))) + 'loop-package-symbols-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:internal + :external))) w)) (defparameter *loop-ansi-universe* @@ -2015,7 +2015,7 @@ code to be loaded. (if (and keywords-and-forms (symbolp (car keywords-and-forms))) (loop-translate keywords-and-forms environment universe) (let ((tag (gensym))) - `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag)))))) + `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag)))))) (sb!int:defmacro-mundanely loop (&environment env &rest keywords-and-forms) (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*)) diff --git a/src/code/macroexpand.lisp b/src/code/macroexpand.lisp index 36ab43c..9a94350 100644 --- a/src/code/macroexpand.lisp +++ b/src/code/macroexpand.lisp @@ -35,35 +35,35 @@ fact, a macro. ENV is the lexical environment to expand in, which defaults to the null environment." (cond ((and (consp form) (symbolp (car form))) - (let ((def (sb!xc:macro-function (car form) env))) - (if def - (values (funcall sb!xc:*macroexpand-hook* - def - form - ;; As far as I can tell, it's not clear from - ;; the ANSI spec whether a MACRO-FUNCTION - ;; function needs to be prepared to handle - ;; NIL as a lexical environment. CMU CL - ;; passed NIL through to the MACRO-FUNCTION - ;; function, but I prefer SBCL "be conservative - ;; in what it sends and liberal in what it - ;; accepts" by doing the defaulting itself. - ;; -- WHN 19991128 - (coerce-to-lexenv env)) - t) - (values form nil)))) - ((symbolp form) - (let* ((venv (when env (sb!c::lexenv-vars env))) - (local-def (cdr (assoc form venv)))) - (cond ((and (consp local-def) - (eq (car local-def) 'macro)) - (values (cdr local-def) t)) - ((eq (info :variable :kind form) :macro) - (values (info :variable :macro-expansion form) t)) - (t - (values form nil))))) - (t - (values form nil)))) + (let ((def (sb!xc:macro-function (car form) env))) + (if def + (values (funcall sb!xc:*macroexpand-hook* + def + form + ;; As far as I can tell, it's not clear from + ;; the ANSI spec whether a MACRO-FUNCTION + ;; function needs to be prepared to handle + ;; NIL as a lexical environment. CMU CL + ;; passed NIL through to the MACRO-FUNCTION + ;; function, but I prefer SBCL "be conservative + ;; in what it sends and liberal in what it + ;; accepts" by doing the defaulting itself. + ;; -- WHN 19991128 + (coerce-to-lexenv env)) + t) + (values form nil)))) + ((symbolp form) + (let* ((venv (when env (sb!c::lexenv-vars env))) + (local-def (cdr (assoc form venv)))) + (cond ((and (consp local-def) + (eq (car local-def) 'macro)) + (values (cdr local-def) t)) + ((eq (info :variable :kind form) :macro) + (values (info :variable :macro-expansion form) t)) + (t + (values form nil))))) + (t + (values form nil)))) (defun sb!xc:macroexpand (form &optional env) #!+sb-doc @@ -72,9 +72,9 @@ lexical environment to expand in, or NIL (the default) for the null environment." (labels ((frob (form expanded) - (multiple-value-bind (new-form newly-expanded-p) - (sb!xc:macroexpand-1 form env) - (if newly-expanded-p - (frob new-form t) - (values new-form expanded))))) + (multiple-value-bind (new-form newly-expanded-p) + (sb!xc:macroexpand-1 form env) + (if newly-expanded-p + (frob new-form t) + (values new-form expanded))))) (frob form nil))) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 0b23bac..b860377 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -32,19 +32,19 @@ `(do () (,test-form) (assert-error ',test-form ',places ,datum ,@arguments) ,@(mapcar (lambda (place) - `(setf ,place (assert-prompt ',place ,place))) - places))) + `(setf ,place (assert-prompt ',place ,place))) + places))) (defun assert-prompt (name value) (cond ((y-or-n-p "The old value of ~S is ~S.~ ~%Do you want to supply a new value? " - name value) - (format *query-io* "~&Type a form to be evaluated:~%") - (flet ((read-it () (eval (read *query-io*)))) - (if (symbolp name) ;help user debug lexical variables - (progv (list name) (list value) (read-it)) - (read-it)))) - (t value))) + name value) + (format *query-io* "~&Type a form to be evaluated:~%") + (flet ((read-it () (eval (read *query-io*)))) + (if (symbolp name) ;help user debug lexical variables + (progv (list name) (list value) (read-it)) + (read-it)))) + (t value))) ;;; CHECK-TYPE is written this way, to call CHECK-TYPE-ERROR, because ;;; of how closures are compiled. RESTART-CASE has forms with closures @@ -64,9 +64,9 @@ invoked. In that case it will store into PLACE and start over." (let ((place-value (gensym))) `(do ((,place-value ,place ,place)) - ((typep ,place-value ',type)) + ((typep ,place-value ',type)) (setf ,place - (check-type-error ',place ,place-value ',type ,type-string))))) + (check-type-error ',place ,place-value ',type ,type-string))))) ;;;; DEFINE-SYMBOL-MACRO @@ -77,9 +77,9 @@ (defun sb!c::%define-symbol-macro (name expansion) (unless (symbolp name) (error 'simple-type-error :datum name :expected-type 'symbol - :format-control "Symbol macro name is not a symbol: ~S." - :format-arguments (list name))) - (with-single-package-locked-error + :format-control "Symbol macro name is not a symbol: ~S." + :format-arguments (list name))) + (with-single-package-locked-error (:symbol name "defining ~A as a symbol-macro")) (ecase (info :variable :kind name) ((:macro :global nil) @@ -87,12 +87,12 @@ (setf (info :variable :macro-expansion name) expansion)) (:special (error 'simple-program-error - :format-control "Symbol macro name already declared special: ~S." - :format-arguments (list name))) + :format-control "Symbol macro name already declared special: ~S." + :format-arguments (list name))) (:constant (error 'simple-program-error - :format-control "Symbol macro name already declared constant: ~S." - :format-arguments (list name)))) + :format-control "Symbol macro name already declared constant: ~S." + :format-arguments (list name)))) name) ;;;; DEFINE-COMPILER-MACRO @@ -119,17 +119,17 @@ "defining compiler macro of (SETF ...), which will not be expanded")) (when (and (symbolp name) (special-operator-p name)) (error 'simple-program-error - :format-control "cannot define a compiler-macro for a special operator: ~S" - :format-arguments (list name))) + :format-control "cannot define a compiler-macro for a special operator: ~S" + :format-arguments (list name))) (with-unique-names (whole environment) (multiple-value-bind (body local-decs doc) - (parse-defmacro lambda-list whole body name 'define-compiler-macro - :environment environment) + (parse-defmacro lambda-list whole body name 'define-compiler-macro + :environment environment) (let ((def `(lambda (,whole ,environment) - ,@local-decs - ,body)) - (debug-name (sb!c::debug-name 'compiler-macro-function name))) - `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@local-decs + ,body)) + (debug-name (sb!c::debug-name 'compiler-macro-function name))) + `(eval-when (:compile-toplevel :load-toplevel :execute) (sb!c::%define-compiler-macro ',name #',def ',lambda-list @@ -141,31 +141,31 @@ ;;; bits of logic should be shared (notably arglist setting). (macrolet ((def (times set-p) - `(eval-when (,@times) - (defun sb!c::%define-compiler-macro - (name definition lambda-list doc debug-name) - ,@(unless set-p - '((declare (ignore lambda-list debug-name)))) - ;; FIXME: warn about incompatible lambda list with - ;; respect to parent function? - (setf (sb!xc:compiler-macro-function name) definition) - ;; FIXME: Add support for (SETF FDOCUMENTATION) when - ;; object is a list and type is COMPILER-MACRO. (Until - ;; then, we have to discard any compiler macro - ;; documentation for (SETF FOO).) - (unless (listp name) - (setf (fdocumentation name 'compiler-macro) doc)) - ,(when set-p - `(case (widetag-of definition) + `(eval-when (,@times) + (defun sb!c::%define-compiler-macro + (name definition lambda-list doc debug-name) + ,@(unless set-p + '((declare (ignore lambda-list debug-name)))) + ;; FIXME: warn about incompatible lambda list with + ;; respect to parent function? + (setf (sb!xc:compiler-macro-function name) definition) + ;; FIXME: Add support for (SETF FDOCUMENTATION) when + ;; object is a list and type is COMPILER-MACRO. (Until + ;; then, we have to discard any compiler macro + ;; documentation for (SETF FOO).) + (unless (listp name) + (setf (fdocumentation name 'compiler-macro) doc)) + ,(when set-p + `(case (widetag-of definition) (#.sb!vm:closure-header-widetag (setf (%simple-fun-arglist (%closure-fun definition)) lambda-list - (%simple-fun-name (%closure-fun definition)) - debug-name)) + (%simple-fun-name (%closure-fun definition)) + debug-name)) (#.sb!vm:simple-fun-header-widetag (setf (%simple-fun-arglist definition) lambda-list - (%simple-fun-name definition) debug-name)))) - name)))) + (%simple-fun-name definition) debug-name)))) + name)))) (progn (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil) #-sb-xc (def (:compile-toplevel) nil))) @@ -190,57 +190,57 @@ (unless (or cases (not needcasesp)) (warn "no clauses in ~S" name)) (let ((keyform-value (gensym)) - (clauses ()) - (keys ())) + (clauses ()) + (keys ())) (do* ((cases cases (cdr cases)) - (case (car cases) (car cases))) - ((null cases) nil) + (case (car cases) (car cases))) + ((null cases) nil) (unless (list-of-length-at-least-p case 1) - (error "~S -- bad clause in ~S" case name)) + (error "~S -- bad clause in ~S" case name)) (destructuring-bind (keyoid &rest forms) case - (cond (;; an OTHERWISE-CLAUSE - ;; - ;; By the way... The old code here tried gave - ;; STYLE-WARNINGs for normal-clauses which looked as - ;; though they might've been intended to be - ;; otherwise-clauses. As Tony Martinez reported on - ;; sbcl-devel 2004-11-09 there are sometimes good - ;; reasons to write clauses like that; and as I noticed - ;; when trying to understand the old code so I could - ;; understand his patch, trying to guess which clauses - ;; don't have good reasons is fundamentally kind of a - ;; mess. SBCL does issue style warnings rather - ;; enthusiastically, and I have often justified that by - ;; arguing that we're doing that to detect issues which - ;; are tedious for programmers to detect for by - ;; proofreading (like small typoes in long symbol - ;; names, or duplicate function definitions in large - ;; files). This doesn't seem to be an issue like that, - ;; and I can't think of a comparably good justification - ;; for giving STYLE-WARNINGs for legal code here, so - ;; now we just hope the programmer knows what he's - ;; doing. -- WHN 2004-11-20 - (and (not errorp) ; possible only in CASE or TYPECASE, - ; not in [EC]CASE or [EC]TYPECASE - (memq keyoid '(t otherwise)) - (null (cdr cases))) - (push `(t nil ,@forms) clauses)) - ((and multi-p (listp keyoid)) - (setf keys (append keyoid keys)) - (push `((or ,@(mapcar (lambda (key) - `(,test ,keyform-value ',key)) - keyoid)) - nil - ,@forms) - clauses)) - (t - (push keyoid keys) - (push `((,test ,keyform-value ',keyoid) - nil - ,@forms) - clauses))))) + (cond (;; an OTHERWISE-CLAUSE + ;; + ;; By the way... The old code here tried gave + ;; STYLE-WARNINGs for normal-clauses which looked as + ;; though they might've been intended to be + ;; otherwise-clauses. As Tony Martinez reported on + ;; sbcl-devel 2004-11-09 there are sometimes good + ;; reasons to write clauses like that; and as I noticed + ;; when trying to understand the old code so I could + ;; understand his patch, trying to guess which clauses + ;; don't have good reasons is fundamentally kind of a + ;; mess. SBCL does issue style warnings rather + ;; enthusiastically, and I have often justified that by + ;; arguing that we're doing that to detect issues which + ;; are tedious for programmers to detect for by + ;; proofreading (like small typoes in long symbol + ;; names, or duplicate function definitions in large + ;; files). This doesn't seem to be an issue like that, + ;; and I can't think of a comparably good justification + ;; for giving STYLE-WARNINGs for legal code here, so + ;; now we just hope the programmer knows what he's + ;; doing. -- WHN 2004-11-20 + (and (not errorp) ; possible only in CASE or TYPECASE, + ; not in [EC]CASE or [EC]TYPECASE + (memq keyoid '(t otherwise)) + (null (cdr cases))) + (push `(t nil ,@forms) clauses)) + ((and multi-p (listp keyoid)) + (setf keys (append keyoid keys)) + (push `((or ,@(mapcar (lambda (key) + `(,test ,keyform-value ',key)) + keyoid)) + nil + ,@forms) + clauses)) + (t + (push keyoid keys) + (push `((,test ,keyform-value ',keyoid) + nil + ,@forms) + clauses))))) (case-body-aux name keyform keyform-value clauses keys errorp proceedp - `(,(if multi-p 'member 'or) ,@keys)))) + `(,(if multi-p 'member 'or) ,@keys)))) ;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled ;;; all the cases. Note: it is not necessary that the resulting code @@ -253,34 +253,34 @@ ;;; The CASE-BODY-ERROR function is defined later, when the ;;; RESTART-CASE macro has been defined. (defun case-body-aux (name keyform keyform-value clauses keys - errorp proceedp expected-type) + errorp proceedp expected-type) (if proceedp (let ((block (gensym)) - (again (gensym))) - `(let ((,keyform-value ,keyform)) - (block ,block - (tagbody - ,again - (return-from - ,block - (cond ,@(nreverse clauses) - (t - (setf ,keyform-value - (setf ,keyform - (case-body-error - ',name ',keyform ,keyform-value - ',expected-type ',keys))) - (go ,again)))))))) + (again (gensym))) + `(let ((,keyform-value ,keyform)) + (block ,block + (tagbody + ,again + (return-from + ,block + (cond ,@(nreverse clauses) + (t + (setf ,keyform-value + (setf ,keyform + (case-body-error + ',name ',keyform ,keyform-value + ',expected-type ',keys))) + (go ,again)))))))) `(let ((,keyform-value ,keyform)) - (declare (ignorable ,keyform-value)) ; e.g. (CASE KEY (T)) - (cond - ,@(nreverse clauses) - ,@(if errorp - `((t (error 'case-failure - :name ',name - :datum ,keyform-value - :expected-type ',expected-type - :possibilities ',keys)))))))) + (declare (ignorable ,keyform-value)) ; e.g. (CASE KEY (T)) + (cond + ,@(nreverse clauses) + ,@(if errorp + `((t (error 'case-failure + :name ',name + :datum ,keyform-value + :expected-type ',expected-type + :possibilities ',keys)))))))) ) ; EVAL-WHEN (defmacro-mundanely case (keyform &body cases) @@ -333,50 +333,50 @@ (parse-body forms-decls :doc-string-allowed nil) (let ((abortp (gensym))) `(let ((,var ,stream) - (,abortp t)) - ,@decls - (unwind-protect - (multiple-value-prog1 - (progn ,@forms) - (setq ,abortp nil)) - (when ,var - (close ,var :abort ,abortp))))))) + (,abortp t)) + ,@decls + (unwind-protect + (multiple-value-prog1 + (progn ,@forms) + (setq ,abortp nil)) + (when ,var + (close ,var :abort ,abortp))))))) (defmacro-mundanely with-open-file ((stream filespec &rest options) - &body body) + &body body) `(with-open-stream (,stream (open ,filespec ,@options)) ,@body)) (defmacro-mundanely with-input-from-string ((var string &key index start end) - &body forms-decls) + &body forms-decls) (multiple-value-bind (forms decls) (parse-body forms-decls :doc-string-allowed nil) ;; The ONCE-ONLY inhibits compiler note for unreachable code when ;; END is true. (once-only ((string string)) `(let ((,var - ,(cond ((null end) - `(make-string-input-stream ,string ,(or start 0))) - ((symbolp end) - `(if ,end - (make-string-input-stream ,string - ,(or start 0) - ,end) - (make-string-input-stream ,string - ,(or start 0)))) - (t - `(make-string-input-stream ,string - ,(or start 0) - ,end))))) - ,@decls - (multiple-value-prog1 - (unwind-protect - (progn ,@forms) - (close ,var)) - ,@(when index - `((setf ,index (string-input-stream-current ,var))))))))) + ,(cond ((null end) + `(make-string-input-stream ,string ,(or start 0))) + ((symbolp end) + `(if ,end + (make-string-input-stream ,string + ,(or start 0) + ,end) + (make-string-input-stream ,string + ,(or start 0)))) + (t + `(make-string-input-stream ,string + ,(or start 0) + ,end))))) + ,@decls + (multiple-value-prog1 + (unwind-protect + (progn ,@forms) + (close ,var)) + ,@(when index + `((setf ,index (string-input-stream-current ,var))))))))) -(defmacro-mundanely with-output-to-string +(defmacro-mundanely with-output-to-string ((var &optional string &key (element-type ''character)) &body forms-decls) (multiple-value-bind (forms decls) @@ -389,16 +389,16 @@ ;; but it still has to be evaluated for side-effects. (,element-type-var ,element-type)) (declare (ignore ,element-type-var)) - ,@decls + ,@decls (unwind-protect (progn ,@forms) (close ,var)))) `(let ((,var (make-string-output-stream :element-type ,element-type))) - ,@decls - (unwind-protect - (progn ,@forms) - (close ,var)) - (get-output-stream-string ,var))))) + ,@decls + (unwind-protect + (progn ,@forms) + (close ,var)) + (get-output-stream-string ,var))))) ;;;; miscellaneous macros @@ -415,21 +415,21 @@ ;; hairy. (if (integerp n) (let ((dummy-list nil) - (keeper (gensym "KEEPER-"))) - ;; We build DUMMY-LIST, a list of variables to bind to useless - ;; values, then we explicitly IGNORE those bindings and return - ;; KEEPER, the only thing we're really interested in right now. - (dotimes (i n) - (push (gensym "IGNORE-") dummy-list)) - `(multiple-value-bind (,@dummy-list ,keeper) ,form - (declare (ignore ,@dummy-list)) - ,keeper)) + (keeper (gensym "KEEPER-"))) + ;; We build DUMMY-LIST, a list of variables to bind to useless + ;; values, then we explicitly IGNORE those bindings and return + ;; KEEPER, the only thing we're really interested in right now. + (dotimes (i n) + (push (gensym "IGNORE-") dummy-list)) + `(multiple-value-bind (,@dummy-list ,keeper) ,form + (declare (ignore ,@dummy-list)) + ,keeper)) (once-only ((n n)) - `(case (the fixnum ,n) - (0 (nth-value 0 ,form)) - (1 (nth-value 1 ,form)) - (2 (nth-value 2 ,form)) - (t (nth (the fixnum ,n) (multiple-value-list ,form))))))) + `(case (the fixnum ,n) + (0 (nth-value 0 ,form)) + (1 (nth-value 1 ,form)) + (2 (nth-value 2 ,form)) + (t (nth (the fixnum ,n) (multiple-value-list ,form))))))) (defmacro-mundanely declaim (&rest specs) #!+sb-doc @@ -437,17 +437,17 @@ Do a declaration or declarations for the global environment." `(eval-when (:compile-toplevel :load-toplevel :execute) ,@(mapcar (lambda (spec) `(sb!xc:proclaim ',spec)) - specs))) + specs))) (defmacro-mundanely print-unreadable-object ((object stream &key type identity) - &body body) + &body body) "Output OBJECT to STREAM with \"#<\" prefix, \">\" suffix, optionally with object-type prefix and object-identity suffix, and executing the code in BODY to provide possible further output." `(%print-unreadable-object ,object ,stream ,type ,identity - ,(if body - `(lambda () ,@body) - nil))) + ,(if body + `(lambda () ,@body) + nil))) (defmacro-mundanely ignore-errors (&rest forms) #!+sb-doc diff --git a/src/code/mips-vm.lisp b/src/code/mips-vm.lisp index 541bb35..4da2a83 100644 --- a/src/code/mips-vm.lisp +++ b/src/code/mips-vm.lisp @@ -20,23 +20,23 @@ (error "Unaligned instruction? offset=#x~X." offset)) (sb!sys:without-gcing (let ((sap (truly-the system-area-pointer - (%primitive sb!c::code-instructions code)))) + (%primitive sb!c::code-instructions code)))) (ecase kind (:jump - (aver (zerop (ash value -28))) - (setf (ldb (byte 26 0) (sap-ref-32 sap offset)) - (ash value -2))) + (aver (zerop (ash value -28))) + (setf (ldb (byte 26 0) (sap-ref-32 sap offset)) + (ash value -2))) (:lui - (setf (sap-ref-16 sap - #!+little-endian offset - #!-little-endian (+ offset 2)) - (+ (ash value -16) - (if (logbitp 15 value) 1 0)))) + (setf (sap-ref-16 sap + #!+little-endian offset + #!-little-endian (+ offset 2)) + (+ (ash value -16) + (if (logbitp 15 value) 1 0)))) (:addi - (setf (sap-ref-16 sap - #!+little-endian offset - #!-little-endian (+ offset 2)) - (ldb (byte 16 0) value))))))) + (setf (sap-ref-16 sap + #!+little-endian offset + #!-little-endian (+ offset 2)) + (ldb (byte 16 0) value))))))) (define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int) @@ -51,10 +51,10 @@ ;; binary-compatible with 64-bit mode. Since there appears not to ;; be ALIEN support for 64-bit return values, we have to do the ;; hacky pointer arithmetic thing. -- CSR, 2002-09-01 - (int-sap (deref (context-pc-addr context) - #!-little-endian 1 - ;; Untested - #!+little-endian 0))) + (int-sap (deref (context-pc-addr context) + #!-little-endian 1 + ;; Untested + #!+little-endian 0))) (define-alien-routine ("os_context_register_addr" context-register-addr) (* unsigned-int) @@ -69,16 +69,16 @@ ;;; (Are they used in anything time-critical, or just the debugger?) (defun context-register (context index) (declare (type (alien (* os-context-t)) context)) - (deref (context-register-addr context index) - #!-little-endian 1 - #!+little-endian 0)) + (deref (context-register-addr context index) + #!-little-endian 1 + #!+little-endian 0)) (defun %set-context-register (context index new) (declare (type (alien (* os-context-t)) context)) - (setf (deref (context-register-addr context index) - #!-little-endian 1 - #!+little-endian 0) - new)) + (setf (deref (context-register-addr context index) + #!-little-endian 1 + #!+little-endian 0) + new)) #!+linux ;;; For now. @@ -93,13 +93,13 @@ ;;; ;;; Given the sigcontext, extract the internal error arguments from the ;;; instruction stream. -;;; +;;; (defun internal-error-args (context) (declare (type (alien (* os-context-t)) context)) (/show0 "entering INTERNAL-ERROR-ARGS, CONTEXT=..") (/hexstr context) (let ((pc (context-pc context)) - (cause (context-bd-cause-int context))) + (cause (context-bd-cause-int context))) (declare (type system-area-pointer pc)) (/show0 "got PC=..") (/hexstr (sap-int pc)) @@ -111,24 +111,24 @@ (/show0 "now PC=..") (/hexstr (sap-int pc)) (let* ((length (sap-ref-8 pc 4)) - (vector (make-array length :element-type '(unsigned-byte 8)))) + (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (type (unsigned-byte 8) length) - (type (simple-array (unsigned-byte 8) (*)) vector)) + (type (simple-array (unsigned-byte 8) (*)) vector)) (/show0 "LENGTH,VECTOR,ERROR-NUMBER=..") (/hexstr length) (/hexstr vector) (copy-ub8-from-system-area pc 5 vector 0 length) (let* ((index 0) - (error-number (sb!c:read-var-integer vector index))) - (/hexstr error-number) - (collect ((sc-offsets)) - (loop - (/show0 "INDEX=..") - (/hexstr index) - (when (>= index length) - (return)) - (sc-offsets (sb!c:read-var-integer vector index))) - (values error-number (sc-offsets))))))) + (error-number (sb!c:read-var-integer vector index))) + (/hexstr error-number) + (collect ((sc-offsets)) + (loop + (/show0 "INDEX=..") + (/hexstr index) + (when (>= index length) + (return)) + (sc-offsets (sb!c:read-var-integer vector index))) + (values error-number (sc-offsets))))))) diff --git a/src/code/mipsstrops.lisp b/src/code/mipsstrops.lisp index 6f98979..42708c6 100644 --- a/src/code/mipsstrops.lisp +++ b/src/code/mipsstrops.lisp @@ -18,62 +18,62 @@ ;;; the shorter is a prefix of the longer, the length of the shorter + ;;; START1 is returned. The arguments must be simple strings. ;;; -;;; This would be done on the Vax with CMPC3. +;;; This would be done on the Vax with CMPC3. (defun %sp-string-compare (string1 start1 end1 string2 start2 end2) (declare (simple-string string1 string2)) (declare (fixnum start1 end1 start2 end2)) (let ((len1 (- end1 start1)) - (len2 (- end2 start2))) + (len2 (- end2 start2))) (declare (fixnum len1 len2)) (cond ((= len1 len2) (do ((index1 start1 (1+ index1)) - (index2 start2 (1+ index2))) - ((= index1 end1) nil) - (declare (fixnum index1 index2)) - (if (char/= (schar string1 index1) (schar string2 index2)) - (return index1)))) + (index2 start2 (1+ index2))) + ((= index1 end1) nil) + (declare (fixnum index1 index2)) + (if (char/= (schar string1 index1) (schar string2 index2)) + (return index1)))) ((> len1 len2) (do ((index1 start1 (1+ index1)) - (index2 start2 (1+ index2))) - ((= index2 end2) index1) - (declare (fixnum index1 index2)) - (if (char/= (schar string1 index1) (schar string2 index2)) - (return index1)))) + (index2 start2 (1+ index2))) + ((= index2 end2) index1) + (declare (fixnum index1 index2)) + (if (char/= (schar string1 index1) (schar string2 index2)) + (return index1)))) (t (do ((index1 start1 (1+ index1)) - (index2 start2 (1+ index2))) - ((= index1 end1) index1) - (declare (fixnum index1 index2)) - (if (char/= (schar string1 index1) (schar string2 index2)) - (return index1))))))) + (index2 start2 (1+ index2))) + ((= index1 end1) index1) + (declare (fixnum index1 index2)) + (if (char/= (schar string1 index1) (schar string2 index2)) + (return index1))))))) ;;; like %SP-STRING-COMPARE, only backwards (defun %sp-reverse-string-compare (string1 start1 end1 string2 start2 end2) (declare (simple-string string1 string2)) (declare (fixnum start1 end1 start2 end2)) (let ((len1 (- end1 start1)) - (len2 (- end2 start2))) + (len2 (- end2 start2))) (declare (fixnum len1 len2)) (cond ((= len1 len2) (do ((index1 (1- end1) (1- index1)) - (index2 (1- end2) (1- index2))) - ((< index1 start1) nil) - (declare (fixnum index1 index2)) - (if (char/= (schar string1 index1) (schar string2 index2)) - (return index1)))) + (index2 (1- end2) (1- index2))) + ((< index1 start1) nil) + (declare (fixnum index1 index2)) + (if (char/= (schar string1 index1) (schar string2 index2)) + (return index1)))) ((> len1 len2) (do ((index1 (1- end1) (1- index1)) - (index2 (1- end2) (1- index2))) - ((< index2 start2) index1) - (declare (fixnum index1 index2)) - (if (char/= (schar string1 index1) (schar string2 index2)) - (return index1)))) + (index2 (1- end2) (1- index2))) + ((< index2 start2) index1) + (declare (fixnum index1 index2)) + (if (char/= (schar string1 index1) (schar string2 index2)) + (return index1)))) (t (do ((index1 (1- end1) (1- index1)) - (index2 (1- end2) (1- index2))) - ((< index1 start1) index1) - (declare (fixnum index1 index2)) - (if (char/= (schar string1 index1) (schar string2 index2)) - (return index1))))))) + (index2 (1- end2) (1- index2))) + ((< index1 start1) index1) + (declare (fixnum index1 index2)) + (if (char/= (schar string1 index1) (schar string2 index2)) + (return index1))))))) diff --git a/src/code/module.lisp b/src/code/module.lisp index db40773..c21efc4 100644 --- a/src/code/module.lisp +++ b/src/code/module.lisp @@ -38,12 +38,12 @@ (defun require-error (control &rest arguments) (error 'extension-failure - :format-control control - :format-arguments arguments - :references - (list - '(:sbcl :variable *module-provider-functions*) - '(:sbcl :function require)))) + :format-control control + :format-arguments arguments + :references + (list + '(:sbcl :variable *module-provider-functions*) + '(:sbcl :function require)))) (defun require (module-name &optional pathnames) #!+sb-doc @@ -59,19 +59,19 @@ (require-error "~@" 'require module-name)) (let ((saved-modules (copy-list *modules*)) - (*requiring* (cons name *requiring*))) + (*requiring* (cons name *requiring*))) (unless (member name *modules* :test #'string=) - (cond (pathnames - (unless (listp pathnames) (setf pathnames (list pathnames))) - ;; ambiguity in standard: should we try all pathnames in the - ;; list, or should we stop as soon as one of them calls PROVIDE? - (dolist (ele pathnames t) - (load ele))) - (t - (unless (some (lambda (p) (funcall p module-name)) - *module-provider-functions*) - (require-error "Don't know how to ~S ~A." - 'require module-name))))) + (cond (pathnames + (unless (listp pathnames) (setf pathnames (list pathnames))) + ;; ambiguity in standard: should we try all pathnames in the + ;; list, or should we stop as soon as one of them calls PROVIDE? + (dolist (ele pathnames t) + (load ele))) + (t + (unless (some (lambda (p) (funcall p module-name)) + *module-provider-functions*) + (require-error "Don't know how to ~S ~A." + 'require module-name))))) (set-difference *modules* saved-modules)))) @@ -81,22 +81,22 @@ "Stringify and downcase NAME, then attempt to load the file $SBCL_HOME/name/name" (let* ((filesys-name (string-downcase (string name))) - (unadorned-path - (merge-pathnames - (make-pathname :directory (list :relative filesys-name) - :name filesys-name) - (truename (posix-getenv "SBCL_HOME")))) - (fasl-path (merge-pathnames - (make-pathname :type *fasl-file-type*) - unadorned-path)) - (lisp-path (merge-pathnames (make-pathname :type "lisp") - unadorned-path))) + (unadorned-path + (merge-pathnames + (make-pathname :directory (list :relative filesys-name) + :name filesys-name) + (truename (posix-getenv "SBCL_HOME")))) + (fasl-path (merge-pathnames + (make-pathname :type *fasl-file-type*) + unadorned-path)) + (lisp-path (merge-pathnames (make-pathname :type "lisp") + unadorned-path))) ;; KLUDGE: there's a race condition here; the file we probe could ;; be removed by the time we get round to trying to load it. ;; Maybe factor out the logic in the LOAD guesser as to which file ;; was meant, so that we can use it here on open streams instead? (when (or (probe-file unadorned-path) - (probe-file fasl-path) - (probe-file lisp-path)) + (probe-file fasl-path) + (probe-file lisp-path)) (load unadorned-path) t))) diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp index 7f14f40..ded1ab7 100644 --- a/src/code/ntrace.lisp +++ b/src/code/ntrace.lisp @@ -42,10 +42,10 @@ ;;; A TRACE-INFO object represents all the information we need to ;;; trace a given function. (def!struct (trace-info - (:make-load-form-fun sb-kernel:just-dump-it-normally) - (:print-object (lambda (x stream) - (print-unreadable-object (x stream :type t) - (prin1 (trace-info-what x) stream))))) + (:make-load-form-fun sb-kernel:just-dump-it-normally) + (:print-object (lambda (x stream) + (print-unreadable-object (x stream :type t) + (prin1 (trace-info-what x) stream))))) ;; the original representation of the thing traced (what nil :type (or function cons symbol)) ;; Is WHAT a function name whose definition we should track? @@ -62,7 +62,7 @@ (wherein nil :type list) ;; should we trace methods given a generic function to trace? (methods nil) - + ;; The following slots represent the forms that we are supposed to ;; evaluate on each iteration. Each form is represented by a cons ;; (Form . Function), where the Function is the cached result of @@ -119,19 +119,19 @@ (defun trace-fdefinition (x) (multiple-value-bind (res named-p) (typecase x - (symbol - (cond ((special-operator-p x) - (error "can't trace special form ~S" x)) - ((macro-function x)) - (t - (values (fdefinition x) t)))) - (function x) - (t (values (fdefinition x) t))) + (symbol + (cond ((special-operator-p x) + (error "can't trace special form ~S" x)) + ((macro-function x)) + (t + (values (fdefinition x) t)))) + (function x) + (t (values (fdefinition x) t))) (case (sb-kernel:widetag-of res) (#.sb-vm:closure-header-widetag (values (sb-kernel:%closure-fun res) - named-p - :compiled-closure)) + named-p + :compiled-closure)) (#.sb-vm:funcallable-instance-header-widetag (values res named-p :funcallable-instance)) (t (values res named-p :compiled))))) @@ -141,10 +141,10 @@ (defun trace-redefined-update (fname new-value) (when (fboundp fname) (let* ((fun (trace-fdefinition fname)) - (info (gethash fun *traced-funs*))) + (info (gethash fun *traced-funs*))) (when (and info (trace-info-named info)) - (untrace-1 fname) - (trace-1 fname info new-value))))) + (untrace-1 fname) + (trace-1 fname info new-value))))) (push #'trace-redefined-update *setf-fdefinition-hook*) ;;; Annotate a FORM to evaluate with pre-converted functions. FORM is @@ -155,28 +155,28 @@ (when form (let ((exp (car form))) (if (sb-di:code-location-p loc) - (let ((fun (sb-di:preprocess-for-eval exp loc))) + (let ((fun (sb-di:preprocess-for-eval exp loc))) (declare (type function fun)) - (cons exp - (lambda (frame) - (let ((*current-frame* frame)) - (funcall fun frame))))) - (let* ((bod (ecase loc - ((nil) exp) - (:encapsulated - `(locally (declare (disable-package-locks sb-debug:arg arg-list)) + (cons exp + (lambda (frame) + (let ((*current-frame* frame)) + (funcall fun frame))))) + (let* ((bod (ecase loc + ((nil) exp) + (:encapsulated + `(locally (declare (disable-package-locks sb-debug:arg arg-list)) (flet ((sb-debug:arg (n) (declare (special arg-list)) (elt arg-list n))) (declare (ignorable #'sb-debug:arg) (enable-package-locks sb-debug:arg arg-list)) ,exp))))) - (fun (coerce `(lambda () ,bod) 'function))) - (cons exp - (lambda (frame) - (declare (ignore frame)) - (let ((*current-frame* nil)) - (funcall fun))))))))) + (fun (coerce `(lambda () ,bod) 'function))) + (cons exp + (lambda (frame) + (declare (ignore frame)) + (let ((*current-frame* nil)) + (funcall fun))))))))) (defun coerce-form-list (forms loc) (mapcar (lambda (x) (coerce-form x loc)) forms)) @@ -188,19 +188,19 @@ (dolist (entry *traced-entries*) (when (cdr entry) (incf depth))) (format t - "~V,0@T~W: " - (+ (mod (* depth *trace-indentation-step*) - (- *max-trace-indentation* *trace-indentation-step*)) - *trace-indentation-step*) - depth))) + "~V,0@T~W: " + (+ (mod (* depth *trace-indentation-step*) + (- *max-trace-indentation* *trace-indentation-step*)) + *trace-indentation-step*) + depth))) ;;; Return true if any of the NAMES appears on the stack below FRAME. (defun trace-wherein-p (frame names) (do ((frame (sb-di:frame-down frame) (sb-di:frame-down frame))) ((not frame) nil) (when (member (sb-di:debug-fun-name (sb-di:frame-debug-fun frame)) - names - :test #'equal) + names + :test #'equal) (return t)))) ;;; Handle PRINT and PRINT-AFTER options. @@ -217,8 +217,8 @@ (sb-di:flush-frames-above frame) (let ((*stack-top-hint* frame)) (break "breaking ~A traced call to ~S:" - where - (trace-info-what info))))) + where + (trace-info-what info))))) ;;; Discard any invalid cookies on our simulated stack. Encapsulated ;;; entries are always valid, since we bind *TRACED-ENTRIES* in the @@ -226,9 +226,9 @@ (defun discard-invalid-entries (frame) (loop (when (or (null *traced-entries*) - (let ((cookie (caar *traced-entries*))) - (or (not cookie) - (sb-di:fun-end-cookie-valid-p frame cookie)))) + (let ((cookie (caar *traced-entries*))) + (or (not cookie) + (sb-di:fun-end-cookie-valid-p frame cookie)))) (return)) (pop *traced-entries*))) @@ -246,32 +246,32 @@ (declare (ignore bpt)) (discard-invalid-entries frame) (let ((condition (trace-info-condition info)) - (wherein (trace-info-wherein info))) - (setq conditionp - (and (not *in-trace*) - (or (not condition) - (funcall (cdr condition) frame)) - (or (not wherein) - (trace-wherein-p frame wherein))))) + (wherein (trace-info-wherein info))) + (setq conditionp + (and (not *in-trace*) + (or (not condition) + (funcall (cdr condition) frame)) + (or (not wherein) + (trace-wherein-p frame wherein))))) (when conditionp - (let ((sb-kernel:*current-level-in-print* 0) - (*standard-output* (make-string-output-stream)) - (*in-trace* t)) - (fresh-line) - (print-trace-indentation) - (if (trace-info-encapsulated info) - ;; FIXME: These special variables should be given - ;; *FOO*-style names, and probably declared globally - ;; with DEFVAR. - (locally - (declare (special basic-definition arg-list)) - (prin1 `(,(trace-info-what info) ,@arg-list))) - (print-frame-call frame *standard-output*)) - (terpri) - (trace-print frame (trace-info-print info)) - (write-sequence (get-output-stream-string *standard-output*) - *trace-output*)) - (trace-maybe-break info (trace-info-break info) "before" frame))) + (let ((sb-kernel:*current-level-in-print* 0) + (*standard-output* (make-string-output-stream)) + (*in-trace* t)) + (fresh-line) + (print-trace-indentation) + (if (trace-info-encapsulated info) + ;; FIXME: These special variables should be given + ;; *FOO*-style names, and probably declared globally + ;; with DEFVAR. + (locally + (declare (special basic-definition arg-list)) + (prin1 `(,(trace-info-what info) ,@arg-list))) + (print-frame-call frame *standard-output*)) + (terpri) + (trace-print frame (trace-info-print info)) + (write-sequence (get-output-stream-string *standard-output*) + *trace-output*)) + (trace-maybe-break info (trace-info-break info) "before" frame))) (lambda (frame cookie) (declare (ignore frame)) @@ -289,33 +289,33 @@ (declare (ignore bpt)) (unless (eq cookie (caar *traced-entries*)) (setf *traced-entries* - (member cookie *traced-entries* :key #'car))) + (member cookie *traced-entries* :key #'car))) (let ((entry (pop *traced-entries*))) (when (and (not (trace-info-untraced info)) - (or (cdr entry) - (let ((cond (trace-info-condition-after info))) - (and cond (funcall (cdr cond) frame))))) - (let ((sb-kernel:*current-level-in-print* 0) - (*standard-output* (make-string-output-stream)) - (*in-trace* t)) - (fresh-line) - (pprint-logical-block (*standard-output* nil) - (print-trace-indentation) - (pprint-indent :current 2) - (format t "~S returned" (trace-info-what info)) - (dolist (v *trace-values*) - (write-char #\space) - (pprint-newline :linear) - (prin1 v))) - (terpri) - (trace-print frame (trace-info-print-after info)) - (write-sequence (get-output-stream-string *standard-output*) - *trace-output*)) - (trace-maybe-break info - (trace-info-break-after info) - "after" - frame))))) + (or (cdr entry) + (let ((cond (trace-info-condition-after info))) + (and cond (funcall (cdr cond) frame))))) + (let ((sb-kernel:*current-level-in-print* 0) + (*standard-output* (make-string-output-stream)) + (*in-trace* t)) + (fresh-line) + (pprint-logical-block (*standard-output* nil) + (print-trace-indentation) + (pprint-indent :current 2) + (format t "~S returned" (trace-info-what info)) + (dolist (v *trace-values*) + (write-char #\space) + (pprint-newline :linear) + (prin1 v))) + (terpri) + (trace-print frame (trace-info-print-after info)) + (write-sequence (get-output-stream-string *standard-output*) + *trace-output*)) + (trace-maybe-break info + (trace-info-break-after info) + "after" + frame))))) ;;; This function is called by the trace encapsulation. It calls the ;;; breakpoint hook functions with NIL for the breakpoint and cookie, @@ -326,13 +326,13 @@ (let ((frame (sb-di:frame-down (sb-di:top-frame)))) (funcall start frame nil) (let ((*traced-entries* *traced-entries*)) - (declare (special basic-definition arg-list)) - (funcall cookie frame nil) - (let ((vals - (multiple-value-list - (apply basic-definition arg-list)))) - (funcall (trace-end-breakpoint-fun info) frame nil vals nil) - (values-list vals)))))) + (declare (special basic-definition arg-list)) + (funcall cookie frame nil) + (let ((vals + (multiple-value-list + (apply basic-definition arg-list)))) + (funcall (trace-end-breakpoint-fun info) frame nil vals nil) + (values-list vals)))))) ;;; Trace one function according to the specified options. We copy the ;;; trace info (it was a quoted constant), fill in the functions, and @@ -343,76 +343,76 @@ (defun trace-1 (function-or-name info &optional definition) (multiple-value-bind (fun named kind) (if definition - (values definition t - (nth-value 2 (trace-fdefinition definition))) - (trace-fdefinition function-or-name)) + (values definition t + (nth-value 2 (trace-fdefinition definition))) + (trace-fdefinition function-or-name)) (when (gethash fun *traced-funs*) (warn "~S is already TRACE'd, untracing it first." function-or-name) (untrace-1 fun)) (let* ((debug-fun (sb-di:fun-debug-fun fun)) - (encapsulated - (if (eq (trace-info-encapsulated info) :default) - (ecase kind - (:compiled nil) - (:compiled-closure - (unless (functionp function-or-name) - (warn "tracing shared code for ~S:~% ~S" - function-or-name - fun)) - nil) - ((:interpreted :interpreted-closure :funcallable-instance) - t)) - (trace-info-encapsulated info))) - (loc (if encapsulated - :encapsulated - (sb-di:debug-fun-start-location debug-fun))) - (info (make-trace-info - :what function-or-name - :named named - :encapsulated encapsulated - :wherein (trace-info-wherein info) + (encapsulated + (if (eq (trace-info-encapsulated info) :default) + (ecase kind + (:compiled nil) + (:compiled-closure + (unless (functionp function-or-name) + (warn "tracing shared code for ~S:~% ~S" + function-or-name + fun)) + nil) + ((:interpreted :interpreted-closure :funcallable-instance) + t)) + (trace-info-encapsulated info))) + (loc (if encapsulated + :encapsulated + (sb-di:debug-fun-start-location debug-fun))) + (info (make-trace-info + :what function-or-name + :named named + :encapsulated encapsulated + :wherein (trace-info-wherein info) :methods (trace-info-methods info) - :condition (coerce-form (trace-info-condition info) loc) - :break (coerce-form (trace-info-break info) loc) - :print (coerce-form-list (trace-info-print info) loc) - :break-after (coerce-form (trace-info-break-after info) nil) - :condition-after - (coerce-form (trace-info-condition-after info) nil) - :print-after - (coerce-form-list (trace-info-print-after info) nil)))) + :condition (coerce-form (trace-info-condition info) loc) + :break (coerce-form (trace-info-break info) loc) + :print (coerce-form-list (trace-info-print info) loc) + :break-after (coerce-form (trace-info-break-after info) nil) + :condition-after + (coerce-form (trace-info-condition-after info) nil) + :print-after + (coerce-form-list (trace-info-print-after info) nil)))) (dolist (wherein (trace-info-wherein info)) - (unless (or (stringp wherein) - (fboundp wherein)) - (warn ":WHEREIN name ~S is not a defined global function." - wherein))) + (unless (or (stringp wherein) + (fboundp wherein)) + (warn ":WHEREIN name ~S is not a defined global function." + wherein))) (cond (encapsulated - (unless named - (error "can't use encapsulation to trace anonymous function ~S" - fun)) - (encapsulate function-or-name 'trace `(trace-call ',info))) + (unless named + (error "can't use encapsulation to trace anonymous function ~S" + fun)) + (encapsulate function-or-name 'trace `(trace-call ',info))) (t - (multiple-value-bind (start-fun cookie-fun) - (trace-start-breakpoint-fun info) - (let ((start (sb-di:make-breakpoint start-fun debug-fun - :kind :fun-start)) - (end (sb-di:make-breakpoint - (trace-end-breakpoint-fun info) - debug-fun :kind :fun-end - :fun-end-cookie cookie-fun))) - (setf (trace-info-start-breakpoint info) start) - (setf (trace-info-end-breakpoint info) end) - ;; The next two forms must be in the order in which they - ;; appear, since the start breakpoint must run before the - ;; fun-end breakpoint's start helper (which calls the - ;; cookie function.) One reason is that cookie function - ;; requires that the CONDITIONP shared closure variable be - ;; initialized. - (sb-di:activate-breakpoint start) - (sb-di:activate-breakpoint end))))) + (multiple-value-bind (start-fun cookie-fun) + (trace-start-breakpoint-fun info) + (let ((start (sb-di:make-breakpoint start-fun debug-fun + :kind :fun-start)) + (end (sb-di:make-breakpoint + (trace-end-breakpoint-fun info) + debug-fun :kind :fun-end + :fun-end-cookie cookie-fun))) + (setf (trace-info-start-breakpoint info) start) + (setf (trace-info-end-breakpoint info) end) + ;; The next two forms must be in the order in which they + ;; appear, since the start breakpoint must run before the + ;; fun-end breakpoint's start helper (which calls the + ;; cookie function.) One reason is that cookie function + ;; requires that the CONDITIONP shared closure variable be + ;; initialized. + (sb-di:activate-breakpoint start) + (sb-di:activate-breakpoint end))))) (setf (gethash fun *traced-funs*) info)) @@ -445,73 +445,73 @@ (loop (when (endp current) (return)) (let ((option (first current)) - (value (cons (second current) nil))) - (case option - (:report (error "stub: The :REPORT option is not yet implemented.")) - (:condition (setf (trace-info-condition info) value)) - (:condition-after - (setf (trace-info-condition info) (cons nil nil)) - (setf (trace-info-condition-after info) value)) - (:condition-all - (setf (trace-info-condition info) value) - (setf (trace-info-condition-after info) value)) - (:wherein - (setf (trace-info-wherein info) - (if (listp (car value)) (car value) value))) - (:encapsulate - (setf (trace-info-encapsulated info) (car value))) + (value (cons (second current) nil))) + (case option + (:report (error "stub: The :REPORT option is not yet implemented.")) + (:condition (setf (trace-info-condition info) value)) + (:condition-after + (setf (trace-info-condition info) (cons nil nil)) + (setf (trace-info-condition-after info) value)) + (:condition-all + (setf (trace-info-condition info) value) + (setf (trace-info-condition-after info) value)) + (:wherein + (setf (trace-info-wherein info) + (if (listp (car value)) (car value) value))) + (:encapsulate + (setf (trace-info-encapsulated info) (car value))) (:methods (setf (trace-info-methods info) (car value))) - (:break (setf (trace-info-break info) value)) - (:break-after (setf (trace-info-break-after info) value)) - (:break-all - (setf (trace-info-break info) value) - (setf (trace-info-break-after info) value)) - (:print - (setf (trace-info-print info) - (append (trace-info-print info) (list value)))) - (:print-after - (setf (trace-info-print-after info) - (append (trace-info-print-after info) (list value)))) - (:print-all - (setf (trace-info-print info) - (append (trace-info-print info) (list value))) - (setf (trace-info-print-after info) - (append (trace-info-print-after info) (list value)))) - (t (return))) - (pop current) - (unless current - (error "missing argument to ~S TRACE option" option)) - (pop current))) + (:break (setf (trace-info-break info) value)) + (:break-after (setf (trace-info-break-after info) value)) + (:break-all + (setf (trace-info-break info) value) + (setf (trace-info-break-after info) value)) + (:print + (setf (trace-info-print info) + (append (trace-info-print info) (list value)))) + (:print-after + (setf (trace-info-print-after info) + (append (trace-info-print-after info) (list value)))) + (:print-all + (setf (trace-info-print info) + (append (trace-info-print info) (list value))) + (setf (trace-info-print-after info) + (append (trace-info-print-after info) (list value)))) + (t (return))) + (pop current) + (unless current + (error "missing argument to ~S TRACE option" option)) + (pop current))) current)) ;;; Compute the expansion of TRACE in the non-trivial case (arguments -;;; specified.) +;;; specified.) (defun expand-trace (specs) (collect ((binds) - (forms)) + (forms)) (let* ((global-options (make-trace-info)) - (current (parse-trace-options specs global-options))) + (current (parse-trace-options specs global-options))) (loop - (when (endp current) (return)) - (let ((name (pop current)) - (options (copy-trace-info global-options))) - (cond - ((eq name :function) - (let ((temp (gensym))) - (binds `(,temp ,(pop current))) - (forms `(trace-1 ,temp ',options)))) - ((and (keywordp name) - (not (or (fboundp name) (macro-function name)))) - (error "unknown TRACE option: ~S" name)) - ((stringp name) - (let ((package (find-undeleted-package-or-lose name))) - (do-all-symbols (symbol (find-package name)) - (when (and (eql package (symbol-package symbol)) - (fboundp symbol) - (not (macro-function symbol)) - (not (special-operator-p symbol))) - (forms `(trace-1 ',symbol ',options)))))) + (when (endp current) (return)) + (let ((name (pop current)) + (options (copy-trace-info global-options))) + (cond + ((eq name :function) + (let ((temp (gensym))) + (binds `(,temp ,(pop current))) + (forms `(trace-1 ,temp ',options)))) + ((and (keywordp name) + (not (or (fboundp name) (macro-function name)))) + (error "unknown TRACE option: ~S" name)) + ((stringp name) + (let ((package (find-undeleted-package-or-lose name))) + (do-all-symbols (symbol (find-package name)) + (when (and (eql package (symbol-package symbol)) + (fboundp symbol) + (not (macro-function symbol)) + (not (special-operator-p symbol))) + (forms `(trace-1 ',symbol ',options)))))) ;; special-case METHOD: it itself is not a general function ;; name symbol, but it (at least here) designates one of a ;; pair of such. @@ -522,16 +522,16 @@ (when (fboundp (list* 'sb-pcl::fast-method (cdr name))) (forms `(trace-1 ',(list* 'sb-pcl::fast-method (cdr name)) ',options)))) - (t - (forms `(trace-1 ',name ',options)))) - (setq current (parse-trace-options current options))))) - + (t + (forms `(trace-1 ',name ',options)))) + (setq current (parse-trace-options current options))))) + `(let ,(binds) (list ,@(forms))))) (defun %list-traced-funs () (loop for x being each hash-value in *traced-funs* - collect (trace-info-what x))) + collect (trace-info-what x))) (defmacro trace (&rest specs) #+sb-doc @@ -584,7 +584,7 @@ The following options are defined: :BREAK-ALL Form If specified, and Form evaluates to true, then the debugger is invoked at the start of the function, at the end of the function, or both, - according to the respective option. + according to the respective option. :PRINT Form :PRINT-AFTER Form @@ -592,7 +592,7 @@ The following options are defined: In addition to the usual printout, the result of evaluating Form is printed at the start of the function, at the end of the function, or both, according to the respective option. Multiple print options cause - multiple values to be printed. + multiple values to be printed. :WHEREIN Names If specified, Names is a function name or list of names. TRACE does @@ -632,17 +632,17 @@ are evaluated in the null environment." ;;; Untrace one function. (defun untrace-1 (function-or-name) (let* ((fun (trace-fdefinition function-or-name)) - (info (gethash fun *traced-funs*))) + (info (gethash fun *traced-funs*))) (cond ((not info) (warn "Function is not TRACEd: ~S" function-or-name)) (t (cond ((trace-info-encapsulated info) - (unencapsulate (trace-info-what info) 'trace)) + (unencapsulate (trace-info-what info) 'trace)) (t - (sb-di:delete-breakpoint (trace-info-start-breakpoint info)) - (sb-di:delete-breakpoint (trace-info-end-breakpoint info)))) + (sb-di:delete-breakpoint (trace-info-start-breakpoint info)) + (sb-di:delete-breakpoint (trace-info-end-breakpoint info)))) (setf (trace-info-untraced info) t) (remhash fun *traced-funs*))))) @@ -663,12 +663,12 @@ are evaluated in the null environment." ;; UNTRACE-with-args more often than I do.) -- WHN 2003-12-17 (if specs (collect ((res)) - (let ((current specs)) - (loop - (unless current (return)) - (let ((name (pop current))) - (res (if (eq name :function) - `(untrace-1 ,(pop current)) - `(untrace-1 ',name))))) - `(progn ,@(res) t))) + (let ((current specs)) + (loop + (unless current (return)) + (let ((name (pop current))) + (res (if (eq name :function) + `(untrace-1 ,(pop current)) + `(untrace-1 ',name))))) + `(progn ,@(res) t))) '(untrace-all))) diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index d525b8a..a0fff99 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -21,29 +21,29 @@ ;;; leaf is the body to be executed in that case. (defun parse-number-dispatch (vars result types var-types body) (cond ((null vars) - (unless (null types) (error "More types than vars.")) - (when (cdr result) - (error "Duplicate case: ~S." body)) - (setf (cdr result) - (sublis var-types body :test #'equal))) - ((null types) - (error "More vars than types.")) - (t - (flet ((frob (var type) - (parse-number-dispatch - (rest vars) - (or (assoc type (cdr result) :test #'equal) - (car (setf (cdr result) - (acons type nil (cdr result))))) - (rest types) - (acons `(dispatch-type ,var) type var-types) - body))) - (let ((type (first types)) - (var (first vars))) - (if (and (consp type) (eq (first type) 'foreach)) - (dolist (type (rest type)) - (frob var type)) - (frob var type))))))) + (unless (null types) (error "More types than vars.")) + (when (cdr result) + (error "Duplicate case: ~S." body)) + (setf (cdr result) + (sublis var-types body :test #'equal))) + ((null types) + (error "More vars than types.")) + (t + (flet ((frob (var type) + (parse-number-dispatch + (rest vars) + (or (assoc type (cdr result) :test #'equal) + (car (setf (cdr result) + (acons type nil (cdr result))))) + (rest types) + (acons `(dispatch-type ,var) type var-types) + body))) + (let ((type (first types)) + (var (first vars))) + (if (and (consp type) (eq (first type) 'foreach)) + (dolist (type (rest type)) + (frob var type)) + (frob var type))))))) ;;; our guess for the preferred order in which to do type tests ;;; (cheaper and/or more probable first.) @@ -54,26 +54,26 @@ ;;; Should TYPE1 be tested before TYPE2? (defun type-test-order (type1 type2) (let ((o1 (position type1 *type-test-ordering*)) - (o2 (position type2 *type-test-ordering*))) + (o2 (position type2 *type-test-ordering*))) (cond ((not o1) nil) - ((not o2) t) - (t - (< o1 o2))))) + ((not o2) t) + (t + (< o1 o2))))) ;;; Return an ETYPECASE form that does the type dispatch, ordering the ;;; cases for efficiency. (defun generate-number-dispatch (vars error-tags cases) (if vars (let ((var (first vars)) - (cases (sort cases #'type-test-order :key #'car))) - `((typecase ,var - ,@(mapcar (lambda (case) - `(,(first case) - ,@(generate-number-dispatch (rest vars) - (rest error-tags) - (cdr case)))) - cases) - (t (go ,(first error-tags)))))) + (cases (sort cases #'type-test-order :key #'car))) + `((typecase ,var + ,@(mapcar (lambda (case) + `(,(first case) + ,@(generate-number-dispatch (rest vars) + (rest error-tags) + (cdr case)))) + cases) + (t (go ,(first error-tags)))))) cases)) ) ; EVAL-WHEN @@ -94,38 +94,38 @@ ;;; not applied recursively. (defmacro number-dispatch (var-specs &body cases) (let ((res (list nil)) - (vars (mapcar #'car var-specs)) - (block (gensym))) + (vars (mapcar #'car var-specs)) + (block (gensym))) (dolist (case cases) (if (symbolp (first case)) - (let ((cases (apply (symbol-function (first case)) (rest case)))) - (dolist (case cases) - (parse-number-dispatch vars res (first case) nil (rest case)))) - (parse-number-dispatch vars res (first case) nil (rest case)))) + (let ((cases (apply (symbol-function (first case)) (rest case)))) + (dolist (case cases) + (parse-number-dispatch vars res (first case) nil (rest case)))) + (parse-number-dispatch vars res (first case) nil (rest case)))) (collect ((errors) - (error-tags)) + (error-tags)) (dolist (spec var-specs) - (let ((var (first spec)) - (type (second spec)) - (tag (gensym))) - (error-tags tag) - (errors tag) - (errors `(return-from - ,block - (error 'simple-type-error :datum ,var - :expected-type ',type - :format-control - "~@" - :format-arguments - (list ',var ',type ,var)))))) + (let ((var (first spec)) + (type (second spec)) + (tag (gensym))) + (error-tags tag) + (errors tag) + (errors `(return-from + ,block + (error 'simple-type-error :datum ,var + :expected-type ',type + :format-control + "~@" + :format-arguments + (list ',var ',type ,var)))))) `(block ,block - (tagbody - (return-from ,block - ,@(generate-number-dispatch vars (error-tags) - (cdr res))) - ,@(errors)))))) + (tagbody + (return-from ,block + ,@(generate-number-dispatch vars (error-tags) + (cdr res))) + ,@(errors)))))) ;;;; binary operation dispatching utilities @@ -173,17 +173,17 @@ (if (eql imagpart 0) realpart (cond #!+long-float - ((and (typep realpart 'long-float) - (typep imagpart 'long-float)) - (truly-the (complex long-float) (complex realpart imagpart))) - ((and (typep realpart 'double-float) - (typep imagpart 'double-float)) - (truly-the (complex double-float) (complex realpart imagpart))) - ((and (typep realpart 'single-float) - (typep imagpart 'single-float)) - (truly-the (complex single-float) (complex realpart imagpart))) - (t - (%make-complex realpart imagpart))))) + ((and (typep realpart 'long-float) + (typep imagpart 'long-float)) + (truly-the (complex long-float) (complex realpart imagpart))) + ((and (typep realpart 'double-float) + (typep imagpart 'double-float)) + (truly-the (complex double-float) (complex realpart imagpart))) + ((and (typep realpart 'single-float) + (typep imagpart 'single-float)) + (truly-the (complex single-float) (complex realpart imagpart))) + (t + (%make-complex realpart imagpart))))) ;;; Given a numerator and denominator with the GCD already divided ;;; out, make a canonical rational. We make the denominator positive, @@ -192,13 +192,13 @@ (defun build-ratio (num den) (multiple-value-bind (num den) (if (minusp den) - (values (- num) (- den)) - (values num den)) + (values (- num) (- den)) + (values num den)) (cond ((eql den 0) (error 'division-by-zero - :operands (list num den) - :operation 'build-ratio)) + :operands (list num den) + :operation 'build-ratio)) ((eql den 1) num) (t (%make-ratio num den))))) @@ -215,21 +215,21 @@ #!+sb-doc "Return a complex number with the specified real and imaginary components." (flet ((%%make-complex (realpart imagpart) - (cond #!+long-float - ((and (typep realpart 'long-float) - (typep imagpart 'long-float)) - (truly-the (complex long-float) - (complex realpart imagpart))) - ((and (typep realpart 'double-float) - (typep imagpart 'double-float)) - (truly-the (complex double-float) - (complex realpart imagpart))) - ((and (typep realpart 'single-float) - (typep imagpart 'single-float)) - (truly-the (complex single-float) - (complex realpart imagpart))) - (t - (%make-complex realpart imagpart))))) + (cond #!+long-float + ((and (typep realpart 'long-float) + (typep imagpart 'long-float)) + (truly-the (complex long-float) + (complex realpart imagpart))) + ((and (typep realpart 'double-float) + (typep imagpart 'double-float)) + (truly-the (complex double-float) + (complex realpart imagpart))) + ((and (typep realpart 'single-float) + (typep imagpart 'single-float)) + (truly-the (complex single-float) + (complex realpart imagpart))) + (t + (%make-complex realpart imagpart))))) (number-dispatch ((realpart real) (imagpart real)) ((rational rational) (canonical-complex realpart imagpart)) @@ -283,8 +283,8 @@ (if (zerop number) number (if (rationalp number) - (if (plusp number) 1 -1) - (/ number (abs number))))) + (if (plusp number) 1 -1) + (/ number (abs number))))) ;;;; ratios @@ -301,15 +301,15 @@ ;;;; arithmetic operations (macrolet ((define-arith (op init doc) - #!-sb-doc (declare (ignore doc)) - `(defun ,op (&rest args) - #!+sb-doc ,doc - (if (null args) ,init - (do ((args (cdr args) (cdr args)) - (result (car args) (,op result (car args)))) - ((null args) result) - ;; to signal TYPE-ERROR when exactly 1 arg of wrong type: - (declare (type number result))))))) + #!-sb-doc (declare (ignore doc)) + `(defun ,op (&rest args) + #!+sb-doc ,doc + (if (null args) ,init + (do ((args (cdr args) (cdr args)) + (result (car args) (,op result (car args)))) + ((null args) result) + ;; to signal TYPE-ERROR when exactly 1 arg of wrong type: + (declare (type number result))))))) (define-arith + 0 "Return the sum of its arguments. With no args, returns 0.") (define-arith * 1 @@ -317,14 +317,14 @@ (defun - (number &rest more-numbers) #!+sb-doc - "Subtract the second and all subsequent arguments from the first; + "Subtract the second and all subsequent arguments from the first; or with one argument, negate the first argument." (if more-numbers (do ((nlist more-numbers (cdr nlist)) - (result number)) - ((atom nlist) result) - (declare (list nlist)) - (setq result (- result (car nlist)))) + (result number)) + ((atom nlist) result) + (declare (list nlist)) + (setq result (- result (car nlist)))) (- number))) (defun / (number &rest more-numbers) @@ -333,10 +333,10 @@ With one argument, return reciprocal." (if more-numbers (do ((nlist more-numbers (cdr nlist)) - (result number)) - ((atom nlist) result) - (declare (list nlist)) - (setq result (/ result (car nlist)))) + (result number)) + ((atom nlist) result) + (declare (list nlist)) + (setq result (/ result (car nlist)))) (/ number))) (defun 1+ (number) @@ -358,40 +358,40 @@ (float-contagion ,op x y) ((complex complex) - (canonical-complex (,op (realpart x) (realpart y)) - (,op (imagpart x) (imagpart y)))) + (canonical-complex (,op (realpart x) (realpart y)) + (,op (imagpart x) (imagpart y)))) (((foreach bignum fixnum ratio single-float double-float - #!+long-float long-float) complex) - (complex (,op x (realpart y)) (,op (imagpart y)))) + #!+long-float long-float) complex) + (complex (,op x (realpart y)) (,op (imagpart y)))) ((complex (or rational float)) - (complex (,op (realpart x) y) (imagpart x))) + (complex (,op (realpart x) y) (imagpart x))) (((foreach fixnum bignum) ratio) - (let* ((dy (denominator y)) - (n (,op (* x dy) (numerator y)))) - (%make-ratio n dy))) + (let* ((dy (denominator y)) + (n (,op (* x dy) (numerator y)))) + (%make-ratio n dy))) ((ratio integer) - (let* ((dx (denominator x)) - (n (,op (numerator x) (* y dx)))) - (%make-ratio n dx))) + (let* ((dx (denominator x)) + (n (,op (numerator x) (* y dx)))) + (%make-ratio n dx))) ((ratio ratio) - (let* ((nx (numerator x)) - (dx (denominator x)) - (ny (numerator y)) - (dy (denominator y)) - (g1 (gcd dx dy))) - (if (eql g1 1) - (%make-ratio (,op (* nx dy) (* dx ny)) (* dx dy)) - (let* ((t1 (,op (* nx (truncate dy g1)) (* (truncate dx g1) ny))) - (g2 (gcd t1 g1)) - (t2 (truncate dx g1))) - (cond ((eql t1 0) 0) - ((eql g2 1) - (%make-ratio t1 (* t2 dy))) - (t (let* ((nn (truncate t1 g2)) - (t3 (truncate dy g2)) - (nd (if (eql t2 1) t3 (* t2 t3)))) - (if (eql nd 1) nn (%make-ratio nn nd)))))))))))) + (let* ((nx (numerator x)) + (dx (denominator x)) + (ny (numerator y)) + (dy (denominator y)) + (g1 (gcd dx dy))) + (if (eql g1 1) + (%make-ratio (,op (* nx dy) (* dx ny)) (* dx dy)) + (let* ((t1 (,op (* nx (truncate dy g1)) (* (truncate dx g1) ny))) + (g2 (gcd t1 g1)) + (t2 (truncate dx g1))) + (cond ((eql t1 0) 0) + ((eql g2 1) + (%make-ratio t1 (* t2 dy))) + (t (let* ((nn (truncate t1 g2)) + (t3 (truncate dy g2)) + (nd (if (eql t2 1) t3 (* t2 t3)))) + (if (eql nd 1) nn (%make-ratio nn nd)))))))))))) ) ; EVAL-WHEN @@ -400,19 +400,19 @@ (defun two-arg-* (x y) (flet ((integer*ratio (x y) - (if (eql x 0) 0 - (let* ((ny (numerator y)) - (dy (denominator y)) - (gcd (gcd x dy))) - (if (eql gcd 1) - (%make-ratio (* x ny) dy) - (let ((nn (* (truncate x gcd) ny)) - (nd (truncate dy gcd))) - (if (eql nd 1) - nn - (%make-ratio nn nd))))))) - (complex*real (x y) - (canonical-complex (* (realpart x) y) (* (imagpart x) y)))) + (if (eql x 0) 0 + (let* ((ny (numerator y)) + (dy (denominator y)) + (gcd (gcd x dy))) + (if (eql gcd 1) + (%make-ratio (* x ny) dy) + (let ((nn (* (truncate x gcd) ny)) + (nd (truncate dy gcd))) + (if (eql nd 1) + nn + (%make-ratio nn nd))))))) + (complex*real (x y) + (canonical-complex (* (realpart x) y) (* (imagpart x) y)))) (number-dispatch ((x number) (y number)) (float-contagion * x y) @@ -423,13 +423,13 @@ ((complex complex) (let* ((rx (realpart x)) - (ix (imagpart x)) - (ry (realpart y)) - (iy (imagpart y))) - (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry))))) + (ix (imagpart x)) + (ry (realpart y)) + (iy (imagpart y))) + (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry))))) (((foreach bignum fixnum ratio single-float double-float - #!+long-float long-float) - complex) + #!+long-float long-float) + complex) (complex*real y x)) ((complex (or rational float)) (complex*real x y)) @@ -438,15 +438,15 @@ ((ratio integer) (integer*ratio y x)) ((ratio ratio) (let* ((nx (numerator x)) - (dx (denominator x)) - (ny (numerator y)) - (dy (denominator y)) - (g1 (gcd nx dy)) - (g2 (gcd dx ny))) - (build-ratio (* (maybe-truncate nx g1) - (maybe-truncate ny g2)) - (* (maybe-truncate dx g2) - (maybe-truncate dy g1)))))))) + (dx (denominator x)) + (ny (numerator y)) + (dy (denominator y)) + (g1 (gcd nx dy)) + (g2 (gcd dx ny))) + (build-ratio (* (maybe-truncate nx g1) + (maybe-truncate ny g2)) + (* (maybe-truncate dx g2) + (maybe-truncate dy g1)))))))) ;;; Divide two integers, producing a canonical rational. If a fixnum, ;;; we see whether they divide evenly before trying the GCD. In the @@ -455,17 +455,17 @@ (defun integer-/-integer (x y) (if (and (typep x 'fixnum) (typep y 'fixnum)) (multiple-value-bind (quo rem) (truncate x y) - (if (zerop rem) - quo - (let ((gcd (gcd x y))) - (declare (fixnum gcd)) - (if (eql gcd 1) - (build-ratio x y) - (build-ratio (truncate x gcd) (truncate y gcd)))))) + (if (zerop rem) + quo + (let ((gcd (gcd x y))) + (declare (fixnum gcd)) + (if (eql gcd 1) + (build-ratio x y) + (build-ratio (truncate x gcd) (truncate y gcd)))))) (let ((gcd (gcd x y))) - (if (eql gcd 1) - (build-ratio x y) - (build-ratio (truncate x gcd) (truncate y gcd)))))) + (if (eql gcd 1) + (build-ratio x y) + (build-ratio (truncate x gcd) (truncate y gcd)))))) (defun two-arg-/ (x y) (number-dispatch ((x number) (y number)) @@ -473,61 +473,61 @@ ((complex complex) (let* ((rx (realpart x)) - (ix (imagpart x)) - (ry (realpart y)) - (iy (imagpart y))) + (ix (imagpart x)) + (ry (realpart y)) + (iy (imagpart y))) (if (> (abs ry) (abs iy)) - (let* ((r (/ iy ry)) - (dn (* ry (+ 1 (* r r))))) - (canonical-complex (/ (+ rx (* ix r)) dn) - (/ (- ix (* rx r)) dn))) - (let* ((r (/ ry iy)) - (dn (* iy (+ 1 (* r r))))) - (canonical-complex (/ (+ (* rx r) ix) dn) - (/ (- (* ix r) rx) dn)))))) + (let* ((r (/ iy ry)) + (dn (* ry (+ 1 (* r r))))) + (canonical-complex (/ (+ rx (* ix r)) dn) + (/ (- ix (* rx r)) dn))) + (let* ((r (/ ry iy)) + (dn (* iy (+ 1 (* r r))))) + (canonical-complex (/ (+ (* rx r) ix) dn) + (/ (- (* ix r) rx) dn)))))) (((foreach integer ratio single-float double-float) complex) (let* ((ry (realpart y)) - (iy (imagpart y))) + (iy (imagpart y))) (if (> (abs ry) (abs iy)) - (let* ((r (/ iy ry)) - (dn (* ry (+ 1 (* r r))))) - (canonical-complex (/ x dn) - (/ (- (* x r)) dn))) - (let* ((r (/ ry iy)) - (dn (* iy (+ 1 (* r r))))) - (canonical-complex (/ (* x r) dn) - (/ (- x) dn)))))) + (let* ((r (/ iy ry)) + (dn (* ry (+ 1 (* r r))))) + (canonical-complex (/ x dn) + (/ (- (* x r)) dn))) + (let* ((r (/ ry iy)) + (dn (* iy (+ 1 (* r r))))) + (canonical-complex (/ (* x r) dn) + (/ (- x) dn)))))) ((complex (or rational float)) (canonical-complex (/ (realpart x) y) - (/ (imagpart x) y))) + (/ (imagpart x) y))) ((ratio ratio) (let* ((nx (numerator x)) - (dx (denominator x)) - (ny (numerator y)) - (dy (denominator y)) - (g1 (gcd nx ny)) - (g2 (gcd dx dy))) + (dx (denominator x)) + (ny (numerator y)) + (dy (denominator y)) + (g1 (gcd nx ny)) + (g2 (gcd dx dy))) (build-ratio (* (maybe-truncate nx g1) (maybe-truncate dy g2)) - (* (maybe-truncate dx g2) (maybe-truncate ny g1))))) + (* (maybe-truncate dx g2) (maybe-truncate ny g1))))) ((integer integer) (integer-/-integer x y)) ((integer ratio) (if (zerop x) - 0 - (let* ((ny (numerator y)) - (dy (denominator y)) - (gcd (gcd x ny))) - (build-ratio (* (maybe-truncate x gcd) dy) - (maybe-truncate ny gcd))))) + 0 + (let* ((ny (numerator y)) + (dy (denominator y)) + (gcd (gcd x ny))) + (build-ratio (* (maybe-truncate x gcd) dy) + (maybe-truncate ny gcd))))) ((ratio integer) (let* ((nx (numerator x)) - (gcd (gcd nx y))) + (gcd (gcd nx y))) (build-ratio (maybe-truncate nx gcd) - (* (maybe-truncate y gcd) (denominator x))))))) + (* (maybe-truncate y gcd) (denominator x))))))) (defun %negate (n) (number-dispatch ((n number)) @@ -547,34 +547,34 @@ "Return number (or number/divisor) as an integer, rounded toward 0. The second returned value is the remainder." (macrolet ((truncate-float (rtype) - `(let* ((float-div (coerce divisor ',rtype)) - (res (%unary-truncate (/ number float-div)))) - (values res - (- number - (* (coerce res ',rtype) float-div)))))) + `(let* ((float-div (coerce divisor ',rtype)) + (res (%unary-truncate (/ number float-div)))) + (values res + (- number + (* (coerce res ',rtype) float-div)))))) (number-dispatch ((number real) (divisor real)) ((fixnum fixnum) (truncate number divisor)) (((foreach fixnum bignum) ratio) (let ((q (truncate (* number (denominator divisor)) - (numerator divisor)))) - (values q (- number (* q divisor))))) + (numerator divisor)))) + (values q (- number (* q divisor))))) ((fixnum bignum) (bignum-truncate (make-small-bignum number) divisor)) ((ratio (or float rational)) (let ((q (truncate (numerator number) - (* (denominator number) divisor)))) - (values q (- number (* q divisor))))) + (* (denominator number) divisor)))) + (values q (- number (* q divisor))))) ((bignum fixnum) (bignum-truncate number (make-small-bignum divisor))) ((bignum bignum) (bignum-truncate number divisor)) (((foreach single-float double-float #!+long-float long-float) - (or rational single-float)) + (or rational single-float)) (if (eql divisor 1) - (let ((res (%unary-truncate number))) - (values res (- number (coerce res '(dispatch-type number))))) - (truncate-float (dispatch-type number)))) + (let ((res (%unary-truncate number))) + (values res (- number (coerce res '(dispatch-type number))))) + (truncate-float (dispatch-type number)))) #!+long-float ((long-float (or single-float double-float long-float)) (truncate-float long-float)) @@ -586,7 +586,7 @@ ((single-float double-float) (truncate-float double-float)) (((foreach fixnum bignum ratio) - (foreach single-float double-float #!+long-float long-float)) + (foreach single-float double-float #!+long-float long-float)) (truncate-float (dispatch-type divisor)))))) ;;; Declare these guys inline to let them get optimized a little. @@ -607,11 +607,11 @@ ;; and augment the remainder by the divisor. (multiple-value-bind (tru rem) (truncate number divisor) (if (and (not (zerop rem)) - (if (minusp divisor) - (plusp number) - (minusp number))) - (values (1- tru) (+ rem divisor)) - (values tru rem)))) + (if (minusp divisor) + (plusp number) + (minusp number))) + (values (1- tru) (+ rem divisor)) + (values tru rem)))) (defun ceiling (number &optional (divisor 1)) #!+sb-doc @@ -622,11 +622,11 @@ ;; and decrement the remainder by the divisor. (multiple-value-bind (tru rem) (truncate number divisor) (if (and (not (zerop rem)) - (if (minusp divisor) - (minusp number) - (plusp number))) - (values (+ tru 1) (- rem divisor)) - (values tru rem)))) + (if (minusp divisor) + (minusp number) + (plusp number))) + (values (+ tru 1) (- rem divisor)) + (values tru rem)))) (defun round (number &optional (divisor 1)) #!+sb-doc @@ -635,21 +635,21 @@ (if (eql divisor 1) (round number) (multiple-value-bind (tru rem) (truncate number divisor) - (if (zerop rem) - (values tru rem) - (let ((thresh (/ (abs divisor) 2))) - (cond ((or (> rem thresh) - (and (= rem thresh) (oddp tru))) - (if (minusp divisor) - (values (- tru 1) (+ rem divisor)) - (values (+ tru 1) (- rem divisor)))) - ((let ((-thresh (- thresh))) - (or (< rem -thresh) - (and (= rem -thresh) (oddp tru)))) - (if (minusp divisor) - (values (+ tru 1) (- rem divisor)) - (values (- tru 1) (+ rem divisor)))) - (t (values tru rem)))))))) + (if (zerop rem) + (values tru rem) + (let ((thresh (/ (abs divisor) 2))) + (cond ((or (> rem thresh) + (and (= rem thresh) (oddp tru))) + (if (minusp divisor) + (values (- tru 1) (+ rem divisor)) + (values (+ tru 1) (- rem divisor)))) + ((let ((-thresh (- thresh))) + (or (< rem -thresh) + (and (= rem -thresh) (oddp tru)))) + (if (minusp divisor) + (values (+ tru 1) (- rem divisor)) + (values (- tru 1) (+ rem divisor)))) + (t (values tru rem)))))))) (defun rem (number divisor) #!+sb-doc @@ -663,11 +663,11 @@ "Return second result of FLOOR." (let ((rem (rem number divisor))) (if (and (not (zerop rem)) - (if (minusp divisor) - (plusp number) - (minusp number))) - (+ rem divisor) - rem))) + (if (minusp divisor) + (plusp number) + (minusp number))) + (+ rem divisor) + rem))) (defmacro !define-float-rounding-function (name op doc) `(defun ,name (number &optional (divisor 1)) @@ -679,22 +679,22 @@ #!+sb-doc "Same as TRUNCATE, but returns first value as a float." (macrolet ((ftruncate-float (rtype) - `(let* ((float-div (coerce divisor ',rtype)) - (res (%unary-ftruncate (/ number float-div)))) - (values res - (- number - (* (coerce res ',rtype) float-div)))))) + `(let* ((float-div (coerce divisor ',rtype)) + (res (%unary-ftruncate (/ number float-div)))) + (values res + (- number + (* (coerce res ',rtype) float-div)))))) (number-dispatch ((number real) (divisor real)) (((foreach fixnum bignum ratio) (or fixnum bignum ratio)) (multiple-value-bind (q r) - (truncate number divisor) - (values (float q) r))) + (truncate number divisor) + (values (float q) r))) (((foreach single-float double-float #!+long-float long-float) - (or rational single-float)) + (or rational single-float)) (if (eql divisor 1) - (let ((res (%unary-ftruncate number))) - (values res (- number (coerce res '(dispatch-type number))))) - (ftruncate-float (dispatch-type number)))) + (let ((res (%unary-ftruncate number))) + (values res (- number (coerce res '(dispatch-type number))))) + (ftruncate-float (dispatch-type number)))) #!+long-float ((long-float (or single-float double-float long-float)) (ftruncate-float long-float)) @@ -706,7 +706,7 @@ ((single-float double-float) (ftruncate-float double-float)) (((foreach fixnum bignum ratio) - (foreach single-float double-float #!+long-float long-float)) + (foreach single-float double-float #!+long-float long-float)) (ftruncate-float (dispatch-type divisor)))))) (defun ffloor (number &optional (divisor 1)) @@ -752,20 +752,20 @@ #!+sb-doc "Return T if no two of its arguments are numerically equal, NIL otherwise." (do* ((head (the number number) (car nlist)) - (nlist more-numbers (cdr nlist))) + (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) (unless (do* ((nl nlist (cdr nl))) - ((atom nl) t) - (declare (list nl)) - (if (= head (car nl)) (return nil))) + ((atom nl) t) + (declare (list nl)) + (if (= head (car nl)) (return nil))) (return nil)))) (defun < (number &rest more-numbers) #!+sb-doc "Return T if its arguments are in strictly increasing order, NIL otherwise." (do* ((n (the number number) (car nlist)) - (nlist more-numbers (cdr nlist))) + (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) (if (not (< n (car nlist))) (return nil)))) @@ -774,7 +774,7 @@ #!+sb-doc "Return T if its arguments are in strictly decreasing order, NIL otherwise." (do* ((n (the number number) (car nlist)) - (nlist more-numbers (cdr nlist))) + (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) (if (not (> n (car nlist))) (return nil)))) @@ -783,7 +783,7 @@ #!+sb-doc "Return T if arguments are in strictly non-decreasing order, NIL otherwise." (do* ((n (the number number) (car nlist)) - (nlist more-numbers (cdr nlist))) + (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) (if (not (<= n (car nlist))) (return nil)))) @@ -792,7 +792,7 @@ #!+sb-doc "Return T if arguments are in strictly non-increasing order, NIL otherwise." (do* ((n (the number number) (car nlist)) - (nlist more-numbers (cdr nlist))) + (nlist more-numbers (cdr nlist))) ((atom nlist) t) (declare (list nlist)) (if (not (>= n (car nlist))) (return nil)))) @@ -853,72 +853,72 @@ the first." ;; If the fixnum has an exact float representation, do a ;; float comparison. Otherwise do the slow float -> ratio ;; conversion. - (multiple-value-bind (lo hi) - (case '(dispatch-type y) - ('single-float - (values most-negative-exactly-single-float-fixnum - most-positive-exactly-single-float-fixnum)) - ('double-float - (values most-negative-exactly-double-float-fixnum - most-positive-exactly-double-float-fixnum))) - (if (<= lo y hi) - (,op (coerce x '(dispatch-type y)) y) - (,op x (rational y)))))) + (multiple-value-bind (lo hi) + (case '(dispatch-type y) + ('single-float + (values most-negative-exactly-single-float-fixnum + most-positive-exactly-single-float-fixnum)) + ('double-float + (values most-negative-exactly-double-float-fixnum + most-positive-exactly-double-float-fixnum))) + (if (<= lo y hi) + (,op (coerce x '(dispatch-type y)) y) + (,op x (rational y)))))) (((foreach single-float double-float) fixnum) (if (eql y 0) (,op x (coerce 0 '(dispatch-type x))) (if (float-infinity-p x) ,infinite-x-finite-y ;; Likewise - (multiple-value-bind (lo hi) - (case '(dispatch-type x) - ('single-float - (values most-negative-exactly-single-float-fixnum - most-positive-exactly-single-float-fixnum)) - ('double-float - (values most-negative-exactly-double-float-fixnum - most-positive-exactly-double-float-fixnum))) - (if (<= lo y hi) - (,op x (coerce y '(dispatch-type x))) - (,op (rational x) y)))))) + (multiple-value-bind (lo hi) + (case '(dispatch-type x) + ('single-float + (values most-negative-exactly-single-float-fixnum + most-positive-exactly-single-float-fixnum)) + ('double-float + (values most-negative-exactly-double-float-fixnum + most-positive-exactly-double-float-fixnum))) + (if (<= lo y hi) + (,op x (coerce y '(dispatch-type x))) + (,op (rational x) y)))))) (((foreach single-float double-float) double-float) (,op (coerce x 'double-float) y)) ((double-float single-float) (,op x (coerce y 'double-float))) (((foreach single-float double-float #!+long-float long-float) rational) (if (eql y 0) - (,op x (coerce 0 '(dispatch-type x))) - (if (float-infinity-p x) - ,infinite-x-finite-y - (,op (rational x) y)))) + (,op x (coerce 0 '(dispatch-type x))) + (if (float-infinity-p x) + ,infinite-x-finite-y + (,op (rational x) y)))) (((foreach bignum fixnum ratio) float) (if (float-infinity-p y) - ,infinite-y-finite-x - (,op x (rational y)))))) + ,infinite-y-finite-x + (,op x (rational y)))))) ) ; EVAL-WHEN (macrolet ((def-two-arg- (name op ratio-arg1 ratio-arg2 &rest cases) `(defun ,name (x y) - (number-dispatch ((x real) (y real)) - (basic-compare - ,op - :infinite-x-finite-y - (,op x (coerce 0 '(dispatch-type x))) - :infinite-y-finite-x - (,op (coerce 0 '(dispatch-type y)) y)) - (((foreach fixnum bignum) ratio) - (,op x (,ratio-arg2 (numerator y) - (denominator y)))) - ((ratio integer) - (,op (,ratio-arg1 (numerator x) - (denominator x)) - y)) - ((ratio ratio) - (,op (* (numerator (truly-the ratio x)) - (denominator (truly-the ratio y))) - (* (numerator (truly-the ratio y)) - (denominator (truly-the ratio x))))) - ,@cases)))) + (number-dispatch ((x real) (y real)) + (basic-compare + ,op + :infinite-x-finite-y + (,op x (coerce 0 '(dispatch-type x))) + :infinite-y-finite-x + (,op (coerce 0 '(dispatch-type y)) y)) + (((foreach fixnum bignum) ratio) + (,op x (,ratio-arg2 (numerator y) + (denominator y)))) + ((ratio integer) + (,op (,ratio-arg1 (numerator x) + (denominator x)) + y)) + ((ratio ratio) + (,op (* (numerator (truly-the ratio x)) + (denominator (truly-the ratio y))) + (* (numerator (truly-the ratio y)) + (denominator (truly-the ratio x))))) + ,@cases)))) (def-two-arg- two-arg-< < floor ceiling ((fixnum bignum) (bignum-plus-p y)) @@ -937,9 +937,9 @@ the first." (defun two-arg-= (x y) (number-dispatch ((x number) (y number)) (basic-compare = - ;; An infinite value is never equal to a finite value. - :infinite-x-finite-y nil - :infinite-y-finite-x nil) + ;; An infinite value is never equal to a finite value. + :infinite-x-finite-y nil + :infinite-y-finite-x nil) ((fixnum (or bignum ratio)) nil) ((bignum (or fixnum ratio)) nil) @@ -949,51 +949,51 @@ the first." ((ratio integer) nil) ((ratio ratio) (and (eql (numerator x) (numerator y)) - (eql (denominator x) (denominator y)))) + (eql (denominator x) (denominator y)))) ((complex complex) (and (= (realpart x) (realpart y)) - (= (imagpart x) (imagpart y)))) + (= (imagpart x) (imagpart y)))) (((foreach fixnum bignum ratio single-float double-float - #!+long-float long-float) complex) + #!+long-float long-float) complex) (and (= x (realpart y)) - (zerop (imagpart y)))) + (zerop (imagpart y)))) ((complex (or float rational)) (and (= (realpart x) y) - (zerop (imagpart x)))))) + (zerop (imagpart x)))))) (defun eql (obj1 obj2) #!+sb-doc "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL." (or (eq obj1 obj2) (if (or (typep obj2 'fixnum) - (not (typep obj2 'number))) - nil - (macrolet ((foo (&rest stuff) - `(typecase obj2 - ,@(mapcar (lambda (foo) - (let ((type (car foo)) - (fn (cadr foo))) - `(,type - (and (typep obj1 ',type) - (,fn obj1 obj2))))) - stuff)))) - (foo - (single-float eql) - (double-float eql) - #!+long-float - (long-float eql) - (bignum - (lambda (x y) - (zerop (bignum-compare x y)))) - (ratio - (lambda (x y) - (and (eql (numerator x) (numerator y)) - (eql (denominator x) (denominator y))))) - (complex - (lambda (x y) - (and (eql (realpart x) (realpart y)) - (eql (imagpart x) (imagpart y)))))))))) + (not (typep obj2 'number))) + nil + (macrolet ((foo (&rest stuff) + `(typecase obj2 + ,@(mapcar (lambda (foo) + (let ((type (car foo)) + (fn (cadr foo))) + `(,type + (and (typep obj1 ',type) + (,fn obj1 obj2))))) + stuff)))) + (foo + (single-float eql) + (double-float eql) + #!+long-float + (long-float eql) + (bignum + (lambda (x y) + (zerop (bignum-compare x y)))) + (ratio + (lambda (x y) + (and (eql (numerator x) (numerator y)) + (eql (denominator x) (denominator y))))) + (complex + (lambda (x y) + (and (eql (realpart x) (realpart y)) + (eql (imagpart x) (imagpart y)))))))))) ;;;; logicals @@ -1003,8 +1003,8 @@ the first." (declare (list integers)) (if integers (do ((result (pop integers) (logior result (pop integers)))) - ((null integers) result) - (declare (integer result))) + ((null integers) result) + (declare (integer result))) 0)) (defun logxor (&rest integers) @@ -1013,8 +1013,8 @@ the first." (declare (list integers)) (if integers (do ((result (pop integers) (logxor result (pop integers)))) - ((null integers) result) - (declare (integer result))) + ((null integers) result) + (declare (integer result))) 0)) (defun logand (&rest integers) @@ -1023,8 +1023,8 @@ the first." (declare (list integers)) (if integers (do ((result (pop integers) (logand result (pop integers)))) - ((null integers) result) - (declare (integer result))) + ((null integers) result) + (declare (integer result))) -1)) (defun logeqv (&rest integers) @@ -1033,8 +1033,8 @@ the first." (declare (list integers)) (if integers (do ((result (pop integers) (logeqv result (pop integers)))) - ((null integers) result) - (declare (integer result))) + ((null integers) result) + (declare (integer result))) -1)) (defun lognot (number) @@ -1045,21 +1045,21 @@ the first." (bignum (bignum-logical-not number)))) (macrolet ((def (name op big-op &optional doc) - `(defun ,name (integer1 integer2) - ,@(when doc - (list doc)) - (let ((x integer1) - (y integer2)) - (number-dispatch ((x integer) (y integer)) - (bignum-cross-fixnum ,op ,big-op)))))) + `(defun ,name (integer1 integer2) + ,@(when doc + (list doc)) + (let ((x integer1) + (y integer2)) + (number-dispatch ((x integer) (y integer)) + (bignum-cross-fixnum ,op ,big-op)))))) (def two-arg-and logand bignum-logical-and) (def two-arg-ior logior bignum-logical-ior) (def two-arg-xor logxor bignum-logical-xor) ;; BIGNUM-LOGICAL-{AND,IOR,XOR} need not return a bignum, so must ;; call the generic LOGNOT... (def two-arg-eqv logeqv (lambda (x y) (lognot (bignum-logical-xor x y)))) - (def lognand lognand - (lambda (x y) (lognot (bignum-logical-and x y))) + (def lognand lognand + (lambda (x y) (lognot (bignum-logical-and x y))) #!+sb-doc "Complement the logical AND of INTEGER1 and INTEGER2.") (def lognor lognor (lambda (x y) (lognot (bignum-logical-ior x y))) @@ -1085,11 +1085,11 @@ the first." (etypecase integer (fixnum (logcount (truly-the (integer 0 - #.(max sb!xc:most-positive-fixnum - (lognot sb!xc:most-negative-fixnum))) - (if (minusp (truly-the fixnum integer)) - (lognot (truly-the fixnum integer)) - integer)))) + #.(max sb!xc:most-positive-fixnum + (lognot sb!xc:most-negative-fixnum))) + (if (minusp (truly-the fixnum integer)) + (lognot (truly-the fixnum integer)) + integer)))) (bignum (bignum-logcount integer)))) @@ -1103,8 +1103,8 @@ the first." "Predicate returns T if bit index of integer is a 1." (number-dispatch ((index integer) (integer integer)) ((fixnum fixnum) (if (> index #.(- sb!vm:n-word-bits sb!vm:n-lowtag-bits)) - (minusp integer) - (not (zerop (logand integer (ash 1 index)))))) + (minusp integer) + (not (zerop (logand integer (ash 1 index)))))) ((fixnum bignum) (bignum-logbitp index integer)) ((bignum (foreach fixnum bignum)) (minusp integer)))) @@ -1115,26 +1115,26 @@ the first." (etypecase integer (fixnum (cond ((zerop integer) - 0) - ((fixnump count) - (let ((length (integer-length (truly-the fixnum integer))) - (count (truly-the fixnum count))) - (declare (fixnum length count)) - (cond ((and (plusp count) - (> (+ length count) - (integer-length most-positive-fixnum))) - (bignum-ashift-left (make-small-bignum integer) count)) - (t - (truly-the fixnum - (ash (truly-the fixnum integer) count)))))) - ((minusp count) - (if (minusp integer) -1 0)) - (t - (bignum-ashift-left (make-small-bignum integer) count)))) + 0) + ((fixnump count) + (let ((length (integer-length (truly-the fixnum integer))) + (count (truly-the fixnum count))) + (declare (fixnum length count)) + (cond ((and (plusp count) + (> (+ length count) + (integer-length most-positive-fixnum))) + (bignum-ashift-left (make-small-bignum integer) count)) + (t + (truly-the fixnum + (ash (truly-the fixnum integer) count)))))) + ((minusp count) + (if (minusp integer) -1 0)) + (t + (bignum-ashift-left (make-small-bignum integer) count)))) (bignum (if (plusp count) - (bignum-ashift-left integer count) - (bignum-ashift-right integer (- count)))))) + (bignum-ashift-left integer count) + (bignum-ashift-right integer (- count)))))) (defun integer-length (integer) #!+sb-doc @@ -1191,7 +1191,7 @@ the first." (defun %ldb (size posn integer) (logand (ash integer (- posn)) - (1- (ash 1 size)))) + (1- (ash 1 size)))) (defun %mask-field (size posn integer) (logand integer (ash (1- (ash 1 size)) posn))) @@ -1199,12 +1199,12 @@ the first." (defun %dpb (newbyte size posn integer) (let ((mask (1- (ash 1 size)))) (logior (logand integer (lognot (ash mask posn))) - (ash (logand newbyte mask) posn)))) + (ash (logand newbyte mask) posn)))) (defun %deposit-field (newbyte size posn integer) (let ((mask (ash (ldb (byte size 0) -1) posn))) (logior (logand newbyte mask) - (logand integer (lognot mask))))) + (logand integer (lognot mask))))) (defun sb!c::mask-signed-field (size integer) #!+sb-doc @@ -1334,27 +1334,27 @@ the first." "Return the greatest common divisor of the arguments, which must be integers. Gcd with no arguments is defined to be 0." (cond ((null numbers) 0) - ((null (cdr numbers)) (abs (the integer (car numbers)))) - (t - (do ((gcd (the integer (car numbers)) - (gcd gcd (the integer (car rest)))) - (rest (cdr numbers) (cdr rest))) - ((null rest) gcd) - (declare (integer gcd) - (list rest)))))) + ((null (cdr numbers)) (abs (the integer (car numbers)))) + (t + (do ((gcd (the integer (car numbers)) + (gcd gcd (the integer (car rest)))) + (rest (cdr numbers) (cdr rest))) + ((null rest) gcd) + (declare (integer gcd) + (list rest)))))) (defun lcm (&rest numbers) #!+sb-doc "Return the least common multiple of one or more integers. LCM of no arguments is defined to be 1." (cond ((null numbers) 1) - ((null (cdr numbers)) (abs (the integer (car numbers)))) - (t - (do ((lcm (the integer (car numbers)) - (lcm lcm (the integer (car rest)))) - (rest (cdr numbers) (cdr rest))) - ((null rest) lcm) - (declare (integer lcm) (list rest)))))) + ((null (cdr numbers)) (abs (the integer (car numbers)))) + (t + (do ((lcm (the integer (car numbers)) + (lcm lcm (the integer (car rest)))) + (rest (cdr numbers) (cdr rest))) + ((null rest) lcm) + (declare (integer lcm) (list rest)))))) (defun two-arg-lcm (n m) (declare (integer n m)) @@ -1366,12 +1366,12 @@ the first." ;; LCM, and I don't know why. To be investigated. -- CSR, ;; 2003-09-11 (let ((m (abs m)) - (n (abs n))) - (multiple-value-bind (max min) - (if (> m n) - (values m n) - (values n m)) - (* (truncate max (gcd n m)) min))))) + (n (abs n))) + (multiple-value-bind (max min) + (if (> m n) + (values m n) + (values n m)) + (* (truncate max (gcd n m)) min))))) ;;; Do the GCD of two integer arguments. With fixnum arguments, we use the ;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly @@ -1380,38 +1380,38 @@ the first." ;;; about "small bignum" zeros. (defun two-arg-gcd (u v) (cond ((eql u 0) (abs v)) - ((eql v 0) (abs u)) - (t - (number-dispatch ((u integer) (v integer)) - ((fixnum fixnum) - (locally - (declare (optimize (speed 3) (safety 0))) - (do ((k 0 (1+ k)) - (u (abs u) (ash u -1)) - (v (abs v) (ash v -1))) - ((oddp (logior u v)) - (do ((temp (if (oddp u) (- v) (ash u -1)) - (ash temp -1))) - (nil) - (declare (fixnum temp)) - (when (oddp temp) - (if (plusp temp) - (setq u temp) - (setq v (- temp))) - (setq temp (- u v)) - (when (zerop temp) - (let ((res (ash u k))) - (declare (type (signed-byte 31) res) - (optimize (inhibit-warnings 3))) - (return res)))))) - (declare (type (mod 30) k) - (type (signed-byte 31) u v))))) - ((bignum bignum) - (bignum-gcd u v)) - ((bignum fixnum) - (bignum-gcd u (make-small-bignum v))) - ((fixnum bignum) - (bignum-gcd (make-small-bignum u) v)))))) + ((eql v 0) (abs u)) + (t + (number-dispatch ((u integer) (v integer)) + ((fixnum fixnum) + (locally + (declare (optimize (speed 3) (safety 0))) + (do ((k 0 (1+ k)) + (u (abs u) (ash u -1)) + (v (abs v) (ash v -1))) + ((oddp (logior u v)) + (do ((temp (if (oddp u) (- v) (ash u -1)) + (ash temp -1))) + (nil) + (declare (fixnum temp)) + (when (oddp temp) + (if (plusp temp) + (setq u temp) + (setq v (- temp))) + (setq temp (- u v)) + (when (zerop temp) + (let ((res (ash u k))) + (declare (type (signed-byte 31) res) + (optimize (inhibit-warnings 3))) + (return res)))))) + (declare (type (mod 30) k) + (type (signed-byte 31) u v))))) + ((bignum bignum) + (bignum-gcd u v)) + ((bignum fixnum) + (bignum-gcd u (make-small-bignum v))) + ((fixnum bignum) + (bignum-gcd (make-small-bignum u) v)))))) ;;; From discussion on comp.lang.lisp and Akira Kurihara. (defun isqrt (n) @@ -1422,25 +1422,25 @@ the first." ;; Theoretically (> n 7), i.e., n-len-quarter > 0. (if (and (fixnump n) (<= n 24)) (cond ((> n 15) 4) - ((> n 8) 3) - ((> n 3) 2) - ((> n 0) 1) - (t 0)) + ((> n 8) 3) + ((> n 3) 2) + ((> n 0) 1) + (t 0)) (let* ((n-len-quarter (ash (integer-length n) -2)) - (n-half (ash n (- (ash n-len-quarter 1)))) - (n-half-isqrt (isqrt n-half)) - (init-value (ash (1+ n-half-isqrt) n-len-quarter))) - (loop - (let ((iterated-value - (ash (+ init-value (truncate n init-value)) -1))) - (unless (< iterated-value init-value) - (return init-value)) - (setq init-value iterated-value)))))) + (n-half (ash n (- (ash n-len-quarter 1)))) + (n-half-isqrt (isqrt n-half)) + (init-value (ash (1+ n-half-isqrt) n-len-quarter))) + (loop + (let ((iterated-value + (ash (+ init-value (truncate n init-value)) -1))) + (unless (< iterated-value init-value) + (return init-value)) + (setq init-value iterated-value)))))) ;;;; miscellaneous number predicates (macrolet ((def (name doc) - `(defun ,name (number) ,doc (,name number)))) + `(defun ,name (number) ,doc (,name number)))) (def zerop "Is this number zero?") (def plusp "Is this real number strictly positive?") (def minusp "Is this real number strictly negative?") @@ -1509,7 +1509,7 @@ the first." ((unsigned-byte 64) (ldb (byte 64 0) (ash integer amount))) (fixnum (ldb (byte 64 0) (ash (logand integer #xffffffffffffffff) amount))) (bignum (ldb (byte 64 0) - (ash (logand integer #xffffffffffffffff) amount))))) + (ash (logand integer #xffffffffffffffff) amount))))) #!+x86 (defun sb!vm::ash-left-smod30 (integer amount) diff --git a/src/code/octets.lisp b/src/code/octets.lisp index 146f425..c499211 100644 --- a/src/code/octets.lisp +++ b/src/code/octets.lisp @@ -33,11 +33,11 @@ one-past-the-end" (external-format :initarg :external-format :reader octets-encoding-error-external-format)) (:report (lambda (c s) - (format s "Unable to encode character ~A as ~S." - (char-code (char (octets-encoding-error-string c) - (octets-encoding-error-position c))) - (octets-encoding-error-external-format c))))) - + (format s "Unable to encode character ~A as ~S." + (char-code (char (octets-encoding-error-string c) + (octets-encoding-error-position c))) + (octets-encoding-error-external-format c))))) + (defun read-replacement-character () (format *query-io* "Replacement byte, bytes, character, or string (evaluated): ") @@ -47,23 +47,23 @@ one-past-the-end" (defun encoding-error (external-format string pos) (restart-case (error 'octets-encoding-error - :external-format external-format - :string string - :position pos) + :external-format external-format + :string string + :position pos) (use-value (replacement) :report "Supply a set of bytes to use in place of the invalid one." :interactive read-replacement-character (typecase replacement - ((unsigned-byte 8) - (make-array 1 :element-type '(unsigned-byte 8) :initial-element replacement)) - (character - (string-to-octets (string replacement) + ((unsigned-byte 8) + (make-array 1 :element-type '(unsigned-byte 8) :initial-element replacement)) + (character + (string-to-octets (string replacement) + :external-format external-format)) + (string + (string-to-octets replacement :external-format external-format)) - (string - (string-to-octets replacement - :external-format external-format)) - (t - (coerce replacement '(simple-array (unsigned-byte 8) (*)))))))) + (t + (coerce replacement '(simple-array (unsigned-byte 8) (*)))))))) ;;; decoding condition @@ -118,11 +118,11 @@ one-past-the-end" (defun decoding-error (array start end external-format reason pos) (restart-case (error reason - :external-format external-format - :array array - :start start - :end end - :pos pos) + :external-format external-format + :array array + :start start + :end end + :pos pos) (use-value (s) :report "Supply a replacement string designator." :interactive read-replacement-string @@ -142,18 +142,18 @@ one-past-the-end" (declaim (inline varimap)) (defun varimap (to-seq to-start to-end from-start from-end mapper) (declare (optimize speed (safety 0)) - (type array-range to-start to-end from-start from-end) - (type function mapper)) + (type array-range to-start to-end from-start from-end) + (type function mapper)) (loop with from-size of-type array-range = 0 - and to-size of-type array-range = 0 - for to-pos of-type array-range = to-start then (+ to-pos to-size) - for from-pos of-type array-range = from-start then (+ from-pos from-size) - while (and (< to-pos to-end) - (< from-pos from-end)) - do (multiple-value-bind (ts fs) (funcall mapper to-pos from-pos) - (setf to-size ts - from-size fs)) - finally (return (values to-seq to-pos from-pos)))) + and to-size of-type array-range = 0 + for to-pos of-type array-range = to-start then (+ to-pos to-size) + for from-pos of-type array-range = from-start then (+ from-pos from-size) + while (and (< to-pos to-end) + (< from-pos from-end)) + do (multiple-value-bind (ts fs) (funcall mapper to-pos from-pos) + (setf to-size ts + from-size fs)) + finally (return (values to-seq to-pos from-pos)))) ;;; FIXME: find out why the comment about SYMBOLICATE below is true ;;; and fix it, or else replace with SYMBOLICATE. @@ -166,7 +166,7 @@ one-past-the-end" ;; SYMBOLICATE does; MAKE-OD-NAME ("octets definition") it is ;; then. (intern (concatenate 'string (symbol-name sym1) "-" (symbol-name sym2)) - (symbol-package sym1)))) + (symbol-package sym1)))) ;;;; to-octets conversions @@ -177,25 +177,25 @@ one-past-the-end" (declaim (inline ,byte-char-name ,code-byte-name)) (defun ,byte-char-name (byte) (declare (optimize speed (safety 0)) - (type (unsigned-byte 8) byte)) + (type (unsigned-byte 8) byte)) (aref ,(make-array 256 - :initial-contents (loop for byte below 256 - collect - (let ((exception (cadr (assoc byte exceptions)))) - (if exception - exception - byte)))) - byte)) + :initial-contents (loop for byte below 256 + collect + (let ((exception (cadr (assoc byte exceptions)))) + (if exception + exception + byte)))) + byte)) (defun ,code-byte-name (code) (declare (optimize speed (safety 0)) - (type char-code code)) + (type char-code code)) (case code - (,(mapcar #'car exceptions) nil) - ,@(mapcar (lambda (exception) - (destructuring-bind (byte code) exception - `(,code ,byte))) - exceptions) - (otherwise code))))) + (,(mapcar #'car exceptions) nil) + ,@(mapcar (lambda (exception) + (destructuring-bind (byte code) exception + `(,code ,byte))) + exceptions) + (otherwise code))))) #!+sb-unicode (define-unibyte-mapper @@ -215,15 +215,15 @@ one-past-the-end" (declare (ignore end)) (let ((code (funcall mapper (char-code (char string pos))))) (values (cond - ((and code (< code 256)) code) - (t - (encoding-error external-format string pos))) - 1))) + ((and code (< code 256)) code) + (t + (encoding-error external-format string pos))) + 1))) (declaim (inline code->ascii-mapper)) (defun code->ascii-mapper (code) (declare (optimize speed (safety 0)) - (type char-code code)) + (type char-code code)) (if (> code 127) nil code)) @@ -231,15 +231,15 @@ one-past-the-end" (declaim (inline get-ascii-bytes)) (defun get-ascii-bytes (string pos end) (declare (optimize speed (safety 0)) - (type simple-string string) - (type array-range pos end)) + (type simple-string string) + (type array-range pos end)) (get-latin-bytes #'code->ascii-mapper :ascii string pos end)) (declaim (inline get-latin1-bytes)) (defun get-latin1-bytes (string pos end) (declare (optimize speed (safety 0)) - (type simple-string string) - (type array-range pos end)) + (type simple-string string) + (type array-range pos end)) (get-latin-bytes #'identity :latin-1 string pos end)) #!+sb-unicode @@ -254,40 +254,40 @@ one-past-the-end" (declaim (inline string->latin%)) (defun string->latin% (string sstart send get-bytes null-padding) (declare (optimize speed) - (type simple-string string) - (type array-range sstart send null-padding) - (type function get-bytes)) + (type simple-string string) + (type array-range sstart send null-padding) + (type function get-bytes)) (let ((octets (make-array 0 :adjustable t :fill-pointer 0 :element-type '(unsigned-byte 8)))) (loop for pos from sstart below send - do (let ((byte-or-bytes (funcall get-bytes string pos send))) - (declare (type (or (unsigned-byte 8) (simple-array (unsigned-byte 8) (*))) byte-or-bytes)) - (cond - ((numberp byte-or-bytes) - (vector-push-extend byte-or-bytes octets)) - (t - (dotimes (i (length byte-or-bytes)) - (vector-push-extend (aref byte-or-bytes i) octets)))))) + do (let ((byte-or-bytes (funcall get-bytes string pos send))) + (declare (type (or (unsigned-byte 8) (simple-array (unsigned-byte 8) (*))) byte-or-bytes)) + (cond + ((numberp byte-or-bytes) + (vector-push-extend byte-or-bytes octets)) + (t + (dotimes (i (length byte-or-bytes)) + (vector-push-extend (aref byte-or-bytes i) octets)))))) (dotimes (i null-padding) (vector-push-extend 0 octets)) (coerce octets '(simple-array (unsigned-byte 8) (*))))) (defun string->ascii (string sstart send null-padding) (declare (optimize speed (safety 0)) - (type simple-string string) - (type array-range sstart send)) + (type simple-string string) + (type array-range sstart send)) (values (string->latin% string sstart send #'get-ascii-bytes null-padding))) (defun string->latin1 (string sstart send null-padding) (declare (optimize speed (safety 0)) - (type simple-string string) - (type array-range sstart send)) + (type simple-string string) + (type array-range sstart send)) (values (string->latin% string sstart send #'get-latin1-bytes null-padding))) #!+sb-unicode (defun string->latin9 (string sstart send null-padding) (declare (optimize speed (safety 0)) - (type simple-string string) - (type array-range sstart send)) + (type simple-string string) + (type array-range sstart send)) (values (string->latin% string sstart send #'get-latin9-bytes null-padding))) ;;; to utf8 @@ -295,49 +295,49 @@ one-past-the-end" (declaim (inline char-len-as-utf8)) (defun char-len-as-utf8 (code) (declare (optimize speed (safety 0)) - (type (integer 0 (#.sb!xc:char-code-limit)) code)) + (type (integer 0 (#.sb!xc:char-code-limit)) code)) (cond ((< code 0) (bug "can't happen")) - ((< code #x80) 1) - ((< code #x800) 2) - ((< code #x10000) 3) - ((< code #x110000) 4) - (t (bug "can't happen")))) + ((< code #x80) 1) + ((< code #x800) 2) + ((< code #x10000) 3) + ((< code #x110000) 4) + (t (bug "can't happen")))) (declaim (inline char->utf8)) (defun char->utf8 (char dest) (declare (optimize speed (safety 0)) - (type (array (unsigned-byte 8) (*)) dest)) + (type (array (unsigned-byte 8) (*)) dest)) (let ((code (char-code char))) (flet ((add-byte (b) - (declare (type (unsigned-byte 8) b)) - (vector-push-extend b dest))) + (declare (type (unsigned-byte 8) b)) + (vector-push-extend b dest))) (declare (inline add-byte)) (ecase (char-len-as-utf8 code) - (1 - (add-byte code)) - (2 - (add-byte (logior #b11000000 (ldb (byte 5 6) code))) - (add-byte (logior #b10000000 (ldb (byte 6 0) code)))) - (3 - (add-byte (logior #b11100000 (ldb (byte 4 12) code))) - (add-byte (logior #b10000000 (ldb (byte 6 6) code))) - (add-byte (logior #b10000000 (ldb (byte 6 0) code)))) - (4 - (add-byte (logior #b11110000 (ldb (byte 3 18) code))) - (add-byte (logior #b10000000 (ldb (byte 6 12) code))) - (add-byte (logior #b10000000 (ldb (byte 6 6) code))) - (add-byte (logior #b10000000 (ldb (byte 6 0) code)))))))) + (1 + (add-byte code)) + (2 + (add-byte (logior #b11000000 (ldb (byte 5 6) code))) + (add-byte (logior #b10000000 (ldb (byte 6 0) code)))) + (3 + (add-byte (logior #b11100000 (ldb (byte 4 12) code))) + (add-byte (logior #b10000000 (ldb (byte 6 6) code))) + (add-byte (logior #b10000000 (ldb (byte 6 0) code)))) + (4 + (add-byte (logior #b11110000 (ldb (byte 3 18) code))) + (add-byte (logior #b10000000 (ldb (byte 6 12) code))) + (add-byte (logior #b10000000 (ldb (byte 6 6) code))) + (add-byte (logior #b10000000 (ldb (byte 6 0) code)))))))) (defun string->utf8 (string sstart send additional-space) (declare (optimize speed (safety 0)) - (type simple-string string) - (type array-range sstart send additional-space)) + (type simple-string string) + (type array-range sstart send additional-space)) (let ((array (make-array (+ additional-space (- send sstart)) - :element-type '(unsigned-byte 8) - :adjustable t - :fill-pointer 0))) + :element-type '(unsigned-byte 8) + :adjustable t + :fill-pointer 0))) (loop for i from sstart below send - do (char->utf8 (char string i) array)) + do (char->utf8 (char string i) array)) (dotimes (i additional-space) (vector-push-extend 0 array)) (coerce array '(simple-array (unsigned-byte 8) (*))))) @@ -350,24 +350,24 @@ one-past-the-end" (let ((name (make-od-name 'ascii->string accessor))) `(progn (defun ,name (array astart aend) - (declare (optimize speed) - (type ,type array) - (type array-range astart aend)) - ;; Since there is such a thing as a malformed ascii byte, a - ;; simple "make the string, fill it in" won't do. - (let ((string (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t))) - (loop for apos from astart below aend - do (let* ((code (,accessor array apos)) - (string-content - (if (< code 128) - (code-char code) - (decoding-error array apos (1+ apos) :ascii - 'malformed-ascii apos)))) - (if (characterp string-content) - (vector-push-extend string-content string) - (loop for c across string-content - do (vector-push-extend c string)))) - finally (return (coerce string 'simple-string)))))))) + (declare (optimize speed) + (type ,type array) + (type array-range astart aend)) + ;; Since there is such a thing as a malformed ascii byte, a + ;; simple "make the string, fill it in" won't do. + (let ((string (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t))) + (loop for apos from astart below aend + do (let* ((code (,accessor array apos)) + (string-content + (if (< code 128) + (code-char code) + (decoding-error array apos (1+ apos) :ascii + 'malformed-ascii apos)))) + (if (characterp string-content) + (vector-push-extend string-content string) + (loop for c across string-content + do (vector-push-extend c string)))) + finally (return (coerce string 'simple-string)))))))) (instantiate-octets-definition define-ascii->string) (defmacro define-latin->string* (accessor type) @@ -375,16 +375,16 @@ one-past-the-end" `(progn (declaim (inline ,name)) (defun ,name (string sstart send array astart aend mapper) - (declare (optimize speed (safety 0)) - (type simple-string string) - (type ,type array) - (type array-range sstart send astart aend) - (function mapper)) - (varimap string sstart send - astart aend - (lambda (spos apos) - (setf (char string spos) (code-char (funcall mapper (,accessor array apos)))) - (values 1 1))))))) + (declare (optimize speed (safety 0)) + (type simple-string string) + (type ,type array) + (type array-range sstart send astart aend) + (function mapper)) + (varimap string sstart send + astart aend + (lambda (spos apos) + (setf (char string spos) (code-char (funcall mapper (,accessor array apos)))) + (values 1 1))))))) (instantiate-octets-definition define-latin->string*) (defmacro define-latin1->string* (accessor type) @@ -392,7 +392,7 @@ one-past-the-end" (let ((name (make-od-name 'latin1->string* accessor))) `(progn (defun ,name (string sstart send array astart aend) - (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'identity))))) + (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'identity))))) (instantiate-octets-definition define-latin1->string*) #!+sb-unicode @@ -410,14 +410,14 @@ one-past-the-end" `(progn (declaim (inline latin->string)) (defun ,name (array astart aend mapper) - (declare (optimize speed (safety 0)) - (type ,type array) - (type array-range astart aend) - (type function mapper)) - (let ((length (the array-range (- aend astart)))) - (values (,(make-od-name 'latin->string* accessor) (make-string length) 0 length - array astart aend - mapper))))))) + (declare (optimize speed (safety 0)) + (type ,type array) + (type array-range astart aend) + (type function mapper)) + (let ((length (the array-range (- aend astart)))) + (values (,(make-od-name 'latin->string* accessor) (make-string length) 0 length + array astart aend + mapper))))))) (instantiate-octets-definition define-latin->string) (defmacro define-latin1->string (accessor type) @@ -443,140 +443,140 @@ one-past-the-end" (let ((lexically-max (string->utf8 (string (code-char ,(1- sb!xc:char-code-limit))) 0 1 0))) - (declare (type (simple-array (unsigned-byte 8) (#!+sb-unicode 4 #!-sb-unicode 2)) lexically-max)) - (defun ,name (array pos end) - (declare (optimize speed (safety 0)) - (type ,type array) - (type array-range pos end)) - ;; returns the number of bytes consumed and nil if it's a - ;; valid character or the number of bytes consumed and a - ;; replacement string if it's not. - (let ((initial-byte (,accessor array pos)) - (reject-reason nil) - (reject-position pos) - (remaining-bytes (- end pos))) - (declare (type array-range reject-position remaining-bytes)) - (labels ((valid-utf8-starter-byte-p (b) - (declare (type (unsigned-byte 8) b)) - (let ((ok (cond - ((zerop (logand b #b10000000)) 1) - ((= (logand b #b11100000) #b11000000) - 2) - ((= (logand b #b11110000) #b11100000) - 3) - ((= (logand b #b11111000) #b11110000) - 4) - ((= (logand b #b11111100) #b11111000) - 5) - ((= (logand b #b11111110) #b11111100) - 6) - (t - nil)))) - (unless ok - (setf reject-reason 'invalid-utf8-starter-byte)) - ok)) - (enough-bytes-left-p (x) - (let ((ok (> end (+ pos (1- x))))) - (unless ok - (setf reject-reason 'end-of-input-in-character)) - ok)) - (valid-secondary-p (x) - (let* ((idx (the array-range (+ pos x))) - (b (,accessor array idx)) - (ok (= (logand b #b11000000) #b10000000))) - (unless ok - (setf reject-reason 'invalid-utf8-continuation-byte) - (setf reject-position idx)) - ok)) - (preliminary-ok-for-length (maybe-len len) - (and (eql maybe-len len) - ;; Has to be done in this order so that - ;; certain broken sequences (e.g., the - ;; two-byte sequence `"initial (length 3)" - ;; "non-continuation"' -- `#xef #x32') - ;; signal only part of that sequence as - ;; erronous. - (loop for i from 1 below (min len remaining-bytes) - always (valid-secondary-p i)) - (enough-bytes-left-p len))) - (overlong-chk (x y) - (let ((ok (or (/= initial-byte x) - (/= (logior (,accessor array (the array-range (+ pos 1))) - y) - y)))) - (unless ok - (setf reject-reason 'overlong-utf8-sequence)) - ok)) - (character-below-char-code-limit-p () - ;; This is only called on a four-byte sequence - ;; (two in non-unicode builds) to ensure we - ;; don't go over SBCL's character limts. - (let ((ok (cond ((< (aref lexically-max 0) (,accessor array pos)) - nil) - ((> (aref lexically-max 0) (,accessor array pos)) - t) - ((< (aref lexically-max 1) (,accessor array (+ pos 1))) - nil) - #!+sb-unicode - ((> (aref lexically-max 1) (,accessor array (+ pos 1))) - t) - #!+sb-unicode - ((< (aref lexically-max 2) (,accessor array (+ pos 2))) - nil) - #!+sb-unicode - ((> (aref lexically-max 2) (,accessor array (+ pos 2))) - t) - #!+sb-unicode - ((< (aref lexically-max 3) (,accessor array (+ pos 3))) - nil) - (t t)))) - (unless ok - (setf reject-reason 'character-out-of-range)) - ok))) - (declare (inline valid-utf8-starter-byte-p - enough-bytes-left-p - valid-secondary-p - preliminary-ok-for-length - overlong-chk)) - (let ((maybe-len (valid-utf8-starter-byte-p initial-byte))) - (cond ((eql maybe-len 1) - (values 1 nil)) - ((and (preliminary-ok-for-length maybe-len 2) - (overlong-chk #b11000000 #b10111111) - (overlong-chk #b11000001 #b10111111) - #!-sb-unicode (character-below-char-code-limit-p)) - (values 2 nil)) - ((and (preliminary-ok-for-length maybe-len 3) - (overlong-chk #b11100000 #b10011111) - #!-sb-unicode (not (setf reject-reason 'character-out-of-range))) - (values 3 nil)) - ((and (preliminary-ok-for-length maybe-len 4) - (overlong-chk #b11110000 #b10001111) - #!-sb-unicode (not (setf reject-reason 'character-out-of-range)) - (character-below-char-code-limit-p)) - (values 4 nil)) - ((and (preliminary-ok-for-length maybe-len 5) - (overlong-chk #b11111000 #b10000111) - (not (setf reject-reason 'character-out-of-range))) - (bug "can't happen")) - ((and (preliminary-ok-for-length maybe-len 6) - (overlong-chk #b11111100 #b10000011) - (not (setf reject-reason 'character-out-of-range))) - (bug "can't happen")) - (t - (let* ((bad-end (ecase reject-reason - (invalid-utf8-starter-byte - (1+ pos)) - (end-of-input-in-character - end) - (invalid-utf8-continuation-byte - reject-position) - ((overlong-utf8-sequence character-out-of-range) - (+ pos maybe-len)))) - (bad-len (- bad-end pos))) - (declare (type array-range bad-end bad-len)) - (let ((replacement (decoding-error array pos bad-end :utf-8 reject-reason reject-position))) - (values bad-len replacement))))))))))))) + (declare (type (simple-array (unsigned-byte 8) (#!+sb-unicode 4 #!-sb-unicode 2)) lexically-max)) + (defun ,name (array pos end) + (declare (optimize speed (safety 0)) + (type ,type array) + (type array-range pos end)) + ;; returns the number of bytes consumed and nil if it's a + ;; valid character or the number of bytes consumed and a + ;; replacement string if it's not. + (let ((initial-byte (,accessor array pos)) + (reject-reason nil) + (reject-position pos) + (remaining-bytes (- end pos))) + (declare (type array-range reject-position remaining-bytes)) + (labels ((valid-utf8-starter-byte-p (b) + (declare (type (unsigned-byte 8) b)) + (let ((ok (cond + ((zerop (logand b #b10000000)) 1) + ((= (logand b #b11100000) #b11000000) + 2) + ((= (logand b #b11110000) #b11100000) + 3) + ((= (logand b #b11111000) #b11110000) + 4) + ((= (logand b #b11111100) #b11111000) + 5) + ((= (logand b #b11111110) #b11111100) + 6) + (t + nil)))) + (unless ok + (setf reject-reason 'invalid-utf8-starter-byte)) + ok)) + (enough-bytes-left-p (x) + (let ((ok (> end (+ pos (1- x))))) + (unless ok + (setf reject-reason 'end-of-input-in-character)) + ok)) + (valid-secondary-p (x) + (let* ((idx (the array-range (+ pos x))) + (b (,accessor array idx)) + (ok (= (logand b #b11000000) #b10000000))) + (unless ok + (setf reject-reason 'invalid-utf8-continuation-byte) + (setf reject-position idx)) + ok)) + (preliminary-ok-for-length (maybe-len len) + (and (eql maybe-len len) + ;; Has to be done in this order so that + ;; certain broken sequences (e.g., the + ;; two-byte sequence `"initial (length 3)" + ;; "non-continuation"' -- `#xef #x32') + ;; signal only part of that sequence as + ;; erronous. + (loop for i from 1 below (min len remaining-bytes) + always (valid-secondary-p i)) + (enough-bytes-left-p len))) + (overlong-chk (x y) + (let ((ok (or (/= initial-byte x) + (/= (logior (,accessor array (the array-range (+ pos 1))) + y) + y)))) + (unless ok + (setf reject-reason 'overlong-utf8-sequence)) + ok)) + (character-below-char-code-limit-p () + ;; This is only called on a four-byte sequence + ;; (two in non-unicode builds) to ensure we + ;; don't go over SBCL's character limts. + (let ((ok (cond ((< (aref lexically-max 0) (,accessor array pos)) + nil) + ((> (aref lexically-max 0) (,accessor array pos)) + t) + ((< (aref lexically-max 1) (,accessor array (+ pos 1))) + nil) + #!+sb-unicode + ((> (aref lexically-max 1) (,accessor array (+ pos 1))) + t) + #!+sb-unicode + ((< (aref lexically-max 2) (,accessor array (+ pos 2))) + nil) + #!+sb-unicode + ((> (aref lexically-max 2) (,accessor array (+ pos 2))) + t) + #!+sb-unicode + ((< (aref lexically-max 3) (,accessor array (+ pos 3))) + nil) + (t t)))) + (unless ok + (setf reject-reason 'character-out-of-range)) + ok))) + (declare (inline valid-utf8-starter-byte-p + enough-bytes-left-p + valid-secondary-p + preliminary-ok-for-length + overlong-chk)) + (let ((maybe-len (valid-utf8-starter-byte-p initial-byte))) + (cond ((eql maybe-len 1) + (values 1 nil)) + ((and (preliminary-ok-for-length maybe-len 2) + (overlong-chk #b11000000 #b10111111) + (overlong-chk #b11000001 #b10111111) + #!-sb-unicode (character-below-char-code-limit-p)) + (values 2 nil)) + ((and (preliminary-ok-for-length maybe-len 3) + (overlong-chk #b11100000 #b10011111) + #!-sb-unicode (not (setf reject-reason 'character-out-of-range))) + (values 3 nil)) + ((and (preliminary-ok-for-length maybe-len 4) + (overlong-chk #b11110000 #b10001111) + #!-sb-unicode (not (setf reject-reason 'character-out-of-range)) + (character-below-char-code-limit-p)) + (values 4 nil)) + ((and (preliminary-ok-for-length maybe-len 5) + (overlong-chk #b11111000 #b10000111) + (not (setf reject-reason 'character-out-of-range))) + (bug "can't happen")) + ((and (preliminary-ok-for-length maybe-len 6) + (overlong-chk #b11111100 #b10000011) + (not (setf reject-reason 'character-out-of-range))) + (bug "can't happen")) + (t + (let* ((bad-end (ecase reject-reason + (invalid-utf8-starter-byte + (1+ pos)) + (end-of-input-in-character + end) + (invalid-utf8-continuation-byte + reject-position) + ((overlong-utf8-sequence character-out-of-range) + (+ pos maybe-len)))) + (bad-len (- bad-end pos))) + (declare (type array-range bad-end bad-len)) + (let ((replacement (decoding-error array pos bad-end :utf-8 reject-reason reject-position))) + (values bad-len replacement))))))))))))) (instantiate-octets-definition define-bytes-per-utf8-character) (defmacro define-simple-get-utf8-char (accessor type) @@ -584,58 +584,58 @@ one-past-the-end" `(progn (declaim (inline ,name)) (defun ,name (array pos bytes) - (declare (optimize speed (safety 0)) - (type ,type array) - (type array-range pos) - (type (integer 1 4) bytes)) - (flet ((cref (x) - (,accessor array (the array-range (+ pos x))))) - (declare (inline cref)) - (code-char (ecase bytes - (1 (cref 0)) - (2 (logior (ash (ldb (byte 5 0) (cref 0)) 6) - (ldb (byte 6 0) (cref 1)))) - (3 (logior (ash (ldb (byte 4 0) (cref 0)) 12) - (ash (ldb (byte 6 0) (cref 1)) 6) - (ldb (byte 6 0) (cref 2)))) - (4 (logior (ash (ldb (byte 3 0) (cref 0)) 18) - (ash (ldb (byte 6 0) (cref 1)) 12) - (ash (ldb (byte 6 0) (cref 2)) 6) - (ldb (byte 6 0) (cref 3))))))))))) + (declare (optimize speed (safety 0)) + (type ,type array) + (type array-range pos) + (type (integer 1 4) bytes)) + (flet ((cref (x) + (,accessor array (the array-range (+ pos x))))) + (declare (inline cref)) + (code-char (ecase bytes + (1 (cref 0)) + (2 (logior (ash (ldb (byte 5 0) (cref 0)) 6) + (ldb (byte 6 0) (cref 1)))) + (3 (logior (ash (ldb (byte 4 0) (cref 0)) 12) + (ash (ldb (byte 6 0) (cref 1)) 6) + (ldb (byte 6 0) (cref 2)))) + (4 (logior (ash (ldb (byte 3 0) (cref 0)) 18) + (ash (ldb (byte 6 0) (cref 1)) 12) + (ash (ldb (byte 6 0) (cref 2)) 6) + (ldb (byte 6 0) (cref 3))))))))))) (instantiate-octets-definition define-simple-get-utf8-char) (defmacro define-utf8->string (accessor type) (let ((name (make-od-name 'utf8->string accessor))) `(progn (defun ,name (array astart aend) - (declare (optimize speed (safety 0)) - (type ,type array) - (type array-range astart aend)) - (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) - (loop with pos = astart - while (< pos aend) - do (multiple-value-bind (bytes invalid) - (,(make-od-name 'bytes-per-utf8-character accessor) array pos aend) - (declare (type (or null string) invalid)) - (cond - ((null invalid) - (vector-push-extend (,(make-od-name 'simple-get-utf8-char accessor) array pos bytes) string)) - (t - (dotimes (i (length invalid)) - (vector-push-extend (char invalid i) string)))) - (incf pos bytes))) - (coerce string 'simple-string)))))) + (declare (optimize speed (safety 0)) + (type ,type array) + (type array-range astart aend)) + (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) + (loop with pos = astart + while (< pos aend) + do (multiple-value-bind (bytes invalid) + (,(make-od-name 'bytes-per-utf8-character accessor) array pos aend) + (declare (type (or null string) invalid)) + (cond + ((null invalid) + (vector-push-extend (,(make-od-name 'simple-get-utf8-char accessor) array pos bytes) string)) + (t + (dotimes (i (length invalid)) + (vector-push-extend (char invalid i) string)))) + (incf pos bytes))) + (coerce string 'simple-string)))))) (instantiate-octets-definition define-utf8->string) ;;;; external formats (defun default-external-format () (intern (or (sb!alien:alien-funcall - (extern-alien "nl_langinfo" - (function c-string int)) - sb!unix:codeset) - "LATIN-1") - "KEYWORD")) + (extern-alien "nl_langinfo" + (function c-string int)) + sb!unix:codeset) + "LATIN-1") + "KEYWORD")) ;;; FIXME: OAOOM here vrt. DEFINE-EXTERNAL-FORMAT in fd-stream.lisp (defparameter *external-format-functions* @@ -653,8 +653,8 @@ one-past-the-end" (when (eql external-format :default) (setf external-format (default-external-format))) (or (cdr (find external-format (the list *external-format-functions*) - :test #'member - :key #'car)) + :test #'member + :key #'car)) (error "Unknown external-format ~S" external-format))) ;;;; public interface @@ -695,6 +695,6 @@ one-past-the-end" (let ((cname (gensym))) `(let ((,cname ,c)) (handler-bind - ((octet-decoding-error (lambda (c) - (use-value ,cname c)))) + ((octet-decoding-error (lambda (c) + (use-value ,cname c)))) ,@body)))) diff --git a/src/code/osf1-os.lisp b/src/code/osf1-os.lisp index 496e6b2..2ef75b8 100644 --- a/src/code/osf1-os.lisp +++ b/src/code/osf1-os.lisp @@ -28,22 +28,22 @@ if not available." (or *software-version* (setf *software-version* - (string-trim '(#\newline) - (with-output-to-string (stream) - (sb!ext:run-program "/bin/uname" `("-r") - :output stream)))))) + (string-trim '(#\newline) + (with-output-to-string (stream) + (sb!ext:run-program "/bin/uname" `("-r") + :output stream)))))) (defun os-cold-init-or-reinit () ; KLUDGE: don't know what to do here (/show "entering osf1-os.lisp OS-COLD-INIT-OR-REINIT") (setf *software-version* nil) (/show "setting *DEFAULT-PATHNAME-DEFAULTS*") (setf *default-pathname-defaults* - ;; (temporary value, so that #'PATHNAME won't blow up when - ;; we call it below:) - (make-trivial-default-pathname) - *default-pathname-defaults* - ;; (final value, constructed using #'PATHNAME:) - (pathname (sb!unix:posix-getcwd/))) + ;; (temporary value, so that #'PATHNAME won't blow up when + ;; we call it below:) + (make-trivial-default-pathname) + *default-pathname-defaults* + ;; (final value, constructed using #'PATHNAME:) + (pathname (sb!unix:posix-getcwd/))) (/show "leaving osf1-os.lisp OS-COLD-INIT-OR-REINIT")) ;;; Return system time, user time and number of page faults. diff --git a/src/code/package.lisp b/src/code/package.lisp index 80455ac..c636fdd 100644 --- a/src/code/package.lisp +++ b/src/code/package.lisp @@ -33,9 +33,9 @@ (def!type hash-vector () '(simple-array (unsigned-byte 8) (*))) (def!struct (package-hashtable - (:constructor %make-package-hashtable - (table hash size &aux (free size))) - (:copier nil)) + (:constructor %make-package-hashtable + (table hash size &aux (free size))) + (:copier nil)) ;; The g-vector of symbols. (table (missing-arg) :type simple-vector) ;; The i-vector of pname hash values. @@ -64,12 +64,12 @@ ;;; around by putting the new PACKAGE type (and the PACKAGEP predicate ;;; too..) into SB!XC. -- WHN 20000309 (def!struct (sb!xc:package - (:constructor internal-make-package) - (:make-load-form-fun (lambda (p) - (values `(find-undeleted-package-or-lose - ',(package-name p)) - nil))) - (:predicate sb!xc:packagep)) + (:constructor internal-make-package) + (:make-load-form-fun (lambda (p) + (values `(find-undeleted-package-or-lose + ',(package-name p)) + nil))) + (:predicate sb!xc:packagep)) #!+sb-doc "the standard structure for the description of a package" ;; the name of the package, or NIL for a deleted package @@ -109,9 +109,9 @@ ;;;; iteration macros (defmacro-mundanely do-symbols ((var &optional - (package '*package*) - result-form) - &body body-decls) + (package '*package*) + result-form) + &body body-decls) #!+sb-doc "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}* Executes the FORMs at least once for each symbol accessible in the given @@ -120,34 +120,34 @@ (parse-body body-decls :doc-string-allowed nil) (let ((flet-name (gensym "DO-SYMBOLS-"))) `(block nil - (flet ((,flet-name (,var) - ,@decls - (tagbody ,@body))) - (let* ((package (find-undeleted-package-or-lose ,package)) - (shadows (package-%shadowing-symbols package))) - (flet ((iterate-over-hash-table (table ignore) - (let ((hash-vec (package-hashtable-hash table)) - (sym-vec (package-hashtable-table table))) - (dotimes (i (length sym-vec)) - (when (>= (aref hash-vec i) 2) - (let ((sym (aref sym-vec i))) - (declare (inline member)) - (unless (member sym ignore :test #'string=) - (,flet-name sym)))))))) - (iterate-over-hash-table (package-internal-symbols package) nil) - (iterate-over-hash-table (package-external-symbols package) nil) - (dolist (use (package-%use-list package)) - (iterate-over-hash-table (package-external-symbols use) - shadows))))) - (let ((,var nil)) - (declare (ignorable ,var)) - ,@decls - ,result-form))))) + (flet ((,flet-name (,var) + ,@decls + (tagbody ,@body))) + (let* ((package (find-undeleted-package-or-lose ,package)) + (shadows (package-%shadowing-symbols package))) + (flet ((iterate-over-hash-table (table ignore) + (let ((hash-vec (package-hashtable-hash table)) + (sym-vec (package-hashtable-table table))) + (dotimes (i (length sym-vec)) + (when (>= (aref hash-vec i) 2) + (let ((sym (aref sym-vec i))) + (declare (inline member)) + (unless (member sym ignore :test #'string=) + (,flet-name sym)))))))) + (iterate-over-hash-table (package-internal-symbols package) nil) + (iterate-over-hash-table (package-external-symbols package) nil) + (dolist (use (package-%use-list package)) + (iterate-over-hash-table (package-external-symbols use) + shadows))))) + (let ((,var nil)) + (declare (ignorable ,var)) + ,@decls + ,result-form))))) (defmacro-mundanely do-external-symbols ((var &optional - (package '*package*) - result-form) - &body body-decls) + (package '*package*) + result-form) + &body body-decls) #!+sb-doc "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}* Executes the FORMs once for each external symbol in the given PACKAGE with @@ -156,24 +156,24 @@ (parse-body body-decls :doc-string-allowed nil) (let ((flet-name (gensym "DO-SYMBOLS-"))) `(block nil - (flet ((,flet-name (,var) - ,@decls - (tagbody ,@body))) - (let* ((package (find-undeleted-package-or-lose ,package)) - (table (package-external-symbols package)) - (hash-vec (package-hashtable-hash table)) - (sym-vec (package-hashtable-table table))) - (dotimes (i (length sym-vec)) - (when (>= (aref hash-vec i) 2) - (,flet-name (aref sym-vec i)))))) - (let ((,var nil)) - (declare (ignorable ,var)) - ,@decls - ,result-form))))) + (flet ((,flet-name (,var) + ,@decls + (tagbody ,@body))) + (let* ((package (find-undeleted-package-or-lose ,package)) + (table (package-external-symbols package)) + (hash-vec (package-hashtable-hash table)) + (sym-vec (package-hashtable-table table))) + (dotimes (i (length sym-vec)) + (when (>= (aref hash-vec i) 2) + (,flet-name (aref sym-vec i)))))) + (let ((,var nil)) + (declare (ignorable ,var)) + ,@decls + ,result-form))))) (defmacro-mundanely do-all-symbols ((var &optional - result-form) - &body body-decls) + result-form) + &body body-decls) #!+sb-doc "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}* Executes the FORMs once for each symbol in every package with VAR bound @@ -182,198 +182,198 @@ (parse-body body-decls :doc-string-allowed nil) (let ((flet-name (gensym "DO-SYMBOLS-"))) `(block nil - (flet ((,flet-name (,var) - ,@decls - (tagbody ,@body))) - (dolist (package (list-all-packages)) - (flet ((iterate-over-hash-table (table) - (let ((hash-vec (package-hashtable-hash table)) - (sym-vec (package-hashtable-table table))) - (dotimes (i (length sym-vec)) - (when (>= (aref hash-vec i) 2) - (,flet-name (aref sym-vec i))))))) - (iterate-over-hash-table (package-internal-symbols package)) - (iterate-over-hash-table (package-external-symbols package))))) - (let ((,var nil)) - (declare (ignorable ,var)) - ,@decls - ,result-form))))) + (flet ((,flet-name (,var) + ,@decls + (tagbody ,@body))) + (dolist (package (list-all-packages)) + (flet ((iterate-over-hash-table (table) + (let ((hash-vec (package-hashtable-hash table)) + (sym-vec (package-hashtable-table table))) + (dotimes (i (length sym-vec)) + (when (>= (aref hash-vec i) 2) + (,flet-name (aref sym-vec i))))))) + (iterate-over-hash-table (package-internal-symbols package)) + (iterate-over-hash-table (package-external-symbols package))))) + (let ((,var nil)) + (declare (ignorable ,var)) + ,@decls + ,result-form))))) ;;;; WITH-PACKAGE-ITERATOR (defmacro-mundanely with-package-iterator ((mname package-list - &rest symbol-types) - &body body) + &rest symbol-types) + &body body) #!+sb-doc "Within the lexical scope of the body forms, MNAME is defined via macrolet such that successive invocations of (MNAME) will return the symbols, one by one, from the packages in PACKAGE-LIST. SYMBOL-TYPES may be any of :INHERITED :EXTERNAL :INTERNAL." (let* ((packages (gensym)) - (these-packages (gensym)) - (ordered-types (let ((res nil)) - (dolist (kind '(:inherited :external :internal) - res) - (when (member kind symbol-types) - (push kind res))))) ; Order SYMBOL-TYPES. - (counter (gensym)) - (kind (gensym)) - (hash-vector (gensym)) - (vector (gensym)) - (package-use-list (gensym)) - (init-macro (gensym)) - (end-test-macro (gensym)) - (real-symbol-p (gensym)) - (inherited-symbol-p (gensym)) - (BLOCK (gensym))) + (these-packages (gensym)) + (ordered-types (let ((res nil)) + (dolist (kind '(:inherited :external :internal) + res) + (when (member kind symbol-types) + (push kind res))))) ; Order SYMBOL-TYPES. + (counter (gensym)) + (kind (gensym)) + (hash-vector (gensym)) + (vector (gensym)) + (package-use-list (gensym)) + (init-macro (gensym)) + (end-test-macro (gensym)) + (real-symbol-p (gensym)) + (inherited-symbol-p (gensym)) + (BLOCK (gensym))) `(let* ((,these-packages ,package-list) - (,packages `,(mapcar (lambda (package) - (if (packagep package) - package - ;; Maybe FIND-PACKAGE-OR-DIE? - (or (find-package package) - (error 'simple-package-error - ;; could be a character - :name (string package) - :format-control "~@<~S does not name a package ~:>" - :format-arguments (list package))))) - (if (consp ,these-packages) - ,these-packages - (list ,these-packages)))) - (,counter nil) - (,kind (car ,packages)) - (,hash-vector nil) - (,vector nil) - (,package-use-list nil)) + (,packages `,(mapcar (lambda (package) + (if (packagep package) + package + ;; Maybe FIND-PACKAGE-OR-DIE? + (or (find-package package) + (error 'simple-package-error + ;; could be a character + :name (string package) + :format-control "~@<~S does not name a package ~:>" + :format-arguments (list package))))) + (if (consp ,these-packages) + ,these-packages + (list ,these-packages)))) + (,counter nil) + (,kind (car ,packages)) + (,hash-vector nil) + (,vector nil) + (,package-use-list nil)) ,(if (member :inherited ordered-types) - `(setf ,package-use-list (package-%use-list (car ,packages))) - `(declare (ignore ,package-use-list))) + `(setf ,package-use-list (package-%use-list (car ,packages))) + `(declare (ignore ,package-use-list))) (macrolet ((,init-macro (next-kind) - (declare (optimize (inhibit-warnings 3))) - (let ((symbols (gensym))) - `(progn - (setf ,',kind ,next-kind) - (setf ,',counter nil) - ,(case next-kind - (:internal - `(let ((,symbols (package-internal-symbols - (car ,',packages)))) - (when ,symbols - (setf ,',vector (package-hashtable-table ,symbols)) - (setf ,',hash-vector - (package-hashtable-hash ,symbols))))) - (:external - `(let ((,symbols (package-external-symbols - (car ,',packages)))) - (when ,symbols - (setf ,',vector (package-hashtable-table ,symbols)) - (setf ,',hash-vector - (package-hashtable-hash ,symbols))))) - (:inherited - `(let ((,symbols (and ,',package-use-list - (package-external-symbols - (car ,',package-use-list))))) - (when ,symbols - (setf ,',vector (package-hashtable-table ,symbols)) - (setf ,',hash-vector - (package-hashtable-hash ,symbols))))))))) - (,end-test-macro (this-kind) - `,(let ((next-kind (cadr (member this-kind - ',ordered-types)))) - (if next-kind - `(,',init-macro ,next-kind) - `(if (endp (setf ,',packages (cdr ,',packages))) - (return-from ,',BLOCK) - (,',init-macro ,(car ',ordered-types))))))) - (when ,packages - ,(when (null symbol-types) - (error 'simple-program-error - :format-control - "At least one of :INTERNAL, :EXTERNAL, or ~ + (declare (optimize (inhibit-warnings 3))) + (let ((symbols (gensym))) + `(progn + (setf ,',kind ,next-kind) + (setf ,',counter nil) + ,(case next-kind + (:internal + `(let ((,symbols (package-internal-symbols + (car ,',packages)))) + (when ,symbols + (setf ,',vector (package-hashtable-table ,symbols)) + (setf ,',hash-vector + (package-hashtable-hash ,symbols))))) + (:external + `(let ((,symbols (package-external-symbols + (car ,',packages)))) + (when ,symbols + (setf ,',vector (package-hashtable-table ,symbols)) + (setf ,',hash-vector + (package-hashtable-hash ,symbols))))) + (:inherited + `(let ((,symbols (and ,',package-use-list + (package-external-symbols + (car ,',package-use-list))))) + (when ,symbols + (setf ,',vector (package-hashtable-table ,symbols)) + (setf ,',hash-vector + (package-hashtable-hash ,symbols))))))))) + (,end-test-macro (this-kind) + `,(let ((next-kind (cadr (member this-kind + ',ordered-types)))) + (if next-kind + `(,',init-macro ,next-kind) + `(if (endp (setf ,',packages (cdr ,',packages))) + (return-from ,',BLOCK) + (,',init-macro ,(car ',ordered-types))))))) + (when ,packages + ,(when (null symbol-types) + (error 'simple-program-error + :format-control + "At least one of :INTERNAL, :EXTERNAL, or ~ :INHERITED must be supplied.")) - ,(dolist (symbol symbol-types) - (unless (member symbol '(:internal :external :inherited)) - (error 'program-error - :format-control - "~S is not one of :INTERNAL, :EXTERNAL, or :INHERITED." - :format-argument symbol))) - (,init-macro ,(car ordered-types)) - (flet ((,real-symbol-p (number) - (> number 1))) - (macrolet ((,mname () - (declare (optimize (inhibit-warnings 3))) - `(block ,',BLOCK - (loop - (case ,',kind - ,@(when (member :internal ',ordered-types) - `((:internal - (setf ,',counter - (position-if #',',real-symbol-p - (the hash-vector ,',hash-vector) - :start (if ,',counter - (1+ ,',counter) - 0))) - (if ,',counter - (return-from ,',BLOCK - (values t (svref ,',vector ,',counter) - ,',kind (car ,',packages))) - (,',end-test-macro :internal))))) - ,@(when (member :external ',ordered-types) - `((:external - (setf ,',counter - (position-if #',',real-symbol-p - (the hash-vector ,',hash-vector) - :start (if ,',counter - (1+ ,',counter) - 0))) - (if ,',counter - (return-from ,',BLOCK - (values t (svref ,',vector ,',counter) - ,',kind (car ,',packages))) - (,',end-test-macro :external))))) - ,@(when (member :inherited ',ordered-types) - `((:inherited - (flet ((,',inherited-symbol-p (number) - (when (,',real-symbol-p number) - (let* ((p (position - number - (the hash-vector - ,',hash-vector) - :start (if ,',counter - (1+ ,',counter) - 0))) - (s (svref ,',vector p))) - (eql (nth-value - 1 (find-symbol - (symbol-name s) - (car ,',packages))) - :inherited))))) - (setf ,',counter - (when ,',hash-vector - (position-if #',',inherited-symbol-p - (the hash-vector - ,',hash-vector) - :start (if ,',counter - (1+ ,',counter) - 0))))) - (cond (,',counter - (return-from - ,',BLOCK - (values t (svref ,',vector ,',counter) - ,',kind (car ,',packages)) - )) - (t - (setf ,',package-use-list - (cdr ,',package-use-list)) - (cond ((endp ,',package-use-list) - (setf ,',packages (cdr ,',packages)) - (when (endp ,',packages) - (return-from ,',BLOCK)) - (setf ,',package-use-list - (package-%use-list - (car ,',packages))) - (,',init-macro ,(car - ',ordered-types))) - (t (,',init-macro :inherited) - (setf ,',counter nil))))))))))))) - ,@body))))))) + ,(dolist (symbol symbol-types) + (unless (member symbol '(:internal :external :inherited)) + (error 'program-error + :format-control + "~S is not one of :INTERNAL, :EXTERNAL, or :INHERITED." + :format-argument symbol))) + (,init-macro ,(car ordered-types)) + (flet ((,real-symbol-p (number) + (> number 1))) + (macrolet ((,mname () + (declare (optimize (inhibit-warnings 3))) + `(block ,',BLOCK + (loop + (case ,',kind + ,@(when (member :internal ',ordered-types) + `((:internal + (setf ,',counter + (position-if #',',real-symbol-p + (the hash-vector ,',hash-vector) + :start (if ,',counter + (1+ ,',counter) + 0))) + (if ,',counter + (return-from ,',BLOCK + (values t (svref ,',vector ,',counter) + ,',kind (car ,',packages))) + (,',end-test-macro :internal))))) + ,@(when (member :external ',ordered-types) + `((:external + (setf ,',counter + (position-if #',',real-symbol-p + (the hash-vector ,',hash-vector) + :start (if ,',counter + (1+ ,',counter) + 0))) + (if ,',counter + (return-from ,',BLOCK + (values t (svref ,',vector ,',counter) + ,',kind (car ,',packages))) + (,',end-test-macro :external))))) + ,@(when (member :inherited ',ordered-types) + `((:inherited + (flet ((,',inherited-symbol-p (number) + (when (,',real-symbol-p number) + (let* ((p (position + number + (the hash-vector + ,',hash-vector) + :start (if ,',counter + (1+ ,',counter) + 0))) + (s (svref ,',vector p))) + (eql (nth-value + 1 (find-symbol + (symbol-name s) + (car ,',packages))) + :inherited))))) + (setf ,',counter + (when ,',hash-vector + (position-if #',',inherited-symbol-p + (the hash-vector + ,',hash-vector) + :start (if ,',counter + (1+ ,',counter) + 0))))) + (cond (,',counter + (return-from + ,',BLOCK + (values t (svref ,',vector ,',counter) + ,',kind (car ,',packages)) + )) + (t + (setf ,',package-use-list + (cdr ,',package-use-list)) + (cond ((endp ,',package-use-list) + (setf ,',packages (cdr ,',packages)) + (when (endp ,',packages) + (return-from ,',BLOCK)) + (setf ,',package-use-list + (package-%use-list + (car ,',packages))) + (,',init-macro ,(car + ',ordered-types))) + (t (,',init-macro :inherited) + (setf ,',counter nil))))))))))))) + ,@body))))))) diff --git a/src/code/parse-body.lisp b/src/code/parse-body.lisp index 53365a6..7966c85 100644 --- a/src/code/parse-body.lisp +++ b/src/code/parse-body.lisp @@ -35,46 +35,46 @@ ;; a little bit. (flet ((doc-string-p (x remaining-forms) (if (stringp x) - (if doc-string-allowed - ;; ANSI 3.4.11 explicitly requires that a doc - ;; string be followed by another form (either an - ;; ordinary form or a declaration). Hence: - (if remaining-forms - (if doc - ;; ANSI 3.4.11 says that the consequences of - ;; duplicate doc strings are unspecified. - ;; That's probably not something the - ;; programmer intends. We raise an error so - ;; that this won't pass unnoticed. - (error "duplicate doc string ~S" x) - t))))) + (if doc-string-allowed + ;; ANSI 3.4.11 explicitly requires that a doc + ;; string be followed by another form (either an + ;; ordinary form or a declaration). Hence: + (if remaining-forms + (if doc + ;; ANSI 3.4.11 says that the consequences of + ;; duplicate doc strings are unspecified. + ;; That's probably not something the + ;; programmer intends. We raise an error so + ;; that this won't pass unnoticed. + (error "duplicate doc string ~S" x) + t))))) (declaration-p (x) (if (consp x) (let ((name (car x))) - (case name - ((declare) t) - ((declaim) - (unless toplevel - ;; technically legal, but rather unlikely to - ;; be what the user meant to do... - (style-warn - "DECLAIM where DECLARE was probably intended") - nil)) - (t nil)))))) + (case name + ((declare) t) + ((declaim) + (unless toplevel + ;; technically legal, but rather unlikely to + ;; be what the user meant to do... + (style-warn + "DECLAIM where DECLARE was probably intended") + nil)) + (t nil)))))) (tagbody :again (if forms - (let ((form1 (first forms))) - ;; Note: The (IF (IF ..) ..) stuff is because we don't - ;; have the macro AND yet.:-| - (if (doc-string-p form1 (rest forms)) - (setq doc form1) - (if (declaration-p form1) - (setq reversed-decls - (cons form1 reversed-decls)) - (go :done))) - (setq forms (rest forms)) - (go :again))) + (let ((form1 (first forms))) + ;; Note: The (IF (IF ..) ..) stuff is because we don't + ;; have the macro AND yet.:-| + (if (doc-string-p form1 (rest forms)) + (setq doc form1) + (if (declaration-p form1) + (setq reversed-decls + (cons form1 reversed-decls)) + (go :done))) + (setq forms (rest forms)) + (go :again))) :done) (values forms (nreverse reversed-decls) diff --git a/src/code/parse-defmacro-errors.lisp b/src/code/parse-defmacro-errors.lisp index a9f8e96..70cf9d8 100644 --- a/src/code/parse-defmacro-errors.lisp +++ b/src/code/parse-defmacro-errors.lisp @@ -15,29 +15,29 @@ (define-condition defmacro-lambda-list-bind-error (error) ((kind :reader defmacro-lambda-list-bind-error-kind - :initarg :kind) + :initarg :kind) (name :reader defmacro-lambda-list-bind-error-name - :initarg :name - :initform nil))) + :initarg :name + :initform nil))) ;;; shared logic for REPORTing variants of DEFMACRO-LAMBDA-LIST-BIND-ERROR: ;;; Set up appropriate prettying and indentation on STREAM, print some ;;; boilerplate related to CONDITION (an instance of ;;; DEFMACRO-LAMBDA-LIST-BIND-ERROR), then execute BODY. (defmacro !printing-defmacro-lambda-list-bind-error ((condition stream) - &body body) + &body body) `(%printing-defmacro-lambda-list-bind-error ,condition - ,stream - (lambda (,stream) - (declare (type stream ,stream)) - ,@body))) + ,stream + (lambda (,stream) + (declare (type stream ,stream)) + ,@body))) (defun %printing-defmacro-lambda-list-bind-error (condition stream fun) (declare (type stream stream) (type function fun)) (pprint-logical-block (stream nil) (format stream - "error while parsing arguments to ~A~@[ ~S~]:~2I~:@_" - (defmacro-lambda-list-bind-error-kind condition) - (defmacro-lambda-list-bind-error-name condition)) + "error while parsing arguments to ~A~@[ ~S~]:~2I~:@_" + (defmacro-lambda-list-bind-error-kind condition) + (defmacro-lambda-list-bind-error-name condition)) (pprint-logical-block (stream nil) (funcall fun stream)))) @@ -45,67 +45,67 @@ (defmacro-lambda-list-bind-error) ((object :reader defmacro-bogus-sublist-error-object :initarg :object) (lambda-list :reader defmacro-bogus-sublist-error-lambda-list - :initarg :lambda-list)) + :initarg :lambda-list)) (:report (lambda (condition stream) (!printing-defmacro-lambda-list-bind-error (condition stream) (format stream - "bogus sublist ~2I~_~S ~I~_to satisfy lambda-list ~2I~_~:S" - (defmacro-bogus-sublist-error-object condition) - (defmacro-bogus-sublist-error-lambda-list condition)))))) + "bogus sublist ~2I~_~S ~I~_to satisfy lambda-list ~2I~_~:S" + (defmacro-bogus-sublist-error-object condition) + (defmacro-bogus-sublist-error-lambda-list condition)))))) (define-condition arg-count-error (defmacro-lambda-list-bind-error) ((args :reader arg-count-error-args :initarg :args) (lambda-list :reader arg-count-error-lambda-list - :initarg :lambda-list) + :initarg :lambda-list) (minimum :reader arg-count-error-minimum :initarg :minimum) (maximum :reader arg-count-error-maximum :initarg :maximum)) (:report (lambda (condition stream) (!printing-defmacro-lambda-list-bind-error (condition stream) (format stream - "invalid number of elements in ~2I~_~:S ~ + "invalid number of elements in ~2I~_~:S ~ ~I~_to satisfy lambda list ~2I~_~:S: ~I~_" - (arg-count-error-args condition) - (arg-count-error-lambda-list condition)) + (arg-count-error-args condition) + (arg-count-error-lambda-list condition)) (cond ((null (arg-count-error-maximum condition)) - (format stream "at least ~W expected" - (arg-count-error-minimum condition))) - ((= (arg-count-error-minimum condition) - (arg-count-error-maximum condition)) - (format stream "exactly ~W expected" - (arg-count-error-minimum condition))) - (t - (format stream "between ~W and ~W expected" - (arg-count-error-minimum condition) - (arg-count-error-maximum condition)))) + (format stream "at least ~W expected" + (arg-count-error-minimum condition))) + ((= (arg-count-error-minimum condition) + (arg-count-error-maximum condition)) + (format stream "exactly ~W expected" + (arg-count-error-minimum condition))) + (t + (format stream "between ~W and ~W expected" + (arg-count-error-minimum condition) + (arg-count-error-maximum condition)))) (format stream ", but ~W found" - (length (arg-count-error-args condition))))))) + (length (arg-count-error-args condition))))))) (define-condition defmacro-lambda-list-broken-key-list-error - (defmacro-lambda-list-bind-error) + (defmacro-lambda-list-bind-error) ((problem :reader defmacro-lambda-list-broken-key-list-error-problem - :initarg :problem) + :initarg :problem) (info :reader defmacro-lambda-list-broken-key-list-error-info - :initarg :info)) + :initarg :info)) (:report (lambda (condition stream) - (!printing-defmacro-lambda-list-bind-error (condition stream) - (format stream - ;; FIXME: These should probably just be three - ;; subclasses of the base class, so that we don't - ;; need to maintain the set of tags both here and - ;; implicitly wherever this macro is used. (This - ;; might get easier once CLOS is initialized in - ;; cold init.) - (ecase - (defmacro-lambda-list-broken-key-list-error-problem - condition) - (:dotted-list - "dotted keyword/value list: ~S") - (:odd-length - "odd number of elements in keyword/value list: ~S") - (:unknown-keyword - "~{unknown keyword: ~S; expected one of ~ + (!printing-defmacro-lambda-list-bind-error (condition stream) + (format stream + ;; FIXME: These should probably just be three + ;; subclasses of the base class, so that we don't + ;; need to maintain the set of tags both here and + ;; implicitly wherever this macro is used. (This + ;; might get easier once CLOS is initialized in + ;; cold init.) + (ecase + (defmacro-lambda-list-broken-key-list-error-problem + condition) + (:dotted-list + "dotted keyword/value list: ~S") + (:odd-length + "odd number of elements in keyword/value list: ~S") + (:unknown-keyword + "~{unknown keyword: ~S; expected one of ~ ~{~S~^, ~}~}")) - (defmacro-lambda-list-broken-key-list-error-info - condition)))))) + (defmacro-lambda-list-broken-key-list-error-info + condition)))))) diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp index b783de5..d9fc853 100644 --- a/src/code/parse-defmacro.lisp +++ b/src/code/parse-defmacro.lisp @@ -32,84 +32,84 @@ ;;; where this code is inserted, the documentation for the parsed ;;; body, and bounds on the number of arguments. (defun parse-defmacro (lambda-list arg-list-name body name context - &key - (anonymousp nil) - (doc-string-allowed t) - ((:environment env-arg-name)) - ((:default-default *default-default*)) - (error-fun 'error) + &key + (anonymousp nil) + (doc-string-allowed t) + ((:environment env-arg-name)) + ((:default-default *default-default*)) + (error-fun 'error) (wrap-block t)) (multiple-value-bind (forms declarations documentation) (parse-body body :doc-string-allowed doc-string-allowed) (let ((*arg-tests* ()) - (*user-lets* ()) - (*system-lets* ()) - (*ignorable-vars* ()) + (*user-lets* ()) + (*system-lets* ()) + (*ignorable-vars* ()) (*env-var* nil)) (multiple-value-bind (env-arg-used minimum maximum) - (parse-defmacro-lambda-list lambda-list arg-list-name name - context error-fun (not anonymousp) - nil) - (values `(let* (,@(when env-arg-used + (parse-defmacro-lambda-list lambda-list arg-list-name name + context error-fun (not anonymousp) + nil) + (values `(let* (,@(when env-arg-used `((,*env-var* ,env-arg-name))) ,@(nreverse *system-lets*)) - ,@(when *ignorable-vars* - `((declare (ignorable ,@*ignorable-vars*)))) - ,@*arg-tests* - (let* ,(nreverse *user-lets*) - ,@declarations + ,@(when *ignorable-vars* + `((declare (ignorable ,@*ignorable-vars*)))) + ,@*arg-tests* + (let* ,(nreverse *user-lets*) + ,@declarations ,@(if wrap-block `((block ,(fun-name-block-name name) ,@forms)) forms))) - `(,@(when (and env-arg-name (not env-arg-used)) + `(,@(when (and env-arg-name (not env-arg-used)) `((declare (ignore ,env-arg-name))))) - documentation - minimum - maximum))))) + documentation + minimum + maximum))))) ;;; partial reverse-engineered documentation: ;;; TOPLEVEL is true for calls through PARSE-DEFMACRO from DEFSETF and ;;; DESTRUCTURING-BIND, false otherwise. ;;; -- WHN 19990620 (defun parse-defmacro-lambda-list (possibly-dotted-lambda-list - arg-list-name - name - context - error-fun - &optional - toplevel - env-illegal) + arg-list-name + name + context + error-fun + &optional + toplevel + env-illegal) (let* (;; PATH is a sort of pointer into the part of the lambda list we're - ;; considering at this point in the code. PATH-0 is the root of the - ;; lambda list, which is the initial value of PATH. - (path-0 (if toplevel + ;; considering at this point in the code. PATH-0 is the root of the + ;; lambda list, which is the initial value of PATH. + (path-0 (if toplevel `(cdr ,arg-list-name) arg-list-name)) - (path path-0) ; (will change below) - (now-processing :required) - (maximum 0) - (minimum 0) - (keys ()) - (key-seen nil) + (path path-0) ; (will change below) + (now-processing :required) + (maximum 0) + (minimum 0) + (keys ()) + (key-seen nil) (aux-seen nil) (optional-seen nil) - ;; ANSI specifies that dotted lists are "treated exactly as if the - ;; parameter name that ends the list had appeared preceded by &rest." - ;; We force this behavior by transforming dotted lists into ordinary - ;; lists with explicit &REST elements. - (lambda-list (do ((in-pdll possibly-dotted-lambda-list (cdr in-pdll)) - (reversed-result nil)) - ((atom in-pdll) - (nreverse (if in-pdll + ;; ANSI specifies that dotted lists are "treated exactly as if the + ;; parameter name that ends the list had appeared preceded by &rest." + ;; We force this behavior by transforming dotted lists into ordinary + ;; lists with explicit &REST elements. + (lambda-list (do ((in-pdll possibly-dotted-lambda-list (cdr in-pdll)) + (reversed-result nil)) + ((atom in-pdll) + (nreverse (if in-pdll (list* in-pdll '&rest reversed-result) reversed-result))) - (push (car in-pdll) reversed-result))) - rest-name restp allow-other-keys-p env-arg-used) + (push (car in-pdll) reversed-result))) + rest-name restp allow-other-keys-p env-arg-used) (when (member '&whole (rest lambda-list)) (error "&WHOLE may only appear first in ~S lambda-list." context)) (do ((rest-of-args lambda-list (cdr rest-of-args))) - ((null rest-of-args)) + ((null rest-of-args)) (macrolet ((process-sublist (var sublist-name path) (once-only ((var var)) `(if (listp ,var) @@ -119,9 +119,9 @@ (parse-defmacro-lambda-list ,var sub-list-name name context error-fun)) (push-let-binding ,var ,path nil)))) - (normalize-singleton (var) - `(when (null (cdr ,var)) - (setf (cdr ,var) (list *default-default*))))) + (normalize-singleton (var) + `(when (null (cdr ,var)) + (setf (cdr ,var) (list *default-default*))))) (let ((var (car rest-of-args))) (typecase var (list @@ -135,7 +135,7 @@ minimum (1+ minimum) maximum (1+ maximum))) ((:optionals) - (normalize-singleton var) + (normalize-singleton var) (destructuring-bind (varname &optional initform supplied-p) var (push-optional-binding varname initform supplied-p @@ -144,7 +144,7 @@ (setq path `(cdr ,path) maximum (1+ maximum))) ((:keywords) - (normalize-singleton var) + (normalize-singleton var) (let* ((keyword-given (consp (car var))) (variable (if keyword-given (cadar var) @@ -167,18 +167,18 @@ (&whole (cond ((cdr rest-of-args) (setq rest-of-args (cdr rest-of-args)) - ;; Special case for compiler-macros: if car of - ;; the form is FUNCALL skip over it for - ;; destructuring, pretending cdr of the form is - ;; the actual form. - (when (eq context 'define-compiler-macro) - (push-let-binding - arg-list-name - arg-list-name - t - `(not (and (listp ,arg-list-name) - (eq 'funcall (car ,arg-list-name)))) - `(setf ,arg-list-name (cdr ,arg-list-name)))) + ;; Special case for compiler-macros: if car of + ;; the form is FUNCALL skip over it for + ;; destructuring, pretending cdr of the form is + ;; the actual form. + (when (eq context 'define-compiler-macro) + (push-let-binding + arg-list-name + arg-list-name + t + `(not (and (listp ,arg-list-name) + (eq 'funcall (car ,arg-list-name)))) + `(setf ,arg-list-name (cdr ,arg-list-name)))) (process-sublist (car rest-of-args) "WHOLE-LIST-" arg-list-name)) (t @@ -254,20 +254,20 @@ ((:keywords) (let ((key (keywordicate var))) (push-let-binding - var - `(lookup-keyword ,key ,rest-name) - nil - `(keyword-supplied-p ,key ,rest-name)) + var + `(lookup-keyword ,key ,rest-name) + nil + `(keyword-supplied-p ,key ,rest-name)) (push key keys))) ((:auxs) (push-let-binding var nil nil)))))) (t (error "non-symbol in lambda-list: ~S" var)))))) (let (;; common subexpression, suitable for passing to functions - ;; which expect a MAXIMUM argument regardless of whether - ;; there actually is a maximum number of arguments - ;; (expecting MAXIMUM=NIL when there is no maximum) - (explicit-maximum (and (not restp) maximum))) + ;; which expect a MAXIMUM argument regardless of whether + ;; there actually is a maximum number of arguments + ;; (expecting MAXIMUM=NIL when there is no maximum) + (explicit-maximum (and (not restp) maximum))) (unless (and restp (zerop minimum)) (push `(unless ,(if restp ;; (If RESTP, then the argument list might be @@ -288,78 +288,78 @@ :maximum ,explicit-maximum))) *arg-tests*)) (when key-seen - (let ((problem (gensym "KEY-PROBLEM-")) - (info (gensym "INFO-"))) - (push `(multiple-value-bind (,problem ,info) - (verify-keywords ,rest-name - ',keys - ',allow-other-keys-p) - (when ,problem - (,error-fun - 'defmacro-lambda-list-broken-key-list-error - :kind ',context - ,@(when name `(:name ',name)) - :problem ,problem - :info ,info))) - *arg-tests*))) + (let ((problem (gensym "KEY-PROBLEM-")) + (info (gensym "INFO-"))) + (push `(multiple-value-bind (,problem ,info) + (verify-keywords ,rest-name + ',keys + ',allow-other-keys-p) + (when ,problem + (,error-fun + 'defmacro-lambda-list-broken-key-list-error + :kind ',context + ,@(when name `(:name ',name)) + :problem ,problem + :info ,info))) + *arg-tests*))) (values env-arg-used minimum explicit-maximum)))) ;;; We save space in macro definitions by calling this function. (defun arg-count-error (context name args lambda-list minimum maximum) (let (#-sb-xc-host - (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame)))) + (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame)))) (error 'arg-count-error - :kind context - :name name - :args args - :lambda-list lambda-list - :minimum minimum - :maximum maximum))) + :kind context + :name name + :args args + :lambda-list lambda-list + :minimum minimum + :maximum maximum))) (defun push-sub-list-binding (variable path object name context error-fun) (check-defmacro-arg variable) (let ((var (gensym "TEMP-"))) (push `(,variable - (let ((,var ,path)) - (if (listp ,var) - ,var - (,error-fun 'defmacro-bogus-sublist-error - :kind ',context - ,@(when name `(:name ',name)) - :object ,var - :lambda-list ',object)))) - *system-lets*))) + (let ((,var ,path)) + (if (listp ,var) + ,var + (,error-fun 'defmacro-bogus-sublist-error + :kind ',context + ,@(when name `(:name ',name)) + :object ,var + :lambda-list ',object)))) + *system-lets*))) (defun push-let-binding (variable path systemp &optional condition - (init-form *default-default*)) + (init-form *default-default*)) (check-defmacro-arg variable) (let ((let-form (if condition - `(,variable (if ,condition ,path ,init-form)) - `(,variable ,path)))) + `(,variable (if ,condition ,path ,init-form)) + `(,variable ,path)))) (if systemp (push let-form *system-lets*) (push let-form *user-lets*)))) (defun push-optional-binding (value-var init-form supplied-var condition path - name context error-fun) + name context error-fun) (unless supplied-var (setq supplied-var (gensym "SUPPLIEDP-"))) (push-let-binding supplied-var condition t) (cond ((consp value-var) - (let ((whole-thing (gensym "OPTIONAL-SUBLIST-"))) - (push-sub-list-binding whole-thing - `(if ,supplied-var ,path ,init-form) - value-var name context error-fun) - (parse-defmacro-lambda-list value-var whole-thing name - context error-fun))) - ((symbolp value-var) - (push-let-binding value-var path nil supplied-var init-form)) - (t - (error "illegal optional variable name: ~S" value-var)))) + (let ((whole-thing (gensym "OPTIONAL-SUBLIST-"))) + (push-sub-list-binding whole-thing + `(if ,supplied-var ,path ,init-form) + value-var name context error-fun) + (parse-defmacro-lambda-list value-var whole-thing name + context error-fun))) + ((symbolp value-var) + (push-let-binding value-var path nil supplied-var init-form)) + (t + (error "illegal optional variable name: ~S" value-var)))) (defun defmacro-error (problem context name) (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]" - problem context name)) + problem context name)) (defun check-defmacro-arg (arg) (when (or (and *env-var* (eq arg *env-var*)) @@ -376,19 +376,19 @@ (remaining key-list (cddr remaining))) ((null remaining) (if (and unknown-keyword - (not allow-other-keys) - (not (lookup-keyword :allow-other-keys key-list))) - (values :unknown-keyword (list unknown-keyword valid-keys)) - (values nil nil))) + (not allow-other-keys) + (not (lookup-keyword :allow-other-keys key-list))) + (values :unknown-keyword (list unknown-keyword valid-keys)) + (values nil nil))) (cond ((not (and (consp remaining) (listp (cdr remaining)))) - (return (values :dotted-list key-list))) - ((null (cdr remaining)) - (return (values :odd-length key-list))) - ((or (eq (car remaining) :allow-other-keys) - (member (car remaining) valid-keys)) - (push (car remaining) already-processed)) - (t - (setq unknown-keyword (car remaining)))))) + (return (values :dotted-list key-list))) + ((null (cdr remaining)) + (return (values :odd-length key-list))) + ((or (eq (car remaining) :allow-other-keys) + (member (car remaining) valid-keys)) + (push (car remaining) already-processed)) + (t + (setq unknown-keyword (car remaining)))))) (defun lookup-keyword (keyword key-list) (do ((remaining key-list (cddr remaining))) diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp index 07e9a4e..6d3052d 100644 --- a/src/code/pathname.lisp +++ b/src/code/pathname.lisp @@ -29,17 +29,17 @@ (print-unreadable-object (host stream :type t :identity t))) (def!struct (logical-host - (:make-load-form-fun make-logical-host-load-form-fun) - (:include host - (parse #'parse-logical-namestring) - (unparse #'unparse-logical-namestring) - (unparse-host - (lambda (x) - (logical-host-name (%pathname-host x)))) - (unparse-directory #'unparse-logical-directory) - (unparse-file #'unparse-logical-file) - (unparse-enough #'unparse-enough-namestring) - (customary-case :upper))) + (:make-load-form-fun make-logical-host-load-form-fun) + (:include host + (parse #'parse-logical-namestring) + (unparse #'unparse-logical-namestring) + (unparse-host + (lambda (x) + (logical-host-name (%pathname-host x)))) + (unparse-directory #'unparse-logical-directory) + (unparse-file #'unparse-logical-file) + (unparse-enough #'unparse-enough-namestring) + (customary-case :upper))) (name "" :type simple-base-string) (translations nil :type list) (canon-transls nil :type list)) @@ -50,7 +50,7 @@ (defun make-logical-host-load-form-fun (logical-host) (values `(find-logical-host ',(logical-host-name logical-host)) - nil)) + nil)) ;;; A PATTERN is a list of entries and wildcards used for pattern ;;; matches of translations. @@ -66,13 +66,13 @@ '(member nil :unspecific :wild))) (sb!xc:defstruct (pathname (:conc-name %pathname-) - (:constructor %make-pathname (host - device - directory - name - type - version)) - (:predicate pathnamep)) + (:constructor %make-pathname (host + device + directory + name + type + version)) + (:predicate pathnamep)) ;; the host (at present either a UNIX or logical host) (host nil :type (or host null)) ;; the name of a logical or physical device holding files @@ -90,7 +90,7 @@ ;;; Logical pathnames have the following format: ;;; ;;; logical-namestring ::= -;;; [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]] +;;; [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]] ;;; ;;; host ::= word ;;; directory ::= word | wildcard-word | ** @@ -106,11 +106,11 @@ ;;; Logical pathnames are a subclass of PATHNAME. Their class ;;; relations are mimicked using structures for efficiency. (sb!xc:defstruct (logical-pathname (:conc-name %logical-pathname-) - (:include pathname) - (:constructor %make-logical-pathname - (host - device - directory - name - type - version)))) + (:include pathname) + (:constructor %make-logical-pathname + (host + device + directory + name + type + version)))) diff --git a/src/code/pcounter.lisp b/src/code/pcounter.lisp index d2b6b5e..aee1cad 100644 --- a/src/code/pcounter.lisp +++ b/src/code/pcounter.lisp @@ -3,7 +3,7 @@ ;;;; a PCOUNTER is used to represent an unsigned integer quantity which ;;;; can grow bigger than a fixnum, but typically does so, if at all, ;;;; in many small steps, where we don't want to cons on every step. -;;;; Such quantities typically arise in profiling, e.g. +;;;; Such quantities typically arise in profiling, e.g. ;;;; total system consing, time spent in a profiled function, and ;;;; bytes consed in a profiled function are all examples of such ;;;; quantities. The name is an abbreviation for "Profiling COUNTER". @@ -25,10 +25,10 @@ (aver (typep delta 'unsigned-byte)) (let ((sum (+ (pcounter-fixnum pcounter) delta))) (cond ((typep sum 'fixnum) - (setf (pcounter-fixnum pcounter) sum)) - (t - (incf (pcounter-integer pcounter) sum) - (setf (pcounter-fixnum pcounter) 0)))) + (setf (pcounter-fixnum pcounter) sum)) + (t + (incf (pcounter-integer pcounter) sum) + (setf (pcounter-fixnum pcounter) 0)))) pcounter) (/show0 "pcounter.lisp 34") @@ -52,11 +52,11 @@ (fixnum (let ((sum (+ x delta))) (if (typep sum 'fixnum) - sum - (make-pcounter :integer sum)))) + sum + (make-pcounter :integer sum)))) (pcounter (incf-pcounter x delta)))) - + (define-modify-macro incf-pcounter-or-fixnum (delta) %incf-pcounter-or-fixnum) (/show0 "pcounter.lisp 62") @@ -70,8 +70,8 @@ (aver (typep ,delta-sym 'unsigned-byte)) ;;(declare (type unsigned-byte ,delta-sym)) (if (typep ,delta-sym 'fixnum) - (incf-pcounter-or-fixnum ,x ,delta) - (incf-pcounter-or-fixnum ,x ,delta))))) + (incf-pcounter-or-fixnum ,x ,delta) + (incf-pcounter-or-fixnum ,x ,delta))))) (/show0 "pcounter.lisp 76") diff --git a/src/code/pp-backq.lisp b/src/code/pp-backq.lisp index 7905ce7..c1268d0 100644 --- a/src/code/pp-backq.lisp +++ b/src/code/pp-backq.lisp @@ -43,32 +43,32 @@ (mapcar #'backq-unparse (cdr form))) (backq-list* (do ((tail (cdr form) (cdr tail)) - (accum nil)) - ((null (cdr tail)) - (nconc (nreverse accum) - (backq-unparse (car tail) t))) - (push (backq-unparse (car tail)) accum))) + (accum nil)) + ((null (cdr tail)) + (nconc (nreverse accum) + (backq-unparse (car tail) t))) + (push (backq-unparse (car tail)) accum))) (backq-append (apply #'append - (mapcar (lambda (el) (backq-unparse el t)) - (cdr form)))) + (mapcar (lambda (el) (backq-unparse el t)) + (cdr form)))) (backq-nconc (apply #'append - (mapcar (lambda (el) (backq-unparse el :nconc)) - (cdr form)))) + (mapcar (lambda (el) (backq-unparse el :nconc)) + (cdr form)))) (backq-cons (cons (backq-unparse (cadr form) nil) - (backq-unparse (caddr form) t))) + (backq-unparse (caddr form) t))) (backq-vector (coerce (backq-unparse (cadr form)) 'vector)) (quote (cond - ((atom (cadr form)) (cadr form)) - ((and (consp (cadr form)) - (member (caadr form) *backq-tokens*)) - (backq-unparse-expr form splicing)) - (t (cons (backq-unparse `(quote ,(caadr form))) - (backq-unparse `(quote ,(cdadr form))))))) + ((atom (cadr form)) (cadr form)) + ((and (consp (cadr form)) + (member (caadr form) *backq-tokens*)) + (backq-unparse-expr form splicing)) + (t (cons (backq-unparse `(quote ,(caadr form))) + (backq-unparse `(quote ,(cdadr form))))))) (t (backq-unparse-expr form splicing)))))) @@ -97,12 +97,12 @@ ;; work for pretty streams which need to do margin calculations. Oh ;; well. It was good while it lasted. -- CSR, 2003-12-15 (let ((output (with-output-to-string (s) - (write (cadr form) :stream s)))) + (write (cadr form) :stream s)))) (unless (= (length output) 0) (when (and (eql (car form) 'backq-comma) - (or (char= (char output 0) #\.) - (char= (char output 0) #\@))) - (write-char #\Space stream)) + (or (char= (char output 0) #\.) + (char= (char output 0) #\@))) + (write-char #\Space stream)) (write (cadr form) :stream stream)))) ;;; This is called by !PPRINT-COLD-INIT, fairly late, because diff --git a/src/code/ppc-vm.lisp b/src/code/ppc-vm.lisp index 79ddf31..ce78355 100644 --- a/src/code/ppc-vm.lisp +++ b/src/code/ppc-vm.lisp @@ -15,21 +15,21 @@ (defun get-machine-version () #!+linux (with-open-file (stream "/proc/cpuinfo" - ;; /proc is optional even in Linux, so - ;; fail gracefully. - :if-does-not-exist nil) + ;; /proc is optional even in Linux, so + ;; fail gracefully. + :if-does-not-exist nil) (loop with line while (setf line (read-line stream nil)) - ;; hoping "cpu" exists and gives something useful in - ;; all relevant Linuxen... - ;; - ;; from Lars Brinkhoff sbcl-devel 26 Jun 2003: - ;; I examined different versions of Linux/PPC at - ;; http://lxr.linux.no/ (the file that outputs - ;; /proc/cpuinfo is arch/ppc/kernel/setup.c, if - ;; you want to check), and all except 2.0.x - ;; seemed to do the same thing as far as the - ;; "cpu" field is concerned, i.e. it always - ;; starts with the (C-syntax) string "cpu\t\t: ". + ;; hoping "cpu" exists and gives something useful in + ;; all relevant Linuxen... + ;; + ;; from Lars Brinkhoff sbcl-devel 26 Jun 2003: + ;; I examined different versions of Linux/PPC at + ;; http://lxr.linux.no/ (the file that outputs + ;; /proc/cpuinfo is arch/ppc/kernel/setup.c, if + ;; you want to check), and all except 2.0.x + ;; seemed to do the same thing as far as the + ;; "cpu" field is concerned, i.e. it always + ;; starts with the (C-syntax) string "cpu\t\t: ". when (eql (search "cpu" line) 0) return (string-trim " " (subseq line (1+ (position #\: line)))))) #!-linux @@ -43,28 +43,28 @@ (error "Unaligned instruction? offset=#x~X." offset)) (sb!sys:without-gcing (let ((sap (truly-the system-area-pointer - (%primitive sb!kernel::code-instructions code)))) + (%primitive sb!kernel::code-instructions code)))) (ecase kind (:b - (error "Can't deal with CALL fixups, yet.")) + (error "Can't deal with CALL fixups, yet.")) (:ba - (setf (ldb (byte 24 2) (sap-ref-32 sap offset)) - (ash fixup -2))) + (setf (ldb (byte 24 2) (sap-ref-32 sap offset)) + (ash fixup -2))) (:ha - (let* ((h (ldb (byte 16 16) fixup)) - (l (ldb (byte 16 0) fixup))) - ; Compensate for possible sign-extension when the low half - ; is added to the high. We could avoid this by ORI-ing - ; the low half in 32-bit absolute loads, but it'd be - ; nice to be able to do: - ; lis rX,foo@ha - ; lwz rY,foo@l(rX) - ; and lwz/stw and friends all use a signed 16-bit offset. - (setf (ldb (byte 16 0) (sap-ref-32 sap offset)) - (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h)))) + (let* ((h (ldb (byte 16 16) fixup)) + (l (ldb (byte 16 0) fixup))) + ; Compensate for possible sign-extension when the low half + ; is added to the high. We could avoid this by ORI-ing + ; the low half in 32-bit absolute loads, but it'd be + ; nice to be able to do: + ; lis rX,foo@ha + ; lwz rY,foo@l(rX) + ; and lwz/stw and friends all use a signed 16-bit offset. + (setf (ldb (byte 16 0) (sap-ref-32 sap offset)) + (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h)))) (:l - (setf (ldb (byte 16 0) (sap-ref-32 sap offset)) - (ldb (byte 16 0) fixup))))))) + (setf (ldb (byte 16 0) (sap-ref-32 sap offset)) + (ldb (byte 16 0) fixup))))))) ;;;; "Sigcontext" access functions, cut & pasted from x86-vm.lisp then @@ -136,48 +136,48 @@ ;;; ;;; Given the sigcontext, extract the internal error arguments from the ;;; instruction stream. -;;; +;;; (defun internal-error-args (context) (declare (type (alien (* os-context-t)) context)) (let* ((pc (context-pc context)) - (bad-inst (sap-ref-32 pc 0)) - (op (ldb (byte 16 16) bad-inst))) + (bad-inst (sap-ref-32 pc 0)) + (op (ldb (byte 16 16) bad-inst))) (declare (type system-area-pointer pc)) (cond ((= op (logior (ash 3 10) (ash 6 5))) - (args-for-unimp-inst context)) - ((and (= (ldb (byte 6 10) op) 3) - (= (ldb (byte 5 5) op) 24)) - (let* ((regnum (ldb (byte 5 0) op)) - (prev (sap-ref-32 (int-sap (- (sap-int pc) 4)) 0))) - (if (and (= (ldb (byte 6 26) prev) 3) - (= (ldb (byte 5 21) prev) 0)) - (values (ldb (byte 16 0) prev) - (list (sb!c::make-sc-offset sb!vm:any-reg-sc-number + (args-for-unimp-inst context)) + ((and (= (ldb (byte 6 10) op) 3) + (= (ldb (byte 5 5) op) 24)) + (let* ((regnum (ldb (byte 5 0) op)) + (prev (sap-ref-32 (int-sap (- (sap-int pc) 4)) 0))) + (if (and (= (ldb (byte 6 26) prev) 3) + (= (ldb (byte 5 21) prev) 0)) + (values (ldb (byte 16 0) prev) + (list (sb!c::make-sc-offset sb!vm:any-reg-sc-number (ldb (byte 5 16) prev)))) - (values #.(sb!kernel:error-number-or-lose - 'sb!kernel:invalid-arg-count-error) + (values #.(sb!kernel:error-number-or-lose + 'sb!kernel:invalid-arg-count-error) (list (sb!c::make-sc-offset sb!vm:any-reg-sc-number regnum)))))) - - (t - (values #.(error-number-or-lose 'unknown-error) nil))))) + + (t + (values #.(error-number-or-lose 'unknown-error) nil))))) (defun args-for-unimp-inst (context) (declare (type (alien (* os-context-t)) context)) (let* ((pc (context-pc context)) - (length (sap-ref-8 pc 4)) - (vector (make-array length :element-type '(unsigned-byte 8)))) + (length (sap-ref-8 pc 4)) + (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (type system-area-pointer pc) - (type (unsigned-byte 8) length) - (type (simple-array (unsigned-byte 8) (*)) vector)) + (type (unsigned-byte 8) length) + (type (simple-array (unsigned-byte 8) (*)) vector)) (copy-ub8-from-system-area pc 5 vector 0 length) (let* ((index 0) - (error-number (sb!c:read-var-integer vector index))) + (error-number (sb!c:read-var-integer vector index))) (collect ((sc-offsets)) - (loop - (when (>= index length) - (return)) - (sc-offsets (sb!c:read-var-integer vector index))) - (values error-number (sc-offsets)))))) + (loop + (when (>= index length) + (return)) + (sc-offsets (sb!c:read-var-integer vector index))) + (values error-number (sc-offsets)))))) diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index af4eaa2..aadf41a 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -17,7 +17,7 @@ ;;; COLUMN - offset (if characters) from the start of the current line ;;; INDEX - index into the output buffer ;;; POSN - some position in the stream of characters cycling through -;;; the output buffer +;;; the output buffer (deftype column () '(and fixnum unsigned-byte)) ;;; The INDEX type is picked up from the kernel package. @@ -29,19 +29,19 @@ (defconstant default-line-length 80) (defstruct (pretty-stream (:include sb!kernel:ansi-stream - (out #'pretty-out) - (sout #'pretty-sout) - (misc #'pretty-misc)) - (:constructor make-pretty-stream (target)) - (:copier nil)) + (out #'pretty-out) + (sout #'pretty-sout) + (misc #'pretty-misc)) + (:constructor make-pretty-stream (target)) + (:copier nil)) ;; Where the output is going to finally go. (target (missing-arg) :type stream) ;; Line length we should format to. Cached here so we don't have to keep ;; extracting it from the target stream. (line-length (or *print-right-margin* - (sb!impl::line-length target) - default-line-length) - :type column) + (sb!impl::line-length target) + default-line-length) + :type column) ;; A simple string holding all the text that has been output but not yet ;; printed. (buffer (make-string initial-buffer-size) :type (simple-array character (*))) @@ -99,15 +99,15 @@ #!-sb-fluid (declaim (inline index-posn posn-index posn-column)) (defun index-posn (index stream) (declare (type index index) (type pretty-stream stream) - (values posn)) + (values posn)) (+ index (pretty-stream-buffer-offset stream))) (defun posn-index (posn stream) (declare (type posn posn) (type pretty-stream stream) - (values index)) + (values index)) (- posn (pretty-stream-buffer-offset stream))) (defun posn-column (posn stream) (declare (type posn posn) (type pretty-stream stream) - (values posn)) + (values posn)) (index-column (posn-index posn stream) stream)) ;;; Is it OK to do pretty printing on this stream at this time? @@ -119,48 +119,48 @@ (defun pretty-out (stream char) (declare (type pretty-stream stream) - (type character char)) + (type character char)) (cond ((char= char #\newline) - (enqueue-newline stream :literal)) - (t - (ensure-space-in-buffer stream 1) - (let ((fill-pointer (pretty-stream-buffer-fill-pointer stream))) - (setf (schar (pretty-stream-buffer stream) fill-pointer) char) - (setf (pretty-stream-buffer-fill-pointer stream) - (1+ fill-pointer)))))) + (enqueue-newline stream :literal)) + (t + (ensure-space-in-buffer stream 1) + (let ((fill-pointer (pretty-stream-buffer-fill-pointer stream))) + (setf (schar (pretty-stream-buffer stream) fill-pointer) char) + (setf (pretty-stream-buffer-fill-pointer stream) + (1+ fill-pointer)))))) (defun pretty-sout (stream string start end) (declare (type pretty-stream stream) - (type simple-string string) - (type index start) - (type (or index null) end)) + (type simple-string string) + (type index start) + (type (or index null) end)) (let* ((string (if (typep string '(simple-array character (*))) - string - (coerce string '(simple-array character (*))))) - (end (or end (length string)))) + string + (coerce string '(simple-array character (*))))) + (end (or end (length string)))) (unless (= start end) (let ((newline (position #\newline string :start start :end end))) - (cond - (newline - (pretty-sout stream string start newline) - (enqueue-newline stream :literal) - (pretty-sout stream string (1+ newline) end)) - (t - (let ((chars (- end start))) - (loop - (let* ((available (ensure-space-in-buffer stream chars)) - (count (min available chars)) - (fill-pointer (pretty-stream-buffer-fill-pointer stream)) - (new-fill-ptr (+ fill-pointer count))) - (replace (pretty-stream-buffer stream) - string - :start1 fill-pointer :end1 new-fill-ptr - :start2 start) - (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) - (decf chars count) - (when (zerop count) - (return)) - (incf start count)))))))))) + (cond + (newline + (pretty-sout stream string start newline) + (enqueue-newline stream :literal) + (pretty-sout stream string (1+ newline) end)) + (t + (let ((chars (- end start))) + (loop + (let* ((available (ensure-space-in-buffer stream chars)) + (count (min available chars)) + (fill-pointer (pretty-stream-buffer-fill-pointer stream)) + (new-fill-ptr (+ fill-pointer count))) + (replace (pretty-stream-buffer stream) + string + :start1 fill-pointer :end1 new-fill-ptr + :start2 start) + (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) + (decf chars count) + (when (zerop count) + (return)) + (incf start count)))))))))) (defun pretty-misc (stream op &optional arg1 arg2) (declare (ignore stream op arg1 arg2))) @@ -184,60 +184,60 @@ (defun really-start-logical-block (stream column prefix suffix) (let* ((blocks (pretty-stream-blocks stream)) - (prev-block (car blocks)) - (per-line-end (logical-block-per-line-prefix-end prev-block)) - (prefix-length (logical-block-prefix-length prev-block)) - (suffix-length (logical-block-suffix-length prev-block)) - (block (make-logical-block - :start-column column - :section-column column - :per-line-prefix-end per-line-end - :prefix-length prefix-length - :suffix-length suffix-length - :section-start-line (pretty-stream-line-number stream)))) + (prev-block (car blocks)) + (per-line-end (logical-block-per-line-prefix-end prev-block)) + (prefix-length (logical-block-prefix-length prev-block)) + (suffix-length (logical-block-suffix-length prev-block)) + (block (make-logical-block + :start-column column + :section-column column + :per-line-prefix-end per-line-end + :prefix-length prefix-length + :suffix-length suffix-length + :section-start-line (pretty-stream-line-number stream)))) (setf (pretty-stream-blocks stream) (cons block blocks)) (set-indentation stream column) (when prefix (setf (logical-block-per-line-prefix-end block) column) (replace (pretty-stream-prefix stream) prefix - :start1 (- column (length prefix)) :end1 column)) + :start1 (- column (length prefix)) :end1 column)) (when suffix (let* ((total-suffix (pretty-stream-suffix stream)) - (total-suffix-len (length total-suffix)) - (additional (length suffix)) - (new-suffix-len (+ suffix-length additional))) - (when (> new-suffix-len total-suffix-len) - (let ((new-total-suffix-len - (max (* total-suffix-len 2) - (+ suffix-length - (floor (* additional 5) 4))))) - (setf total-suffix - (replace (make-string new-total-suffix-len) total-suffix - :start1 (- new-total-suffix-len suffix-length) - :start2 (- total-suffix-len suffix-length))) - (setf total-suffix-len new-total-suffix-len) - (setf (pretty-stream-suffix stream) total-suffix))) - (replace total-suffix suffix - :start1 (- total-suffix-len new-suffix-len) - :end1 (- total-suffix-len suffix-length)) - (setf (logical-block-suffix-length block) new-suffix-len)))) + (total-suffix-len (length total-suffix)) + (additional (length suffix)) + (new-suffix-len (+ suffix-length additional))) + (when (> new-suffix-len total-suffix-len) + (let ((new-total-suffix-len + (max (* total-suffix-len 2) + (+ suffix-length + (floor (* additional 5) 4))))) + (setf total-suffix + (replace (make-string new-total-suffix-len) total-suffix + :start1 (- new-total-suffix-len suffix-length) + :start2 (- total-suffix-len suffix-length))) + (setf total-suffix-len new-total-suffix-len) + (setf (pretty-stream-suffix stream) total-suffix))) + (replace total-suffix suffix + :start1 (- total-suffix-len new-suffix-len) + :end1 (- total-suffix-len suffix-length)) + (setf (logical-block-suffix-length block) new-suffix-len)))) nil) (defun set-indentation (stream column) (let* ((prefix (pretty-stream-prefix stream)) - (prefix-len (length prefix)) - (block (car (pretty-stream-blocks stream))) - (current (logical-block-prefix-length block)) - (minimum (logical-block-per-line-prefix-end block)) - (column (max minimum column))) + (prefix-len (length prefix)) + (block (car (pretty-stream-blocks stream))) + (current (logical-block-prefix-length block)) + (minimum (logical-block-per-line-prefix-end block)) + (column (max minimum column))) (when (> column prefix-len) (setf prefix - (replace (make-string (max (* prefix-len 2) - (+ prefix-len - (floor (* (- column prefix-len) 5) - 4)))) - prefix - :end1 current)) + (replace (make-string (max (* prefix-len 2) + (+ prefix-len + (floor (* (- column prefix-len) 5) + 4)))) + prefix + :end1 current)) (setf (pretty-stream-prefix stream) prefix)) (when (> column current) (fill prefix #\space :start current :end column)) @@ -245,62 +245,62 @@ (defun really-end-logical-block (stream) (let* ((old (pop (pretty-stream-blocks stream))) - (old-indent (logical-block-prefix-length old)) - (new (car (pretty-stream-blocks stream))) - (new-indent (logical-block-prefix-length new))) + (old-indent (logical-block-prefix-length old)) + (new (car (pretty-stream-blocks stream))) + (new-indent (logical-block-prefix-length new))) (when (> new-indent old-indent) (fill (pretty-stream-prefix stream) #\space - :start old-indent :end new-indent))) + :start old-indent :end new-indent))) nil) ;;;; the pending operation queue (defstruct (queued-op (:constructor nil) - (:copier nil)) + (:copier nil)) (posn 0 :type posn)) (defmacro enqueue (stream type &rest args) (let ((constructor (symbolicate "MAKE-" type))) (once-only ((stream stream) - (entry `(,constructor :posn - (index-posn - (pretty-stream-buffer-fill-pointer - ,stream) - ,stream) - ,@args)) - (op `(list ,entry)) - (head `(pretty-stream-queue-head ,stream))) + (entry `(,constructor :posn + (index-posn + (pretty-stream-buffer-fill-pointer + ,stream) + ,stream) + ,@args)) + (op `(list ,entry)) + (head `(pretty-stream-queue-head ,stream))) `(progn - (if ,head - (setf (cdr ,head) ,op) - (setf (pretty-stream-queue-tail ,stream) ,op)) - (setf (pretty-stream-queue-head ,stream) ,op) - ,entry)))) + (if ,head + (setf (cdr ,head) ,op) + (setf (pretty-stream-queue-tail ,stream) ,op)) + (setf (pretty-stream-queue-head ,stream) ,op) + ,entry)))) (defstruct (section-start (:include queued-op) - (:constructor nil) - (:copier nil)) + (:constructor nil) + (:copier nil)) (depth 0 :type index) (section-end nil :type (or null newline block-end))) (defstruct (newline (:include section-start) - (:copier nil)) + (:copier nil)) (kind (missing-arg) - :type (member :linear :fill :miser :literal :mandatory))) + :type (member :linear :fill :miser :literal :mandatory))) (defun enqueue-newline (stream kind) (let* ((depth (length (pretty-stream-pending-blocks stream))) - (newline (enqueue stream newline :kind kind :depth depth))) + (newline (enqueue stream newline :kind kind :depth depth))) (dolist (entry (pretty-stream-queue-tail stream)) (when (and (not (eq newline entry)) - (section-start-p entry) - (null (section-start-section-end entry)) - (<= depth (section-start-depth entry))) - (setf (section-start-section-end entry) newline)))) + (section-start-p entry) + (null (section-start-section-end entry)) + (<= depth (section-start-depth entry))) + (setf (section-start-section-end entry) newline)))) (maybe-output stream (or (eq kind :literal) (eq kind :mandatory)))) (defstruct (indentation (:include queued-op) - (:copier nil)) + (:copier nil)) (kind (missing-arg) :type (member :block :current)) (amount 0 :type fixnum)) @@ -308,7 +308,7 @@ (enqueue stream indentation :kind kind :amount amount)) (defstruct (block-start (:include section-start) - (:copier nil)) + (:copier nil)) (block-end nil :type (or null block-end)) (prefix nil :type (or null (simple-array character (*)))) (suffix nil :type (or null (simple-array character (*))))) @@ -325,27 +325,27 @@ (setq prefix (coerce prefix '(simple-array character (*)))) (pretty-sout stream prefix 0 (length prefix))) (let* ((pending-blocks (pretty-stream-pending-blocks stream)) - (start (enqueue stream block-start - :prefix (and per-line-p prefix) - :suffix (coerce suffix '(simple-array character (*))) - :depth (length pending-blocks)))) + (start (enqueue stream block-start + :prefix (and per-line-p prefix) + :suffix (coerce suffix '(simple-array character (*))) + :depth (length pending-blocks)))) (setf (pretty-stream-pending-blocks stream) - (cons start pending-blocks)))) + (cons start pending-blocks)))) (defstruct (block-end (:include queued-op) - (:copier nil)) + (:copier nil)) (suffix nil :type (or null (simple-array character (*))))) (defun end-logical-block (stream) (let* ((start (pop (pretty-stream-pending-blocks stream))) - (suffix (block-start-suffix start)) - (end (enqueue stream block-end :suffix suffix))) + (suffix (block-start-suffix start)) + (end (enqueue stream block-end :suffix suffix))) (when suffix (pretty-sout stream suffix 0 (length suffix))) (setf (block-start-block-end start) end))) (defstruct (tab (:include queued-op) - (:copier nil)) + (:copier nil)) (sectionp nil :type (member t nil)) (relativep nil :type (member t nil)) (colnum 0 :type column) @@ -354,12 +354,12 @@ (defun enqueue-tab (stream kind colnum colinc) (multiple-value-bind (sectionp relativep) (ecase kind - (:line (values nil nil)) - (:line-relative (values nil t)) - (:section (values t nil)) - (:section-relative (values t t))) + (:line (values nil nil)) + (:line-relative (values nil t)) + (:section (values t nil)) + (:section-relative (values t t))) (enqueue stream tab :sectionp sectionp :relativep relativep - :colnum colnum :colinc colinc))) + :colnum colnum :colinc colinc))) ;;;; tab support @@ -369,174 +369,174 @@ (colinc (tab-colinc tab)) (position (- column origin))) (cond ((tab-relativep tab) - (unless (<= colinc 1) - (let ((newposn (+ position colnum))) - (let ((rem (rem newposn colinc))) - (unless (zerop rem) - (incf colnum (- colinc rem)))))) - colnum) - ((< position colnum) + (unless (<= colinc 1) + (let ((newposn (+ position colnum))) + (let ((rem (rem newposn colinc))) + (unless (zerop rem) + (incf colnum (- colinc rem)))))) + colnum) + ((< position colnum) (- colnum position)) - ((zerop colinc) 0) + ((zerop colinc) 0) (t - (- colinc - (rem (- position colnum) colinc)))))) + (- colinc + (rem (- position colnum) colinc)))))) (defun index-column (index stream) (let ((column (pretty-stream-buffer-start-column stream)) - (section-start (logical-block-section-column - (first (pretty-stream-blocks stream)))) - (end-posn (index-posn index stream))) + (section-start (logical-block-section-column + (first (pretty-stream-blocks stream)))) + (end-posn (index-posn index stream))) (dolist (op (pretty-stream-queue-tail stream)) (when (>= (queued-op-posn op) end-posn) - (return)) + (return)) (typecase op - (tab - (incf column - (compute-tab-size op - section-start - (+ column - (posn-index (tab-posn op) - stream))))) - ((or newline block-start) - (setf section-start - (+ column (posn-index (queued-op-posn op) - stream)))))) + (tab + (incf column + (compute-tab-size op + section-start + (+ column + (posn-index (tab-posn op) + stream))))) + ((or newline block-start) + (setf section-start + (+ column (posn-index (queued-op-posn op) + stream)))))) (+ column index))) (defun expand-tabs (stream through) (let ((insertions nil) - (additional 0) - (column (pretty-stream-buffer-start-column stream)) - (section-start (logical-block-section-column - (first (pretty-stream-blocks stream))))) + (additional 0) + (column (pretty-stream-buffer-start-column stream)) + (section-start (logical-block-section-column + (first (pretty-stream-blocks stream))))) (dolist (op (pretty-stream-queue-tail stream)) (typecase op - (tab - (let* ((index (posn-index (tab-posn op) stream)) - (tabsize (compute-tab-size op - section-start - (+ column index)))) - (unless (zerop tabsize) - (push (cons index tabsize) insertions) - (incf additional tabsize) - (incf column tabsize)))) - ((or newline block-start) - (setf section-start - (+ column (posn-index (queued-op-posn op) stream))))) + (tab + (let* ((index (posn-index (tab-posn op) stream)) + (tabsize (compute-tab-size op + section-start + (+ column index)))) + (unless (zerop tabsize) + (push (cons index tabsize) insertions) + (incf additional tabsize) + (incf column tabsize)))) + ((or newline block-start) + (setf section-start + (+ column (posn-index (queued-op-posn op) stream))))) (when (eq op through) - (return))) + (return))) (when insertions (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) - (new-fill-ptr (+ fill-ptr additional)) - (buffer (pretty-stream-buffer stream)) - (new-buffer buffer) - (length (length buffer)) - (end fill-ptr)) - (when (> new-fill-ptr length) - (let ((new-length (max (* length 2) - (+ fill-ptr - (floor (* additional 5) 4))))) - (setf new-buffer (make-string new-length)) - (setf (pretty-stream-buffer stream) new-buffer))) - (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) - (decf (pretty-stream-buffer-offset stream) additional) - (dolist (insertion insertions) - (let* ((srcpos (car insertion)) - (amount (cdr insertion)) - (dstpos (+ srcpos additional))) - (replace new-buffer buffer :start1 dstpos :start2 srcpos :end2 end) - (fill new-buffer #\space :start (- dstpos amount) :end dstpos) - (decf additional amount) - (setf end srcpos))) - (unless (eq new-buffer buffer) - (replace new-buffer buffer :end1 end :end2 end)))))) + (new-fill-ptr (+ fill-ptr additional)) + (buffer (pretty-stream-buffer stream)) + (new-buffer buffer) + (length (length buffer)) + (end fill-ptr)) + (when (> new-fill-ptr length) + (let ((new-length (max (* length 2) + (+ fill-ptr + (floor (* additional 5) 4))))) + (setf new-buffer (make-string new-length)) + (setf (pretty-stream-buffer stream) new-buffer))) + (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) + (decf (pretty-stream-buffer-offset stream) additional) + (dolist (insertion insertions) + (let* ((srcpos (car insertion)) + (amount (cdr insertion)) + (dstpos (+ srcpos additional))) + (replace new-buffer buffer :start1 dstpos :start2 srcpos :end2 end) + (fill new-buffer #\space :start (- dstpos amount) :end dstpos) + (decf additional amount) + (setf end srcpos))) + (unless (eq new-buffer buffer) + (replace new-buffer buffer :end1 end :end2 end)))))) ;;;; stuff to do the actual outputting (defun ensure-space-in-buffer (stream want) (declare (type pretty-stream stream) - (type index want)) + (type index want)) (let* ((buffer (pretty-stream-buffer stream)) - (length (length buffer)) - (fill-ptr (pretty-stream-buffer-fill-pointer stream)) - (available (- length fill-ptr))) + (length (length buffer)) + (fill-ptr (pretty-stream-buffer-fill-pointer stream)) + (available (- length fill-ptr))) (cond ((plusp available) - available) - ((> fill-ptr (pretty-stream-line-length stream)) - (unless (maybe-output stream nil) - (output-partial-line stream)) - (ensure-space-in-buffer stream want)) - (t - (let* ((new-length (max (* length 2) - (+ length - (floor (* want 5) 4)))) - (new-buffer (make-string new-length))) - (setf (pretty-stream-buffer stream) new-buffer) - (replace new-buffer buffer :end1 fill-ptr) - (- new-length fill-ptr)))))) + available) + ((> fill-ptr (pretty-stream-line-length stream)) + (unless (maybe-output stream nil) + (output-partial-line stream)) + (ensure-space-in-buffer stream want)) + (t + (let* ((new-length (max (* length 2) + (+ length + (floor (* want 5) 4)))) + (new-buffer (make-string new-length))) + (setf (pretty-stream-buffer stream) new-buffer) + (replace new-buffer buffer :end1 fill-ptr) + (- new-length fill-ptr)))))) (defun maybe-output (stream force-newlines-p) (declare (type pretty-stream stream)) (let ((tail (pretty-stream-queue-tail stream)) - (output-anything nil)) + (output-anything nil)) (loop (unless tail - (setf (pretty-stream-queue-head stream) nil) - (return)) + (setf (pretty-stream-queue-head stream) nil) + (return)) (let ((next (pop tail))) - (etypecase next - (newline - (when (ecase (newline-kind next) - ((:literal :mandatory :linear) t) - (:miser (misering-p stream)) - (:fill - (or (misering-p stream) - (> (pretty-stream-line-number stream) - (logical-block-section-start-line - (first (pretty-stream-blocks stream)))) - (ecase (fits-on-line-p stream - (newline-section-end next) - force-newlines-p) - ((t) nil) - ((nil) t) - (:dont-know - (return)))))) - (setf output-anything t) - (output-line stream next))) - (indentation - (unless (misering-p stream) - (set-indentation stream - (+ (ecase (indentation-kind next) - (:block - (logical-block-start-column - (car (pretty-stream-blocks stream)))) - (:current - (posn-column - (indentation-posn next) - stream))) - (indentation-amount next))))) - (block-start - (ecase (fits-on-line-p stream (block-start-section-end next) - force-newlines-p) - ((t) - ;; Just nuke the whole logical block and make it look - ;; like one nice long literal. - (let ((end (block-start-block-end next))) - (expand-tabs stream end) - (setf tail (cdr (member end tail))))) - ((nil) - (really-start-logical-block - stream - (posn-column (block-start-posn next) stream) - (block-start-prefix next) - (block-start-suffix next))) - (:dont-know - (return)))) - (block-end - (really-end-logical-block stream)) - (tab - (expand-tabs stream next)))) + (etypecase next + (newline + (when (ecase (newline-kind next) + ((:literal :mandatory :linear) t) + (:miser (misering-p stream)) + (:fill + (or (misering-p stream) + (> (pretty-stream-line-number stream) + (logical-block-section-start-line + (first (pretty-stream-blocks stream)))) + (ecase (fits-on-line-p stream + (newline-section-end next) + force-newlines-p) + ((t) nil) + ((nil) t) + (:dont-know + (return)))))) + (setf output-anything t) + (output-line stream next))) + (indentation + (unless (misering-p stream) + (set-indentation stream + (+ (ecase (indentation-kind next) + (:block + (logical-block-start-column + (car (pretty-stream-blocks stream)))) + (:current + (posn-column + (indentation-posn next) + stream))) + (indentation-amount next))))) + (block-start + (ecase (fits-on-line-p stream (block-start-section-end next) + force-newlines-p) + ((t) + ;; Just nuke the whole logical block and make it look + ;; like one nice long literal. + (let ((end (block-start-block-end next))) + (expand-tabs stream end) + (setf tail (cdr (member end tail))))) + ((nil) + (really-start-logical-block + stream + (posn-column (block-start-posn next) stream) + (block-start-prefix next) + (block-start-suffix next))) + (:dont-know + (return)))) + (block-end + (really-end-logical-block stream)) + (tab + (expand-tabs stream next)))) (setf (pretty-stream-queue-tail stream) tail)) output-anything)) @@ -544,104 +544,104 @@ (declare (type pretty-stream stream)) (and *print-miser-width* (<= (- (pretty-stream-line-length stream) - (logical-block-start-column (car (pretty-stream-blocks stream)))) - *print-miser-width*))) + (logical-block-start-column (car (pretty-stream-blocks stream)))) + *print-miser-width*))) (defun fits-on-line-p (stream until force-newlines-p) (let ((available (pretty-stream-line-length stream))) (when (and (not *print-readably*) - (pretty-stream-print-lines stream) - (= (pretty-stream-print-lines stream) - (pretty-stream-line-number stream))) + (pretty-stream-print-lines stream) + (= (pretty-stream-print-lines stream) + (pretty-stream-line-number stream))) (decf available 3) ; for the `` ..'' (decf available (logical-block-suffix-length - (car (pretty-stream-blocks stream))))) + (car (pretty-stream-blocks stream))))) (cond (until - (<= (posn-column (queued-op-posn until) stream) available)) - (force-newlines-p nil) - ((> (index-column (pretty-stream-buffer-fill-pointer stream) stream) - available) - nil) - (t - :dont-know)))) + (<= (posn-column (queued-op-posn until) stream) available)) + (force-newlines-p nil) + ((> (index-column (pretty-stream-buffer-fill-pointer stream) stream) + available) + nil) + (t + :dont-know)))) (defun output-line (stream until) (declare (type pretty-stream stream) - (type newline until)) + (type newline until)) (let* ((target (pretty-stream-target stream)) - (buffer (pretty-stream-buffer stream)) - (kind (newline-kind until)) - (literal-p (eq kind :literal)) - (amount-to-consume (posn-index (newline-posn until) stream)) - (amount-to-print - (if literal-p - amount-to-consume - (let ((last-non-blank - (position #\space buffer :end amount-to-consume - :from-end t :test #'char/=))) - (if last-non-blank - (1+ last-non-blank) - 0))))) + (buffer (pretty-stream-buffer stream)) + (kind (newline-kind until)) + (literal-p (eq kind :literal)) + (amount-to-consume (posn-index (newline-posn until) stream)) + (amount-to-print + (if literal-p + amount-to-consume + (let ((last-non-blank + (position #\space buffer :end amount-to-consume + :from-end t :test #'char/=))) + (if last-non-blank + (1+ last-non-blank) + 0))))) (write-string buffer target :end amount-to-print) (let ((line-number (pretty-stream-line-number stream))) (incf line-number) (when (and (not *print-readably*) - (pretty-stream-print-lines stream) - (>= line-number (pretty-stream-print-lines stream))) - (write-string " .." target) - (let ((suffix-length (logical-block-suffix-length - (car (pretty-stream-blocks stream))))) - (unless (zerop suffix-length) - (let* ((suffix (pretty-stream-suffix stream)) - (len (length suffix))) - (write-string suffix target - :start (- len suffix-length) - :end len)))) - (throw 'line-limit-abbreviation-happened t)) + (pretty-stream-print-lines stream) + (>= line-number (pretty-stream-print-lines stream))) + (write-string " .." target) + (let ((suffix-length (logical-block-suffix-length + (car (pretty-stream-blocks stream))))) + (unless (zerop suffix-length) + (let* ((suffix (pretty-stream-suffix stream)) + (len (length suffix))) + (write-string suffix target + :start (- len suffix-length) + :end len)))) + (throw 'line-limit-abbreviation-happened t)) (setf (pretty-stream-line-number stream) line-number) (write-char #\newline target) (setf (pretty-stream-buffer-start-column stream) 0) (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) - (block (first (pretty-stream-blocks stream))) - (prefix-len - (if literal-p - (logical-block-per-line-prefix-end block) - (logical-block-prefix-length block))) - (shift (- amount-to-consume prefix-len)) - (new-fill-ptr (- fill-ptr shift)) - (new-buffer buffer) - (buffer-length (length buffer))) - (when (> new-fill-ptr buffer-length) - (setf new-buffer - (make-string (max (* buffer-length 2) - (+ buffer-length - (floor (* (- new-fill-ptr buffer-length) - 5) - 4))))) - (setf (pretty-stream-buffer stream) new-buffer)) - (replace new-buffer buffer - :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr) - (replace new-buffer (pretty-stream-prefix stream) - :end1 prefix-len) - (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) - (incf (pretty-stream-buffer-offset stream) shift) - (unless literal-p - (setf (logical-block-section-column block) prefix-len) - (setf (logical-block-section-start-line block) line-number)))))) + (block (first (pretty-stream-blocks stream))) + (prefix-len + (if literal-p + (logical-block-per-line-prefix-end block) + (logical-block-prefix-length block))) + (shift (- amount-to-consume prefix-len)) + (new-fill-ptr (- fill-ptr shift)) + (new-buffer buffer) + (buffer-length (length buffer))) + (when (> new-fill-ptr buffer-length) + (setf new-buffer + (make-string (max (* buffer-length 2) + (+ buffer-length + (floor (* (- new-fill-ptr buffer-length) + 5) + 4))))) + (setf (pretty-stream-buffer stream) new-buffer)) + (replace new-buffer buffer + :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr) + (replace new-buffer (pretty-stream-prefix stream) + :end1 prefix-len) + (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) + (incf (pretty-stream-buffer-offset stream) shift) + (unless literal-p + (setf (logical-block-section-column block) prefix-len) + (setf (logical-block-section-start-line block) line-number)))))) (defun output-partial-line (stream) (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) - (tail (pretty-stream-queue-tail stream)) - (count - (if tail - (posn-index (queued-op-posn (car tail)) stream) - fill-ptr)) - (new-fill-ptr (- fill-ptr count)) - (buffer (pretty-stream-buffer stream))) + (tail (pretty-stream-queue-tail stream)) + (count + (if tail + (posn-index (queued-op-posn (car tail)) stream) + fill-ptr)) + (new-fill-ptr (- fill-ptr count)) + (buffer (pretty-stream-buffer stream))) (when (zerop count) (error "Output-partial-line called when nothing can be output.")) (write-string buffer (pretty-stream-target stream) - :start 0 :end count) + :start 0 :end count) (incf (pretty-stream-buffer-start-column stream) count) (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr) (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) @@ -651,8 +651,8 @@ (maybe-output stream nil) (expand-tabs stream nil) (write-string (pretty-stream-buffer stream) - (pretty-stream-target stream) - :end (pretty-stream-buffer-fill-pointer stream))) + (pretty-stream-target stream) + :end (pretty-stream-buffer-fill-pointer stream))) ;;;; user interface to the pretty printer @@ -677,12 +677,12 @@ from the output and indentation is introduced at the beginning of the next line. (See PPRINT-INDENT.)" (declare (type (member :linear :miser :fill :mandatory) kind) - (type (or stream (member t nil)) stream) - (values null)) + (type (or stream (member t nil)) stream) + (values null)) (let ((stream (case stream - ((t) *terminal-io*) - ((nil) *standard-output*) - (t stream)))) + ((t) *terminal-io*) + ((nil) *standard-output*) + (t stream)))) (when (print-pretty-on-stream-p stream) (enqueue-newline stream kind))) nil) @@ -699,13 +699,13 @@ The new indentation value does not take effect until the following line break." (declare (type (member :block :current) relative-to) - (type real n) - (type (or stream (member t nil)) stream) - (values null)) + (type real n) + (type (or stream (member t nil)) stream) + (values null)) (let ((stream (case stream - ((t) *terminal-io*) - ((nil) *standard-output*) - (t stream)))) + ((t) *terminal-io*) + ((nil) *standard-output*) + (t stream)))) (when (print-pretty-on-stream-p stream) (enqueue-indent stream relative-to (truncate n)))) nil) @@ -724,13 +724,13 @@ :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start of the current section, not the start of the line." (declare (type (member :line :section :line-relative :section-relative) kind) - (type unsigned-byte colnum colinc) - (type (or stream (member t nil)) stream) - (values null)) + (type unsigned-byte colnum colinc) + (type (or stream (member t nil)) stream) + (values null)) (let ((stream (case stream - ((t) *terminal-io*) - ((nil) *standard-output*) - (t stream)))) + ((t) *terminal-io*) + ((nil) *standard-output*) + (t stream)))) (when (print-pretty-on-stream-p stream) (enqueue-tab stream kind colnum colinc))) nil) @@ -743,8 +743,8 @@ can be used with the ~/.../ format directive." (declare (ignore atsign?)) (pprint-logical-block (stream list - :prefix (if colon? "(" "") - :suffix (if colon? ")" "")) + :prefix (if colon? "(" "") + :suffix (if colon? ")" "")) (pprint-exit-if-list-exhausted) (loop (output-object (pprint-pop) stream) @@ -760,8 +760,8 @@ can be used with the ~/.../ format directive." (declare (ignore atsign?)) (pprint-logical-block (stream list - :prefix (if colon? "(" "") - :suffix (if colon? ")" "")) + :prefix (if colon? "(" "") + :suffix (if colon? ")" "")) (pprint-exit-if-list-exhausted) (loop (output-object (pprint-pop) stream) @@ -779,8 +779,8 @@ the ~/.../ format directive." (declare (ignore atsign?)) (pprint-logical-block (stream list - :prefix (if colon? "(" "") - :suffix (if colon? ")" "")) + :prefix (if colon? "(" "") + :suffix (if colon? ")" "")) (pprint-exit-if-list-exhausted) (loop (output-object (pprint-pop) stream) @@ -812,9 +812,9 @@ (def!method print-object ((entry pprint-dispatch-entry) stream) (print-unreadable-object (entry stream :type t) (format stream "type=~S, priority=~S~@[ [initial]~]" - (pprint-dispatch-entry-type entry) - (pprint-dispatch-entry-priority entry) - (pprint-dispatch-entry-initial-p entry)))) + (pprint-dispatch-entry-type entry) + (pprint-dispatch-entry-priority entry) + (pprint-dispatch-entry-initial-p entry)))) (defun cons-type-specifier-p (spec) (and (consp spec) @@ -822,128 +822,128 @@ (cdr spec) (null (cddr spec)) (let ((car (cadr spec))) - (and (consp car) - (let ((carcar (car car))) - (or (eq carcar 'member) - (eq carcar 'eql))) - (cdr car) - (null (cddr car)))))) + (and (consp car) + (let ((carcar (car car))) + (or (eq carcar 'member) + (eq carcar 'eql))) + (cdr car) + (null (cddr car)))))) (defun entry< (e1 e2) (declare (type pprint-dispatch-entry e1 e2)) (if (pprint-dispatch-entry-initial-p e1) (if (pprint-dispatch-entry-initial-p e2) - (< (pprint-dispatch-entry-priority e1) - (pprint-dispatch-entry-priority e2)) - t) + (< (pprint-dispatch-entry-priority e1) + (pprint-dispatch-entry-priority e2)) + t) (if (pprint-dispatch-entry-initial-p e2) - nil - (< (pprint-dispatch-entry-priority e1) - (pprint-dispatch-entry-priority e2))))) + nil + (< (pprint-dispatch-entry-priority e1) + (pprint-dispatch-entry-priority e2))))) (macrolet ((frob (x) - `(cons ',x (lambda (object) ,x)))) + `(cons ',x (lambda (object) ,x)))) (defvar *precompiled-pprint-dispatch-funs* (list (frob (typep object 'array)) - (frob (and (consp object) - (symbolp (car object)) - (fboundp (car object)))) - (frob (typep object 'cons))))) + (frob (and (consp object) + (symbolp (car object)) + (fboundp (car object)))) + (frob (typep object 'cons))))) (defun compute-test-fn (type) (let ((was-cons nil)) (labels ((compute-test-expr (type object) - (if (listp type) - (case (car type) - (cons - (setq was-cons t) - (destructuring-bind - (&optional (car nil car-p) (cdr nil cdr-p)) - (cdr type) - `(and (consp ,object) - ,@(when car-p - `(,(compute-test-expr - car `(car ,object)))) - ,@(when cdr-p - `(,(compute-test-expr - cdr `(cdr ,object))))))) - (not - (destructuring-bind (type) (cdr type) - `(not ,(compute-test-expr type object)))) - (and - `(and ,@(mapcar (lambda (type) - (compute-test-expr type object)) - (cdr type)))) - (or - `(or ,@(mapcar (lambda (type) - (compute-test-expr type object)) - (cdr type)))) - (t - `(typep ,object ',type))) - `(typep ,object ',type)))) + (if (listp type) + (case (car type) + (cons + (setq was-cons t) + (destructuring-bind + (&optional (car nil car-p) (cdr nil cdr-p)) + (cdr type) + `(and (consp ,object) + ,@(when car-p + `(,(compute-test-expr + car `(car ,object)))) + ,@(when cdr-p + `(,(compute-test-expr + cdr `(cdr ,object))))))) + (not + (destructuring-bind (type) (cdr type) + `(not ,(compute-test-expr type object)))) + (and + `(and ,@(mapcar (lambda (type) + (compute-test-expr type object)) + (cdr type)))) + (or + `(or ,@(mapcar (lambda (type) + (compute-test-expr type object)) + (cdr type)))) + (t + `(typep ,object ',type))) + `(typep ,object ',type)))) (let ((expr (compute-test-expr type 'object))) - (cond ((cdr (assoc expr *precompiled-pprint-dispatch-funs* - :test #'equal))) - (t - (compile nil `(lambda (object) ,expr)))))))) + (cond ((cdr (assoc expr *precompiled-pprint-dispatch-funs* + :test #'equal))) + (t + (compile nil `(lambda (object) ,expr)))))))) (defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*)) (declare (type (or pprint-dispatch-table null) table)) (let* ((orig (or table *initial-pprint-dispatch*)) - (new (make-pprint-dispatch-table - :entries (copy-list (pprint-dispatch-table-entries orig)))) - (new-cons-entries (pprint-dispatch-table-cons-entries new))) + (new (make-pprint-dispatch-table + :entries (copy-list (pprint-dispatch-table-entries orig)))) + (new-cons-entries (pprint-dispatch-table-cons-entries new))) (maphash (lambda (key value) - (setf (gethash key new-cons-entries) value)) - (pprint-dispatch-table-cons-entries orig)) + (setf (gethash key new-cons-entries) value)) + (pprint-dispatch-table-cons-entries orig)) new)) (defun pprint-dispatch (object &optional (table *print-pprint-dispatch*)) (declare (type (or pprint-dispatch-table null) table)) (let* ((table (or table *initial-pprint-dispatch*)) - (cons-entry - (and (consp object) - (gethash (car object) - (pprint-dispatch-table-cons-entries table)))) - (entry - (dolist (entry (pprint-dispatch-table-entries table) cons-entry) - (when (and cons-entry - (entry< entry cons-entry)) - (return cons-entry)) - (when (funcall (pprint-dispatch-entry-test-fn entry) object) - (return entry))))) + (cons-entry + (and (consp object) + (gethash (car object) + (pprint-dispatch-table-cons-entries table)))) + (entry + (dolist (entry (pprint-dispatch-table-entries table) cons-entry) + (when (and cons-entry + (entry< entry cons-entry)) + (return cons-entry)) + (when (funcall (pprint-dispatch-entry-test-fn entry) object) + (return entry))))) (if entry - (values (pprint-dispatch-entry-fun entry) t) - (values (lambda (stream object) - (output-ugly-object object stream)) - nil)))) + (values (pprint-dispatch-entry-fun entry) t) + (values (lambda (stream object) + (output-ugly-object object stream)) + nil)))) (defun set-pprint-dispatch (type function &optional - (priority 0) (table *print-pprint-dispatch*)) + (priority 0) (table *print-pprint-dispatch*)) (declare (type (or null callable) function) - (type real priority) - (type pprint-dispatch-table table)) + (type real priority) + (type pprint-dispatch-table table)) (/show0 "entering SET-PPRINT-DISPATCH, TYPE=...") (/hexstr type) (if function (if (cons-type-specifier-p type) - (setf (gethash (second (second type)) - (pprint-dispatch-table-cons-entries table)) - (make-pprint-dispatch-entry :type type - :priority priority - :fun function)) - (let ((list (delete type (pprint-dispatch-table-entries table) - :key #'pprint-dispatch-entry-type - :test #'equal)) - (entry (make-pprint-dispatch-entry - :type type + (setf (gethash (second (second type)) + (pprint-dispatch-table-cons-entries table)) + (make-pprint-dispatch-entry :type type + :priority priority + :fun function)) + (let ((list (delete type (pprint-dispatch-table-entries table) + :key #'pprint-dispatch-entry-type + :test #'equal)) + (entry (make-pprint-dispatch-entry + :type type :test-fn (compute-test-fn type) :priority priority :fun function))) - (do ((prev nil next) - (next list (cdr next))) - ((null next) - (if prev + (do ((prev nil next) + (next list (cdr next))) + ((null next) + (if prev (setf (cdr prev) (list entry)) (setf list (list entry)))) (when (entry< (car next) entry) @@ -951,14 +951,14 @@ (setf (cdr prev) (cons entry next)) (setf list (cons entry next))) (return))) - (setf (pprint-dispatch-table-entries table) list))) + (setf (pprint-dispatch-table-entries table) list))) (if (cons-type-specifier-p type) - (remhash (second (second type)) - (pprint-dispatch-table-cons-entries table)) - (setf (pprint-dispatch-table-entries table) - (delete type (pprint-dispatch-table-entries table) - :key #'pprint-dispatch-entry-type - :test #'equal)))) + (remhash (second (second type)) + (pprint-dispatch-table-cons-entries table)) + (setf (pprint-dispatch-table-entries table) + (delete type (pprint-dispatch-table-entries table) + :key #'pprint-dispatch-entry-type + :test #'equal)))) (/show0 "about to return NIL from SET-PPRINT-DISPATCH") nil) @@ -966,23 +966,23 @@ (defun pprint-array (stream array) (cond ((or (and (null *print-array*) (null *print-readably*)) - (stringp array) - (bit-vector-p array)) - (output-ugly-object array stream)) - ((and *print-readably* - (not (array-readably-printable-p array))) - (let ((*print-readably* nil)) - (error 'print-not-readable :object array))) - ((vectorp array) - (pprint-vector stream array)) - (t - (pprint-multi-dim-array stream array)))) + (stringp array) + (bit-vector-p array)) + (output-ugly-object array stream)) + ((and *print-readably* + (not (array-readably-printable-p array))) + (let ((*print-readably* nil)) + (error 'print-not-readable :object array))) + ((vectorp array) + (pprint-vector stream array)) + (t + (pprint-multi-dim-array stream array)))) (defun pprint-vector (stream vector) (pprint-logical-block (stream nil :prefix "#(" :suffix ")") (dotimes (i (length vector)) (unless (zerop i) - (format stream " ~:_")) + (format stream " ~:_")) (pprint-pop) (output-object (aref vector i) stream)))) @@ -991,31 +991,31 @@ (with-array-data ((data array) (start) (end)) (declare (ignore end)) (labels ((output-guts (stream index dimensions) - (if (null dimensions) - (output-object (aref data index) stream) - (pprint-logical-block - (stream nil :prefix "(" :suffix ")") - (let ((dim (car dimensions))) - (unless (zerop dim) - (let* ((dims (cdr dimensions)) - (index index) - (step (reduce #'* dims)) - (count 0)) - (loop - (pprint-pop) - (output-guts stream index dims) - (when (= (incf count) dim) - (return)) - (write-char #\space stream) - (pprint-newline (if dims :linear :fill) - stream) - (incf index step))))))))) + (if (null dimensions) + (output-object (aref data index) stream) + (pprint-logical-block + (stream nil :prefix "(" :suffix ")") + (let ((dim (car dimensions))) + (unless (zerop dim) + (let* ((dims (cdr dimensions)) + (index index) + (step (reduce #'* dims)) + (count 0)) + (loop + (pprint-pop) + (output-guts stream index dims) + (when (= (incf count) dim) + (return)) + (write-char #\space stream) + (pprint-newline (if dims :linear :fill) + stream) + (incf index step))))))))) (output-guts stream start (array-dimensions array))))) (defun pprint-lambda-list (stream lambda-list &rest noise) (declare (ignore noise)) (when (and (consp lambda-list) - (member (car lambda-list) *backq-tokens*)) + (member (car lambda-list) *backq-tokens*)) ;; if this thing looks like a backquoty thing, then we don't want ;; to destructure it, we want to output it straight away. [ this ;; is the exception to the normal processing: if we did this @@ -1025,73 +1025,73 @@ (return-from pprint-lambda-list nil)) (pprint-logical-block (stream lambda-list :prefix "(" :suffix ")") (let ((state :required) - (first t)) + (first t)) (loop - (pprint-exit-if-list-exhausted) - (unless first - (write-char #\space stream)) - (let ((arg (pprint-pop))) - (unless first - (case arg - (&optional - (setf state :optional) - (pprint-newline :linear stream)) - ((&rest &body) - (setf state :required) - (pprint-newline :linear stream)) - (&key - (setf state :key) - (pprint-newline :linear stream)) - (&aux - (setf state :optional) - (pprint-newline :linear stream)) - (t - (pprint-newline :fill stream)))) - (ecase state - (:required - (pprint-lambda-list stream arg)) - ((:optional :key) - (pprint-logical-block - (stream arg :prefix "(" :suffix ")") - (pprint-exit-if-list-exhausted) - (if (eq state :key) - (pprint-logical-block - (stream (pprint-pop) :prefix "(" :suffix ")") - (pprint-exit-if-list-exhausted) - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :fill stream) - (pprint-lambda-list stream (pprint-pop)) - (loop - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :fill stream) - (output-object (pprint-pop) stream))) - (pprint-lambda-list stream (pprint-pop))) - (loop - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream) - (output-object (pprint-pop) stream)))))) - (setf first nil))))) + (pprint-exit-if-list-exhausted) + (unless first + (write-char #\space stream)) + (let ((arg (pprint-pop))) + (unless first + (case arg + (&optional + (setf state :optional) + (pprint-newline :linear stream)) + ((&rest &body) + (setf state :required) + (pprint-newline :linear stream)) + (&key + (setf state :key) + (pprint-newline :linear stream)) + (&aux + (setf state :optional) + (pprint-newline :linear stream)) + (t + (pprint-newline :fill stream)))) + (ecase state + (:required + (pprint-lambda-list stream arg)) + ((:optional :key) + (pprint-logical-block + (stream arg :prefix "(" :suffix ")") + (pprint-exit-if-list-exhausted) + (if (eq state :key) + (pprint-logical-block + (stream (pprint-pop) :prefix "(" :suffix ")") + (pprint-exit-if-list-exhausted) + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + (pprint-newline :fill stream) + (pprint-lambda-list stream (pprint-pop)) + (loop + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + (pprint-newline :fill stream) + (output-object (pprint-pop) stream))) + (pprint-lambda-list stream (pprint-pop))) + (loop + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + (pprint-newline :linear stream) + (output-object (pprint-pop) stream)))))) + (setf first nil))))) (defun pprint-lambda (stream list &rest noise) (declare (ignore noise)) (funcall (formatter - ;; KLUDGE: This format string, and other format strings which also - ;; refer to SB!PRETTY, rely on the current SBCL not-quite-ANSI - ;; behavior of FORMATTER in order to make code which survives the - ;; transition when SB!PRETTY is renamed to SB-PRETTY after cold - ;; init. (ANSI says that the FORMATTER functions should be - ;; equivalent to the format string, but the SBCL FORMATTER - ;; functions contain references to package objects, not package - ;; names, so they keep right on going if the packages are renamed.) - ;; If our FORMATTER behavior is ever made more compliant, the code - ;; here will have to change. -- WHN 19991207 - "~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>") - stream - list)) + ;; KLUDGE: This format string, and other format strings which also + ;; refer to SB!PRETTY, rely on the current SBCL not-quite-ANSI + ;; behavior of FORMATTER in order to make code which survives the + ;; transition when SB!PRETTY is renamed to SB-PRETTY after cold + ;; init. (ANSI says that the FORMATTER functions should be + ;; equivalent to the format string, but the SBCL FORMATTER + ;; functions contain references to package objects, not package + ;; names, so they keep right on going if the packages are renamed.) + ;; If our FORMATTER behavior is ever made more compliant, the code + ;; here will have to change. -- WHN 19991207 + "~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>") + stream + list)) (defun pprint-block (stream list &rest noise) (declare (ignore noise)) @@ -1100,7 +1100,7 @@ (defun pprint-flet (stream list &rest noise) (declare (ignore noise)) (if (and (consp list) - (consp (cdr list)) + (consp (cdr list)) (cddr list)) (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>") @@ -1118,8 +1118,8 @@ (defun pprint-let (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>") - stream - list)) + stream + list)) (defun pprint-progn (stream list &rest noise) (declare (ignore noise)) @@ -1128,22 +1128,22 @@ (defun pprint-progv (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>") - stream list)) + stream list)) (defun pprint-quote (stream list &rest noise) (declare (ignore noise)) (if (and (consp list) - (consp (cdr list)) - (null (cddr list))) + (consp (cdr list)) + (null (cddr list))) (case (car list) - (function - (write-string "#'" stream) - (output-object (cadr list) stream)) - (quote - (write-char #\' stream) - (output-object (cadr list) stream)) - (t - (pprint-fill stream list))) + (function + (write-string "#'" stream) + (output-object (cadr list) stream)) + (quote + (write-char #\' stream) + (output-object (cadr list) stream)) + (t + (pprint-fill stream list))) (pprint-fill stream list))) (defun pprint-setq (stream list &rest noise) @@ -1155,24 +1155,24 @@ (write-char #\space stream) (pprint-newline :miser stream) (if (and (consp (cdr list)) (consp (cddr list))) - (loop - (pprint-indent :current 2 stream) - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream) - (pprint-indent :current -2 stream) - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream)) - (progn - (pprint-indent :current 0 stream) - (output-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream) - (output-object (pprint-pop) stream))))) + (loop + (pprint-indent :current 2 stream) + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + (pprint-newline :linear stream) + (pprint-indent :current -2 stream) + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + (pprint-newline :linear stream)) + (progn + (pprint-indent :current 0 stream) + (output-object (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream) + (pprint-newline :linear stream) + (output-object (pprint-pop) stream))))) ;;; FIXME: could become SB!XC:DEFMACRO wrapped in EVAL-WHEN (COMPILE EVAL) (defmacro pprint-tagbody-guts (stream) @@ -1181,8 +1181,8 @@ (write-char #\space ,stream) (let ((form-or-tag (pprint-pop))) (pprint-indent :block - (if (atom form-or-tag) 0 1) - ,stream) + (if (atom form-or-tag) 0 1) + ,stream) (pprint-newline :linear ,stream) (output-object form-or-tag ,stream)))) @@ -1196,22 +1196,22 @@ (defun pprint-case (stream list &rest noise) (declare (ignore noise)) (funcall (formatter - "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/SB!PRETTY:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>") - stream - list)) + "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/SB!PRETTY:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>") + stream + list)) (defun pprint-defun (stream list &rest noise) (declare (ignore noise)) (funcall (formatter - "~:<~^~W~^ ~@_~:I~W~^ ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>") - stream - list)) + "~:<~^~W~^ ~@_~:I~W~^ ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>") + stream + list)) (defun pprint-destructuring-bind (stream list &rest noise) (declare (ignore noise)) (funcall (formatter - "~:<~^~W~^~3I ~_~:/SB!PRETTY:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>") - stream list)) + "~:<~^~W~^~3I ~_~:/SB!PRETTY:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>") + stream list)) (defun pprint-do (stream list &rest noise) (declare (ignore noise)) @@ -1222,8 +1222,8 @@ (write-char #\space stream) (pprint-indent :current 0 stream) (funcall (formatter "~:<~@{~:<~^~W~^ ~@_~:I~W~@{ ~_~W~}~:>~^~:@_~}~:>") - stream - (pprint-pop)) + stream + (pprint-pop)) (pprint-exit-if-list-exhausted) (write-char #\space stream) (pprint-newline :linear stream) @@ -1240,16 +1240,16 @@ (write-char #\space stream) (pprint-newline :fill stream) (funcall (formatter "~:<~^~W~^ ~:_~:I~W~@{ ~_~W~}~:>") - stream - (pprint-pop)) + stream + (pprint-pop)) (pprint-tagbody-guts stream))) (defun pprint-typecase (stream list &rest noise) (declare (ignore noise)) (funcall (formatter - "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~W~^~@{ ~_~W~}~:>~}~:>") - stream - list)) + "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~W~^~@{ ~_~W~}~:>~}~:>") + stream + list)) (defun pprint-prog (stream list &rest noise) (declare (ignore noise)) @@ -1265,8 +1265,8 @@ (defun pprint-fun-call (stream list &rest noise) (declare (ignore noise)) (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>") - stream - list)) + stream + list)) ;;;; the interface seen by regular (ugly) printer and initialization routines @@ -1280,99 +1280,99 @@ (/show0 "entering !PPRINT-COLD-INIT") (setf *initial-pprint-dispatch* (make-pprint-dispatch-table)) (let ((*print-pprint-dispatch* *initial-pprint-dispatch*) - (*building-initial-table* t)) + (*building-initial-table* t)) ;; printers for regular types (/show0 "doing SET-PPRINT-DISPATCH for regular types") (set-pprint-dispatch 'array #'pprint-array) (set-pprint-dispatch '(cons symbol) - #'pprint-fun-call -1) + #'pprint-fun-call -1) (set-pprint-dispatch 'cons #'pprint-fill -2) ;; cons cells with interesting things for the car (/show0 "doing SET-PPRINT-DISPATCH for CONS with interesting CAR") (dolist (magic-form '((lambda pprint-lambda) - ;; special forms - (block pprint-block) - (catch pprint-block) - (eval-when pprint-block) - (flet pprint-flet) - (function pprint-quote) - (labels pprint-flet) - (let pprint-let) - (let* pprint-let) - (locally pprint-progn) - (macrolet pprint-flet) - (multiple-value-call pprint-block) - (multiple-value-prog1 pprint-block) - (progn pprint-progn) - (progv pprint-progv) - (quote pprint-quote) - (return-from pprint-block) - (setq pprint-setq) - (symbol-macrolet pprint-let) - (tagbody pprint-tagbody) - (throw pprint-block) - (unwind-protect pprint-block) - - ;; macros - (case pprint-case) - (ccase pprint-case) - (ctypecase pprint-typecase) - (defconstant pprint-block) - (define-modify-macro pprint-defun) - (define-setf-expander pprint-defun) - (defmacro pprint-defun) - (defparameter pprint-block) - (defsetf pprint-defun) - (defstruct pprint-block) - (deftype pprint-defun) - (defun pprint-defun) - (defvar pprint-block) - (destructuring-bind pprint-destructuring-bind) - (do pprint-do) - (do* pprint-do) - (do-all-symbols pprint-dolist) - (do-external-symbols pprint-dolist) - (do-symbols pprint-dolist) - (dolist pprint-dolist) - (dotimes pprint-dolist) - (ecase pprint-case) - (etypecase pprint-typecase) - #+nil (handler-bind ...) - #+nil (handler-case ...) - #+nil (loop ...) - (multiple-value-bind pprint-progv) - (multiple-value-setq pprint-block) - (pprint-logical-block pprint-block) - (print-unreadable-object pprint-block) - (prog pprint-prog) - (prog* pprint-prog) - (prog1 pprint-block) - (prog2 pprint-progv) - (psetf pprint-setq) - (psetq pprint-setq) - #+nil (restart-bind ...) - #+nil (restart-case ...) - (setf pprint-setq) - (step pprint-progn) - (time pprint-progn) - (typecase pprint-typecase) - (unless pprint-block) - (when pprint-block) - (with-compilation-unit pprint-block) - #+nil (with-condition-restarts ...) - (with-hash-table-iterator pprint-block) - (with-input-from-string pprint-block) - (with-open-file pprint-block) - (with-open-stream pprint-block) - (with-output-to-string pprint-block) - (with-package-iterator pprint-block) - (with-simple-restart pprint-block) - (with-standard-io-syntax pprint-progn))) + ;; special forms + (block pprint-block) + (catch pprint-block) + (eval-when pprint-block) + (flet pprint-flet) + (function pprint-quote) + (labels pprint-flet) + (let pprint-let) + (let* pprint-let) + (locally pprint-progn) + (macrolet pprint-flet) + (multiple-value-call pprint-block) + (multiple-value-prog1 pprint-block) + (progn pprint-progn) + (progv pprint-progv) + (quote pprint-quote) + (return-from pprint-block) + (setq pprint-setq) + (symbol-macrolet pprint-let) + (tagbody pprint-tagbody) + (throw pprint-block) + (unwind-protect pprint-block) + + ;; macros + (case pprint-case) + (ccase pprint-case) + (ctypecase pprint-typecase) + (defconstant pprint-block) + (define-modify-macro pprint-defun) + (define-setf-expander pprint-defun) + (defmacro pprint-defun) + (defparameter pprint-block) + (defsetf pprint-defun) + (defstruct pprint-block) + (deftype pprint-defun) + (defun pprint-defun) + (defvar pprint-block) + (destructuring-bind pprint-destructuring-bind) + (do pprint-do) + (do* pprint-do) + (do-all-symbols pprint-dolist) + (do-external-symbols pprint-dolist) + (do-symbols pprint-dolist) + (dolist pprint-dolist) + (dotimes pprint-dolist) + (ecase pprint-case) + (etypecase pprint-typecase) + #+nil (handler-bind ...) + #+nil (handler-case ...) + #+nil (loop ...) + (multiple-value-bind pprint-progv) + (multiple-value-setq pprint-block) + (pprint-logical-block pprint-block) + (print-unreadable-object pprint-block) + (prog pprint-prog) + (prog* pprint-prog) + (prog1 pprint-block) + (prog2 pprint-progv) + (psetf pprint-setq) + (psetq pprint-setq) + #+nil (restart-bind ...) + #+nil (restart-case ...) + (setf pprint-setq) + (step pprint-progn) + (time pprint-progn) + (typecase pprint-typecase) + (unless pprint-block) + (when pprint-block) + (with-compilation-unit pprint-block) + #+nil (with-condition-restarts ...) + (with-hash-table-iterator pprint-block) + (with-input-from-string pprint-block) + (with-open-file pprint-block) + (with-open-stream pprint-block) + (with-output-to-string pprint-block) + (with-package-iterator pprint-block) + (with-simple-restart pprint-block) + (with-standard-io-syntax pprint-progn))) (set-pprint-dispatch `(cons (eql ,(first magic-form))) - (symbol-function (second magic-form)))) + (symbol-function (second magic-form)))) ;; other pretty-print init forms (/show0 "about to call !BACKQ-PP-COLD-INIT") diff --git a/src/code/pred.lisp b/src/code/pred.lisp index ada4bed..d7f5bfa 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -21,7 +21,7 @@ (defun vector-t-p (x) (or (simple-vector-p x) (and (complex-vector-p x) - (simple-vector-p (%array-data-vector x))))) + (simple-vector-p (%array-data-vector x))))) ;;;; primitive predicates. These must be supported directly by the ;;;; compiler. @@ -33,16 +33,16 @@ ;;; All the primitive type predicate wrappers share a parallel form.. (macrolet ((def-type-predicate-wrapper (pred) - (let* ((name (symbol-name pred)) - (stem (string-left-trim "%" (string-right-trim "P-" name))) - (article (if (position (schar name 0) "AEIOU") "an" "a"))) - `(defun ,pred (object) - ,(format nil - "Return true if OBJECT is ~A ~A, and NIL otherwise." - article - stem) - ;; (falling through to low-level implementation) - (,pred object))))) + (let* ((name (symbol-name pred)) + (stem (string-left-trim "%" (string-right-trim "P-" name))) + (article (if (position (schar name 0) "AEIOU") "an" "a"))) + `(defun ,pred (object) + ,(format nil + "Return true if OBJECT is ~A ~A, and NIL otherwise." + article + stem) + ;; (falling through to low-level implementation) + (,pred object))))) (def-type-predicate-wrapper array-header-p) (def-type-predicate-wrapper arrayp) (def-type-predicate-wrapper atom) @@ -128,8 +128,8 @@ (t '(integer 0 #.sb!xc:most-positive-fixnum)))) (integer (if (>= object 0) - '(integer #.(1+ sb!xc:most-positive-fixnum)) - 'bignum)) + '(integer #.(1+ sb!xc:most-positive-fixnum)) + 'bignum)) (standard-char 'standard-char) (base-char 'base-char) (extended-char 'extended-char) @@ -138,19 +138,19 @@ ((or array complex) (type-specifier (ctype-of object))) (t (let* ((classoid (layout-classoid (layout-of object))) - (name (classoid-name classoid))) + (name (classoid-name classoid))) (if (typep object 'instance) - (case name - (sb!alien-internals:alien-value - `(sb!alien:alien - ,(sb!alien-internals:unparse-alien-type - (sb!alien-internals:alien-value-type object)))) - (t - (let ((pname (classoid-proper-name classoid))) - (if (classoid-p pname) - (classoid-pcl-class pname) - pname)))) - name))))) + (case name + (sb!alien-internals:alien-value + `(sb!alien:alien + ,(sb!alien-internals:unparse-alien-type + (sb!alien-internals:alien-value-type object)))) + (t + (let ((pname (classoid-proper-name classoid))) + (if (classoid-p pname) + (classoid-pcl-class pname) + pname)))) + name))))) ;;;; equality predicates @@ -163,15 +163,15 @@ (defun bit-vector-= (x y) (declare (type bit-vector x y)) (if (and (simple-bit-vector-p x) - (simple-bit-vector-p y)) + (simple-bit-vector-p y)) (bit-vector-= x y) ; DEFTRANSFORM (and (= (length x) (length y)) - (do ((i 0 (1+ i)) - (length (length x))) - ((= i length) t) - (declare (fixnum i)) - (unless (= (bit x i) (bit y i)) - (return nil)))))) + (do ((i 0 (1+ i)) + (length (length x))) + ((= i length) t) + (declare (fixnum i)) + (unless (= (bit x i) (bit y i)) + (return nil)))))) (defun equal (x y) #!+sb-doc @@ -180,34 +180,34 @@ are the same length and have identical components. Other arrays must be EQ to be EQUAL." (cond ((eql x y) t) - ((consp x) - (and (consp y) - (equal (car x) (car y)) - (equal (cdr x) (cdr y)))) - ((stringp x) - (and (stringp y) (string= x y))) - ((pathnamep x) - (and (pathnamep y) (pathname= x y))) - ((bit-vector-p x) - (and (bit-vector-p y) - (bit-vector-= x y))) - (t nil))) + ((consp x) + (and (consp y) + (equal (car x) (car y)) + (equal (cdr x) (cdr y)))) + ((stringp x) + (and (stringp y) (string= x y))) + ((pathnamep x) + (and (pathnamep y) (pathname= x y))) + ((bit-vector-p x) + (and (bit-vector-p y) + (bit-vector-= x y))) + (t nil))) ;;; EQUALP comparison of HASH-TABLE values (defun hash-table-equalp (x y) (declare (type hash-table x y)) (or (eq x y) (and (hash-table-p y) - (eql (hash-table-count x) (hash-table-count y)) - (eql (hash-table-test x) (hash-table-test y)) - (block comparison-of-entries - (maphash (lambda (key x-value) - (multiple-value-bind (y-value y-value-p) - (gethash key y) - (unless (and y-value-p (equalp x-value y-value)) - (return-from comparison-of-entries nil)))) - x) - t)))) + (eql (hash-table-count x) (hash-table-count y)) + (eql (hash-table-test x) (hash-table-test y)) + (block comparison-of-entries + (maphash (lambda (key x-value) + (multiple-value-bind (y-value y-value-p) + (gethash key y) + (unless (and y-value-p (equalp x-value y-value)) + (return-from comparison-of-entries nil)))) + x) + t)))) (defun equalp (x y) #+nil ; KLUDGE: If doc string, should be accurate: Talk about structures @@ -218,73 +218,73 @@ arrays must have identical dimensions and EQUALP elements, but may differ in their type restriction." (cond ((eq x y) t) - ((characterp x) (and (characterp y) (char-equal x y))) - ((numberp x) (and (numberp y) (= x y))) - ((consp x) - (and (consp y) - (equalp (car x) (car y)) - (equalp (cdr x) (cdr y)))) - ((pathnamep x) - (and (pathnamep y) (pathname= x y))) - ((hash-table-p x) - (and (hash-table-p y) - (hash-table-equalp x y))) - ((typep x 'instance) - (let* ((layout-x (%instance-layout x)) - (len (layout-length layout-x))) - (and (typep y 'instance) - (eq layout-x (%instance-layout y)) - (structure-classoid-p (layout-classoid layout-x)) - (do ((i 1 (1+ i))) - ((= i len) t) - (declare (fixnum i)) - (let ((x-el (%instance-ref x i)) - (y-el (%instance-ref y i))) - (unless (or (eq x-el y-el) - (equalp x-el y-el)) - (return nil))))))) - ((vectorp x) - (let ((length (length x))) - (and (vectorp y) - (= length (length y)) - (dotimes (i length t) - (let ((x-el (aref x i)) - (y-el (aref y i))) - (unless (or (eq x-el y-el) - (equalp x-el y-el)) - (return nil))))))) - ((arrayp x) - (and (arrayp y) - (= (array-rank x) (array-rank y)) - (dotimes (axis (array-rank x) t) - (unless (= (array-dimension x axis) - (array-dimension y axis)) - (return nil))) - (dotimes (index (array-total-size x) t) - (let ((x-el (row-major-aref x index)) - (y-el (row-major-aref y index))) - (unless (or (eq x-el y-el) - (equalp x-el y-el)) - (return nil)))))) - (t nil))) + ((characterp x) (and (characterp y) (char-equal x y))) + ((numberp x) (and (numberp y) (= x y))) + ((consp x) + (and (consp y) + (equalp (car x) (car y)) + (equalp (cdr x) (cdr y)))) + ((pathnamep x) + (and (pathnamep y) (pathname= x y))) + ((hash-table-p x) + (and (hash-table-p y) + (hash-table-equalp x y))) + ((typep x 'instance) + (let* ((layout-x (%instance-layout x)) + (len (layout-length layout-x))) + (and (typep y 'instance) + (eq layout-x (%instance-layout y)) + (structure-classoid-p (layout-classoid layout-x)) + (do ((i 1 (1+ i))) + ((= i len) t) + (declare (fixnum i)) + (let ((x-el (%instance-ref x i)) + (y-el (%instance-ref y i))) + (unless (or (eq x-el y-el) + (equalp x-el y-el)) + (return nil))))))) + ((vectorp x) + (let ((length (length x))) + (and (vectorp y) + (= length (length y)) + (dotimes (i length t) + (let ((x-el (aref x i)) + (y-el (aref y i))) + (unless (or (eq x-el y-el) + (equalp x-el y-el)) + (return nil))))))) + ((arrayp x) + (and (arrayp y) + (= (array-rank x) (array-rank y)) + (dotimes (axis (array-rank x) t) + (unless (= (array-dimension x axis) + (array-dimension y axis)) + (return nil))) + (dotimes (index (array-total-size x) t) + (let ((x-el (row-major-aref x index)) + (y-el (row-major-aref y index))) + (unless (or (eq x-el y-el) + (equalp x-el y-el)) + (return nil)))))) + (t nil))) (/show0 "about to do test cases in pred.lisp") #!+sb-test (let ((test-cases `((0.0 ,(load-time-value (make-unportable-float :single-float-negative-zero)) t) - (0.0 1.0 nil) - (#c(1 0) #c(1.0 0) t) - (#c(1.1 0) #c(11/10 0) nil) ; due to roundoff error - ("Hello" "hello" t) - ("Hello" #(#\h #\E #\l #\l #\o) t) - ("Hello" "goodbye" nil)))) + (0.0 1.0 nil) + (#c(1 0) #c(1.0 0) t) + (#c(1.1 0) #c(11/10 0) nil) ; due to roundoff error + ("Hello" "hello" t) + ("Hello" #(#\h #\E #\l #\l #\o) t) + ("Hello" "goodbye" nil)))) (/show0 "TEST-CASES bound in pred.lisp") (dolist (test-case test-cases) (/show0 "about to do a TEST-CASE in pred.lisp") (destructuring-bind (x y expected-result) test-case (let* ((result (equalp x y)) - (bresult (if result 1 0)) - (expected-bresult (if expected-result 1 0))) - (unless (= bresult expected-bresult) - (/show0 "failing test in pred.lisp") - (error "failed test (EQUALP ~S ~S)" x y)))))) + (bresult (if result 1 0)) + (expected-bresult (if expected-result 1 0))) + (unless (= bresult expected-bresult) + (/show0 "failing test in pred.lisp") + (error "failed test (EQUALP ~S ~S)" x y)))))) (/show0 "done with test cases in pred.lisp") diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index d09a8b2..f9293be 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -20,9 +20,9 @@ ;;; ;;; CMU CL 18b used :EMPTY for this purpose, which was somewhat nasty ;;; since it's easily accessible to the user, so that e.g. -;;; (DEFVAR *HT* (MAKE-HASH-TABLE)) -;;; (SETF (GETHASH :EMPTY *HT*) :EMPTY) -;;; (MAPHASH (LAMBDA (K V) (FORMAT T "~&~S ~S~%" K V))) +;;; (DEFVAR *HT* (MAKE-HASH-TABLE)) +;;; (SETF (GETHASH :EMPTY *HT*) :EMPTY) +;;; (MAPHASH (LAMBDA (K V) (FORMAT T "~&~S ~S~%" K V))) ;;; gives no output -- oops! ;;; ;;; FIXME: It'd probably be good to use the unbound marker for this. @@ -49,7 +49,7 @@ ;;; work when compiled into a file and loaded back into SBCL. ;;; (Thus, just uninterning %EMPTY-HT-SLOT% doesn't work.) ;;; * The replacement value needs to be acceptable to the -;;; low-level gencgc.lisp hash table scavenging code. +;;; low-level gencgc.lisp hash table scavenging code. ;;; * The change will break binary compatibility, since comparisons ;;; against the value used at the time of compilation are wired ;;; into FASL files. @@ -60,50 +60,50 @@ (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun frob-do-body (varlist endlist decls-and-code bind step name block) (let* ((r-inits nil) ; accumulator for reversed list - (r-steps nil) ; accumulator for reversed list - (label-1 (gensym)) - (label-2 (gensym))) + (r-steps nil) ; accumulator for reversed list + (label-1 (gensym)) + (label-2 (gensym))) ;; Check for illegal old-style DO. (when (or (not (listp varlist)) (atom endlist)) - (error "ill-formed ~S -- possibly illegal old style DO?" name)) + (error "ill-formed ~S -- possibly illegal old style DO?" name)) ;; Parse VARLIST to get R-INITS and R-STEPS. (dolist (v varlist) - (flet (;; (We avoid using CL:PUSH here so that CL:PUSH can be - ;; defined in terms of CL:SETF, and CL:SETF can be - ;; defined in terms of CL:DO, and CL:DO can be defined - ;; in terms of the current function.) - (push-on-r-inits (x) - (setq r-inits (cons x r-inits))) - ;; common error-handling - (illegal-varlist () - (error "~S is an illegal form for a ~S varlist." v name))) - (cond ((symbolp v) (push-on-r-inits v)) - ((listp v) - (unless (symbolp (first v)) - (error "~S step variable is not a symbol: ~S" - name - (first v))) - (let ((lv (length v))) - ;; (We avoid using CL:CASE here so that CL:CASE can - ;; be defined in terms of CL:SETF, and CL:SETF can - ;; be defined in terms of CL:DO, and CL:DO can be - ;; defined in terms of the current function.) - (cond ((= lv 1) - (push-on-r-inits (first v))) - ((= lv 2) - (push-on-r-inits v)) - ((= lv 3) - (push-on-r-inits (list (first v) (second v))) - (setq r-steps (list* (third v) (first v) r-steps))) - (t (illegal-varlist))))) - (t (illegal-varlist))))) + (flet (;; (We avoid using CL:PUSH here so that CL:PUSH can be + ;; defined in terms of CL:SETF, and CL:SETF can be + ;; defined in terms of CL:DO, and CL:DO can be defined + ;; in terms of the current function.) + (push-on-r-inits (x) + (setq r-inits (cons x r-inits))) + ;; common error-handling + (illegal-varlist () + (error "~S is an illegal form for a ~S varlist." v name))) + (cond ((symbolp v) (push-on-r-inits v)) + ((listp v) + (unless (symbolp (first v)) + (error "~S step variable is not a symbol: ~S" + name + (first v))) + (let ((lv (length v))) + ;; (We avoid using CL:CASE here so that CL:CASE can + ;; be defined in terms of CL:SETF, and CL:SETF can + ;; be defined in terms of CL:DO, and CL:DO can be + ;; defined in terms of the current function.) + (cond ((= lv 1) + (push-on-r-inits (first v))) + ((= lv 2) + (push-on-r-inits v)) + ((= lv 3) + (push-on-r-inits (list (first v) (second v))) + (setq r-steps (list* (third v) (first v) r-steps))) + (t (illegal-varlist))))) + (t (illegal-varlist))))) ;; Construct the new form. (multiple-value-bind (code decls) - (parse-body decls-and-code :doc-string-allowed nil) - `(block ,block - (,bind ,(nreverse r-inits) - ,@decls - (tagbody + (parse-body decls-and-code :doc-string-allowed nil) + `(block ,block + (,bind ,(nreverse r-inits) + ,@decls + (tagbody (go ,label-2) ,label-1 (tagbody ,@code) @@ -135,12 +135,12 @@ ;;; _On Lisp_ calls WITH-GENSYMS. (defmacro with-unique-names (symbols &body body) `(let ,(mapcar (lambda (symbol) - (let* ((symbol-name (symbol-name symbol)) - (stem (if (every #'alpha-char-p symbol-name) - symbol-name - (concatenate 'string symbol-name "-")))) - `(,symbol (gensym ,stem)))) - symbols) + (let* ((symbol-name (symbol-name symbol)) + (stem (if (every #'alpha-char-p symbol-name) + symbol-name + (concatenate 'string symbol-name "-")))) + `(,symbol (gensym ,stem)))) + symbols) ,@body)) ;;; Return a list of N gensyms. (This is a common suboperation in @@ -191,30 +191,30 @@ (defun sane-package () (let ((maybe-package *package*)) (cond ((and (packagep maybe-package) - ;; For good measure, we also catch the problem of - ;; *PACKAGE* being bound to a deleted package. - ;; Technically, this is not undefined behavior in itself, - ;; but it will immediately lead to undefined to behavior, - ;; since almost any operation on a deleted package is - ;; undefined. - (package-name maybe-package)) - maybe-package) - (t - ;; We're in the undefined behavior zone. First, munge the - ;; system back into a defined state. - (let ((really-package (find-package :cl-user))) - (setf *package* really-package) - ;; Then complain. - (error 'simple-type-error - :datum maybe-package - :expected-type '(and package (satisfies package-name)) - :format-control - "~@<~S can't be a ~A: ~2I~_~S has been reset to ~S.~:>" - :format-arguments (list '*package* - (if (packagep maybe-package) - "deleted package" - (type-of maybe-package)) - '*package* really-package))))))) + ;; For good measure, we also catch the problem of + ;; *PACKAGE* being bound to a deleted package. + ;; Technically, this is not undefined behavior in itself, + ;; but it will immediately lead to undefined to behavior, + ;; since almost any operation on a deleted package is + ;; undefined. + (package-name maybe-package)) + maybe-package) + (t + ;; We're in the undefined behavior zone. First, munge the + ;; system back into a defined state. + (let ((really-package (find-package :cl-user))) + (setf *package* really-package) + ;; Then complain. + (error 'simple-type-error + :datum maybe-package + :expected-type '(and package (satisfies package-name)) + :format-control + "~@<~S can't be a ~A: ~2I~_~S has been reset to ~S.~:>" + :format-arguments (list '*package* + (if (packagep maybe-package) + "deleted package" + (type-of maybe-package)) + '*package* really-package))))))) ;;; Access *DEFAULT-PATHNAME-DEFAULTS*, issuing a warning if its value ;;; is silly. (Unlike the vaguely-analogous SANE-PACKAGE, we don't @@ -223,13 +223,13 @@ ;;; in a state where it's hard to recover interactively.) (defun sane-default-pathname-defaults () (let* ((dfd *default-pathname-defaults*) - (dfd-dir (pathname-directory dfd))) + (dfd-dir (pathname-directory dfd))) ;; It's generally not good to use a relative pathname for ;; *DEFAULT-PATHNAME-DEFAULTS*, since relative pathnames ;; are defined by merging into a default pathname (which is, ;; by default, *DEFAULT-PATHNAME-DEFAULTS*). (when (and (consp dfd-dir) - (eql (first dfd-dir) :relative)) + (eql (first dfd-dir) :relative)) (warn "~@<~S is a relative pathname. (But we'll try using it anyway.)~@:>" '*default-pathname-defaults*)) @@ -237,21 +237,21 @@ ;;; Give names to elements of a numeric sequence. (defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1)) - &rest identifiers) + &rest identifiers) (let ((results nil) - (index 0) - (start (eval start)) - (step (eval step))) + (index 0) + (start (eval start)) + (step (eval step))) (dolist (id identifiers) (when id - (multiple-value-bind (root docs) - (if (consp id) - (values (car id) (cdr id)) - (values id nil)) - (push `(def!constant ,(symbolicate prefix root suffix) - ,(+ start (* step index)) - ,@docs) - results))) + (multiple-value-bind (root docs) + (if (consp id) + (values (car id) (cdr id)) + (values id nil)) + (push `(def!constant ,(symbolicate prefix root suffix) + ,(+ start (* step index)) + ,@docs) + results))) (incf index)) `(progn ,@(nreverse results)))) @@ -284,19 +284,19 @@ (defun %defconstant-eqx-value (symbol expr eqx) (declare (type function eqx)) (flet ((bummer (explanation) - (error "~@" - symbol - expr - explanation - (symbol-value symbol)))) + (error "~@" + symbol + expr + explanation + (symbol-value symbol)))) (cond ((not (boundp symbol)) - expr) - ((not (constantp symbol)) - (bummer "already bound as a non-constant")) - ((not (funcall eqx (symbol-value symbol) expr)) - (bummer "already bound as a different constant value")) - (t - (symbol-value symbol))))) + expr) + ((not (constantp symbol)) + (bummer "already bound as a non-constant")) + ((not (funcall eqx (symbol-value symbol) expr)) + (bummer "already bound as a different constant value")) + (t + (symbol-value symbol))))) ;;; a helper function for various macros which expect clauses of a ;;; given length, etc. @@ -309,21 +309,21 @@ ;; job is to deal with screwed-up input, it'd be good style to fix ;; it so that it can deal with circular list structure. (cond ((minusp max) nil) - ((null x) (zerop min)) - ((consp x) - (and (plusp max) - (proper-list-of-length-p (cdr x) - (if (plusp (1- min)) - (1- min) - 0) - (1- max)))) - (t nil))) + ((null x) (zerop min)) + ((consp x) + (and (plusp max) + (proper-list-of-length-p (cdr x) + (if (plusp (1- min)) + (1- min) + 0) + (1- max)))) + (t nil))) -;;; Helpers for defining error-signalling NOP's for "not supported +;;; Helpers for defining error-signalling NOP's for "not supported ;;; here" operations. -(defmacro define-unsupported-fun (name &optional +(defmacro define-unsupported-fun (name &optional (doc "Unsupported on this platform.") - (control + (control "~S is unsupported on this platform ~ (OS, CPU, whatever)." controlp) @@ -331,6 +331,6 @@ `(defun ,name (&rest args) ,doc (declare (ignore args)) - (error 'unsupported-operator + (error 'unsupported-operator :format-control ,control :format-arguments (if ,controlp ',arguments (list ',name))))) diff --git a/src/code/print.lisp b/src/code/print.lisp index 018cf57..9da5da1 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -100,55 +100,55 @@ (defun %with-standard-io-syntax (function) (declare (type function function)) (let ((*package* (find-package "COMMON-LISP-USER")) - (*print-array* t) - (*print-base* 10) - (*print-case* :upcase) - (*print-circle* nil) - (*print-escape* t) - (*print-gensym* t) - (*print-length* nil) - (*print-level* nil) - (*print-lines* nil) - (*print-miser-width* nil) - (*print-pretty* nil) - (*print-radix* nil) - (*print-readably* t) - (*print-right-margin* nil) - (*read-base* 10) - (*read-default-float-format* 'single-float) - (*read-eval* t) - (*read-suppress* nil) - ;; FIXME: It doesn't seem like a good idea to expose our - ;; disaster-recovery *STANDARD-READTABLE* here. What if some - ;; enterprising user corrupts the disaster-recovery readtable - ;; by doing destructive readtable operations within - ;; WITH-STANDARD-IO-SYNTAX? Perhaps we should do a - ;; COPY-READTABLE? The consing would be unfortunate, though. - (*readtable* *standard-readtable*)) + (*print-array* t) + (*print-base* 10) + (*print-case* :upcase) + (*print-circle* nil) + (*print-escape* t) + (*print-gensym* t) + (*print-length* nil) + (*print-level* nil) + (*print-lines* nil) + (*print-miser-width* nil) + (*print-pretty* nil) + (*print-radix* nil) + (*print-readably* t) + (*print-right-margin* nil) + (*read-base* 10) + (*read-default-float-format* 'single-float) + (*read-eval* t) + (*read-suppress* nil) + ;; FIXME: It doesn't seem like a good idea to expose our + ;; disaster-recovery *STANDARD-READTABLE* here. What if some + ;; enterprising user corrupts the disaster-recovery readtable + ;; by doing destructive readtable operations within + ;; WITH-STANDARD-IO-SYNTAX? Perhaps we should do a + ;; COPY-READTABLE? The consing would be unfortunate, though. + (*readtable* *standard-readtable*)) (funcall function))) ;;;; routines to print objects (defun write (object &key - ((:stream stream) *standard-output*) - ((:escape *print-escape*) *print-escape*) - ((:radix *print-radix*) *print-radix*) - ((:base *print-base*) *print-base*) - ((:circle *print-circle*) *print-circle*) - ((:pretty *print-pretty*) *print-pretty*) - ((:level *print-level*) *print-level*) - ((:length *print-length*) *print-length*) - ((:case *print-case*) *print-case*) - ((:array *print-array*) *print-array*) - ((:gensym *print-gensym*) *print-gensym*) - ((:readably *print-readably*) *print-readably*) - ((:right-margin *print-right-margin*) - *print-right-margin*) - ((:miser-width *print-miser-width*) - *print-miser-width*) - ((:lines *print-lines*) *print-lines*) - ((:pprint-dispatch *print-pprint-dispatch*) - *print-pprint-dispatch*)) + ((:stream stream) *standard-output*) + ((:escape *print-escape*) *print-escape*) + ((:radix *print-radix*) *print-radix*) + ((:base *print-base*) *print-base*) + ((:circle *print-circle*) *print-circle*) + ((:pretty *print-pretty*) *print-pretty*) + ((:level *print-level*) *print-level*) + ((:length *print-length*) *print-length*) + ((:case *print-case*) *print-case*) + ((:array *print-array*) *print-array*) + ((:gensym *print-gensym*) *print-gensym*) + ((:readably *print-readably*) *print-readably*) + ((:right-margin *print-right-margin*) + *print-right-margin*) + ((:miser-width *print-miser-width*) + *print-miser-width*) + ((:lines *print-lines*) *print-lines*) + ((:pprint-dispatch *print-pprint-dispatch*) + *print-pprint-dispatch*)) #!+sb-doc "Output OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*" (output-object object (out-synonym-of stream)) @@ -167,7 +167,7 @@ "Output an aesthetic but not necessarily READable printed representation of OBJECT on the specified STREAM." (let ((*print-escape* nil) - (*print-readably* nil)) + (*print-readably* nil)) (output-object object (out-synonym-of stream))) object) @@ -185,30 +185,30 @@ #!+sb-doc "Prettily output OBJECT preceded by a newline." (let ((*print-pretty* t) - (*print-escape* t) - (stream (out-synonym-of stream))) + (*print-escape* t) + (stream (out-synonym-of stream))) (terpri stream) (output-object object stream)) (values)) (defun write-to-string (object &key - ((:escape *print-escape*) *print-escape*) - ((:radix *print-radix*) *print-radix*) - ((:base *print-base*) *print-base*) - ((:circle *print-circle*) *print-circle*) - ((:pretty *print-pretty*) *print-pretty*) - ((:level *print-level*) *print-level*) - ((:length *print-length*) *print-length*) - ((:case *print-case*) *print-case*) - ((:array *print-array*) *print-array*) - ((:gensym *print-gensym*) *print-gensym*) - ((:readably *print-readably*) *print-readably*) - ((:right-margin *print-right-margin*) *print-right-margin*) - ((:miser-width *print-miser-width*) *print-miser-width*) - ((:lines *print-lines*) *print-lines*) - ((:pprint-dispatch *print-pprint-dispatch*) - *print-pprint-dispatch*)) + ((:escape *print-escape*) *print-escape*) + ((:radix *print-radix*) *print-radix*) + ((:base *print-base*) *print-base*) + ((:circle *print-circle*) *print-circle*) + ((:pretty *print-pretty*) *print-pretty*) + ((:level *print-level*) *print-level*) + ((:length *print-length*) *print-length*) + ((:case *print-case*) *print-case*) + ((:array *print-array*) *print-array*) + ((:gensym *print-gensym*) *print-gensym*) + ((:readably *print-readably*) *print-readably*) + ((:right-margin *print-right-margin*) *print-right-margin*) + ((:miser-width *print-miser-width*) *print-miser-width*) + ((:lines *print-lines*) *print-lines*) + ((:pprint-dispatch *print-pprint-dispatch*) + *print-pprint-dispatch*)) #!+sb-doc "Return the printed representation of OBJECT as a string." (stringify-object object)) @@ -225,7 +225,7 @@ "Return the printed representation of OBJECT as a string with slashification off." (let ((*print-escape* nil) - (*print-readably* nil)) + (*print-readably* nil)) (stringify-object object))) ;;; This produces the printed representation of an object as a string. @@ -244,27 +244,27 @@ (when *print-readably* (error 'print-not-readable :object object)) (flet ((print-description () - (when type - (write (type-of object) :stream stream :circle nil - :level nil :length nil) - (write-char #\space stream)) - (when body - (funcall body)) - (when identity - (when (or body (not type)) - (write-char #\space stream)) - (write-char #\{ stream) - (write (get-lisp-obj-address object) :stream stream - :radix nil :base 16) - (write-char #\} stream)))) + (when type + (write (type-of object) :stream stream :circle nil + :level nil :length nil) + (write-char #\space stream)) + (when body + (funcall body)) + (when identity + (when (or body (not type)) + (write-char #\space stream)) + (write-char #\{ stream) + (write (get-lisp-obj-address object) :stream stream + :radix nil :base 16) + (write-char #\} stream)))) (cond ((print-pretty-on-stream-p stream) - ;; Since we're printing prettily on STREAM, format the - ;; object within a logical block. PPRINT-LOGICAL-BLOCK does - ;; not rebind the stream when it is already a pretty stream, - ;; so output from the body will go to the same stream. - (pprint-logical-block (stream nil :prefix "#<" :suffix ">") - (print-description))) - (t + ;; Since we're printing prettily on STREAM, format the + ;; object within a logical block. PPRINT-LOGICAL-BLOCK does + ;; not rebind the stream when it is already a pretty stream, + ;; so output from the body will go to the same stream. + (pprint-logical-block (stream nil :prefix "#<" :suffix ">") + (print-description))) + (t (write-string "#<" stream) (print-description) (write-char #\> stream)))) @@ -278,41 +278,41 @@ (or (numberp x) (characterp x) (and (symbolp x) - (symbol-package x)))) + (symbol-package x)))) ;;; Output OBJECT to STREAM observing all printer control variables. (defun output-object (object stream) (labels ((print-it (stream) - (if *print-pretty* - (sb!pretty:output-pretty-object object stream) - (output-ugly-object object stream))) - (check-it (stream) - (multiple-value-bind (marker initiate) - (check-for-circularity object t) - (if (eq initiate :initiate) - (let ((*circularity-hash-table* - (make-hash-table :test 'eq))) - (check-it (make-broadcast-stream)) - (let ((*circularity-counter* 0)) - (check-it stream))) - ;; otherwise - (if marker - (when (handle-circularity marker stream) - (print-it stream)) - (print-it stream)))))) + (if *print-pretty* + (sb!pretty:output-pretty-object object stream) + (output-ugly-object object stream))) + (check-it (stream) + (multiple-value-bind (marker initiate) + (check-for-circularity object t) + (if (eq initiate :initiate) + (let ((*circularity-hash-table* + (make-hash-table :test 'eq))) + (check-it (make-broadcast-stream)) + (let ((*circularity-counter* 0)) + (check-it stream))) + ;; otherwise + (if marker + (when (handle-circularity marker stream) + (print-it stream)) + (print-it stream)))))) (cond (;; Maybe we don't need to bother with circularity detection. - (or (not *print-circle*) - (uniquely-identified-by-print-p object)) - (print-it stream)) - (;; If we have already started circularity detection, this - ;; object might be a shared reference. If we have not, then - ;; if it is a compound object it might contain a circular - ;; reference to itself or multiple shared references. - (or *circularity-hash-table* - (compound-object-p object)) - (check-it stream)) - (t - (print-it stream))))) + (or (not *print-circle*) + (uniquely-identified-by-print-p object)) + (print-it stream)) + (;; If we have already started circularity detection, this + ;; object might be a shared reference. If we have not, then + ;; if it is a compound object it might contain a circular + ;; reference to itself or multiple shared references. + (or *circularity-hash-table* + (compound-object-p object)) + (check-it stream)) + (t + (print-it stream))))) ;;; a hack to work around recurring gotchas with printing while ;;; DEFGENERIC PRINT-OBJECT is being built @@ -348,34 +348,34 @@ ;; priority. -- WHN 2001-11-25 (list (if (null object) - (output-symbol object stream) - (output-list object stream))) + (output-symbol object stream) + (output-list object stream))) (instance (cond ((not (and (boundp '*print-object-is-disabled-p*) - *print-object-is-disabled-p*)) - (print-object object stream)) - ((typep object 'structure-object) - (default-structure-print object stream *current-level-in-print*)) - (t - (write-string "#" stream)))) + *print-object-is-disabled-p*)) + (print-object object stream)) + ((typep object 'structure-object) + (default-structure-print object stream *current-level-in-print*)) + (t + (write-string "#" stream)))) (function (unless (and (funcallable-instance-p object) - (printed-as-funcallable-standard-class object stream)) + (printed-as-funcallable-standard-class object stream)) (output-fun object stream))) (symbol (output-symbol object stream)) (number (etypecase object (integer - (output-integer object stream)) + (output-integer object stream)) (float - (output-float object stream)) + (output-float object stream)) (ratio - (output-ratio object stream)) + (output-ratio object stream)) (ratio - (output-ratio object stream)) + (output-ratio object stream)) (complex - (output-complex object stream)))) + (output-complex object stream)))) (character (output-character object stream)) (vector @@ -412,31 +412,31 @@ ;;; buffer stream is also reset. (defun setup-printer-state () (unless (and (eq *print-case* *previous-case*) - (eq (readtable-case *readtable*) *previous-readtable-case*)) + (eq (readtable-case *readtable*) *previous-readtable-case*)) (setq *previous-case* *print-case*) (setq *previous-readtable-case* (readtable-case *readtable*)) (unless (member *print-case* '(:upcase :downcase :capitalize)) (setq *print-case* :upcase) (error "invalid *PRINT-CASE* value: ~S" *previous-case*)) (unless (member *previous-readtable-case* - '(:upcase :downcase :invert :preserve)) + '(:upcase :downcase :invert :preserve)) (setf (readtable-case *readtable*) :upcase) (error "invalid READTABLE-CASE value: ~S" *previous-readtable-case*)) (setq *internal-symbol-output-fun* - (case *previous-readtable-case* - (:upcase - (case *print-case* - (:upcase #'output-preserve-symbol) - (:downcase #'output-lowercase-symbol) - (:capitalize #'output-capitalize-symbol))) - (:downcase - (case *print-case* - (:upcase #'output-uppercase-symbol) - (:downcase #'output-preserve-symbol) - (:capitalize #'output-capitalize-symbol))) - (:preserve #'output-preserve-symbol) - (:invert #'output-invert-symbol))))) + (case *previous-readtable-case* + (:upcase + (case *print-case* + (:upcase #'output-preserve-symbol) + (:downcase #'output-lowercase-symbol) + (:capitalize #'output-capitalize-symbol))) + (:downcase + (case *print-case* + (:upcase #'output-uppercase-symbol) + (:downcase #'output-preserve-symbol) + (:capitalize #'output-capitalize-symbol))) + (:preserve #'output-preserve-symbol) + (:invert #'output-invert-symbol))))) ;;; Output PNAME (a symbol-name or package-name) surrounded with |'s, ;;; and with any embedded |'s or \'s escaped. @@ -445,42 +445,42 @@ (dotimes (index (length pname)) (let ((char (schar pname index))) (when (or (char= char #\\) (char= char #\|)) - (write-char #\\ stream)) + (write-char #\\ stream)) (write-char char stream))) (write-char #\| stream)) (defun output-symbol (object stream) (if (or *print-escape* *print-readably*) (let ((package (symbol-package object)) - (name (symbol-name object))) - (cond - ;; The ANSI spec "22.1.3.3.1 Package Prefixes for Symbols" - ;; requires that keywords be printed with preceding colons - ;; always, regardless of the value of *PACKAGE*. - ((eq package *keyword-package*) - (write-char #\: stream)) - ;; Otherwise, if the symbol's home package is the current - ;; one, then a prefix is never necessary. - ((eq package (sane-package))) - ;; Uninterned symbols print with a leading #:. - ((null package) - (when (or *print-gensym* *print-readably*) - (write-string "#:" stream))) - (t - (multiple-value-bind (symbol accessible) - (find-symbol name (sane-package)) - ;; If we can find the symbol by looking it up, it need not - ;; be qualified. This can happen if the symbol has been - ;; inherited from a package other than its home package. - (unless (and accessible (eq symbol object)) - (output-symbol-name (package-name package) stream) - (multiple-value-bind (symbol externalp) - (find-external-symbol name package) - (declare (ignore symbol)) - (if externalp - (write-char #\: stream) - (write-string "::" stream))))))) - (output-symbol-name name stream)) + (name (symbol-name object))) + (cond + ;; The ANSI spec "22.1.3.3.1 Package Prefixes for Symbols" + ;; requires that keywords be printed with preceding colons + ;; always, regardless of the value of *PACKAGE*. + ((eq package *keyword-package*) + (write-char #\: stream)) + ;; Otherwise, if the symbol's home package is the current + ;; one, then a prefix is never necessary. + ((eq package (sane-package))) + ;; Uninterned symbols print with a leading #:. + ((null package) + (when (or *print-gensym* *print-readably*) + (write-string "#:" stream))) + (t + (multiple-value-bind (symbol accessible) + (find-symbol name (sane-package)) + ;; If we can find the symbol by looking it up, it need not + ;; be qualified. This can happen if the symbol has been + ;; inherited from a package other than its home package. + (unless (and accessible (eq symbol object)) + (output-symbol-name (package-name package) stream) + (multiple-value-bind (symbol externalp) + (find-external-symbol name package) + (declare (ignore symbol)) + (if externalp + (write-char #\: stream) + (write-string "::" stream))))))) + (output-symbol-name name stream)) (output-symbol-name (symbol-name object) stream nil))) ;;; Output the string NAME as if it were a symbol name. In other @@ -491,8 +491,8 @@ (let ((*readtable* (if *print-readably* *standard-readtable* *readtable*))) (setup-printer-state) (if (and maybe-quote (symbol-quotep name)) - (output-quoted-symbol-name name stream) - (funcall *internal-symbol-output-fun* name stream)))) + (output-quoted-symbol-name name stream) + (funcall *internal-symbol-output-fun* name stream)))) ;;;; escaping symbols @@ -506,21 +506,21 @@ ;;; search for any character with a positive test. (defvar *character-attributes* (make-array 160 ; FIXME - :element-type '(unsigned-byte 16) - :initial-element 0)) + :element-type '(unsigned-byte 16) + :initial-element 0)) (declaim (type (simple-array (unsigned-byte 16) (#.160)) ; FIXME - *character-attributes*)) + *character-attributes*)) ;;; constants which are a bit-mask for each interesting character attribute -(defconstant other-attribute (ash 1 0)) ; Anything else legal. -(defconstant number-attribute (ash 1 1)) ; A numeric digit. -(defconstant uppercase-attribute (ash 1 2)) ; An uppercase letter. -(defconstant lowercase-attribute (ash 1 3)) ; A lowercase letter. -(defconstant sign-attribute (ash 1 4)) ; +- -(defconstant extension-attribute (ash 1 5)) ; ^_ -(defconstant dot-attribute (ash 1 6)) ; . -(defconstant slash-attribute (ash 1 7)) ; / -(defconstant funny-attribute (ash 1 8)) ; Anything illegal. +(defconstant other-attribute (ash 1 0)) ; Anything else legal. +(defconstant number-attribute (ash 1 1)) ; A numeric digit. +(defconstant uppercase-attribute (ash 1 2)) ; An uppercase letter. +(defconstant lowercase-attribute (ash 1 3)) ; A lowercase letter. +(defconstant sign-attribute (ash 1 4)) ; +- +(defconstant extension-attribute (ash 1 5)) ; ^_ +(defconstant dot-attribute (ash 1 6)) ; . +(defconstant slash-attribute (ash 1 7)) ; / +(defconstant funny-attribute (ash 1 8)) ; Anything illegal. (eval-when (:compile-toplevel :load-toplevel :execute) @@ -536,12 +536,12 @@ ) ; EVAL-WHEN (flet ((set-bit (char bit) - (let ((code (char-code char))) - (setf (aref *character-attributes* code) - (logior bit (aref *character-attributes* code)))))) + (let ((code (char-code char))) + (setf (aref *character-attributes* code) + (logior bit (aref *character-attributes* code)))))) (dolist (char '(#\! #\@ #\$ #\% #\& #\* #\= #\~ #\[ #\] #\{ #\} - #\? #\< #\>)) + #\? #\< #\>)) (set-bit char other-attribute)) (dotimes (i 10) @@ -570,10 +570,10 @@ ;;; lowest base in which that character is a digit. (defvar *digit-bases* (make-array 128 ; FIXME - :element-type '(unsigned-byte 8) - :initial-element 36)) + :element-type '(unsigned-byte 8) + :initial-element 36)) (declaim (type (simple-array (unsigned-byte 8) (#.128)) ; FIXME - *digit-bases*)) + *digit-bases*)) (dotimes (i 36) (let ((char (digit-char i 36))) (setf (aref *digit-bases* (char-code char)) i))) @@ -583,46 +583,46 @@ (defun symbol-quotep (name) (declare (simple-string name)) (macrolet ((advance (tag &optional (at-end t)) - `(progn - (when (= index len) - ,(if at-end '(go TEST-SIGN) '(return nil))) - (setq current (schar name index) - code (char-code current) - bits (cond ; FIXME + `(progn + (when (= index len) + ,(if at-end '(go TEST-SIGN) '(return nil))) + (setq current (schar name index) + code (char-code current) + bits (cond ; FIXME ((< code 160) (aref attributes code)) ((upper-case-p current) uppercase-attribute) ((lower-case-p current) lowercase-attribute) (t other-attribute))) - (incf index) - (go ,tag))) - (test (&rest attributes) - `(not (zerop - (the fixnum - (logand - (logior ,@(mapcar - (lambda (x) - (or (cdr (assoc x - *attribute-names*)) - (error "Blast!"))) - attributes)) - bits))))) - (digitp () + (incf index) + (go ,tag))) + (test (&rest attributes) + `(not (zerop + (the fixnum + (logand + (logior ,@(mapcar + (lambda (x) + (or (cdr (assoc x + *attribute-names*)) + (error "Blast!"))) + attributes)) + bits))))) + (digitp () `(and (< code 128) ; FIXME (< (the fixnum (aref bases code)) base)))) (prog ((len (length name)) - (attributes *character-attributes*) - (bases *digit-bases*) - (base *print-base*) - (letter-attribute - (case (readtable-case *readtable*) - (:upcase uppercase-attribute) - (:downcase lowercase-attribute) - (t (logior lowercase-attribute uppercase-attribute)))) - (index 0) - (bits 0) - (code 0) - current) + (attributes *character-attributes*) + (bases *digit-bases*) + (base *print-base*) + (letter-attribute + (case (readtable-case *readtable*) + (:upcase uppercase-attribute) + (:downcase lowercase-attribute) + (t (logior lowercase-attribute uppercase-attribute)))) + (index 0) + (bits 0) + (code 0) + current) (declare (fixnum len base index bits code)) (advance START t) @@ -631,25 +631,25 @@ OTHER ; not potential number, see whether funny chars... (let ((mask (logxor (logior lowercase-attribute uppercase-attribute - funny-attribute) - letter-attribute))) - (do ((i (1- index) (1+ i))) - ((= i len) (return-from symbol-quotep nil)) - (unless (zerop (logand (let* ((char (schar name i)) - (code (char-code char))) - (cond - ((< code 160) (aref attributes code)) - ((upper-case-p char) uppercase-attribute) - ((lower-case-p char) lowercase-attribute) - (t other-attribute))) - mask)) - (return-from symbol-quotep t)))) + funny-attribute) + letter-attribute))) + (do ((i (1- index) (1+ i))) + ((= i len) (return-from symbol-quotep nil)) + (unless (zerop (logand (let* ((char (schar name i)) + (code (char-code char))) + (cond + ((< code 160) (aref attributes code)) + ((upper-case-p char) uppercase-attribute) + ((lower-case-p char) lowercase-attribute) + (t other-attribute))) + mask)) + (return-from symbol-quotep t)))) START (when (digitp) - (if (test letter) - (advance LAST-DIGIT-ALPHA) - (advance DIGIT))) + (if (test letter) + (advance LAST-DIGIT-ALPHA) + (advance DIGIT))) (when (test letter number other slash) (advance OTHER nil)) (when (char= current #\.) (advance DOT-FOUND)) (when (test sign extension) (advance START-STUFF nil)) @@ -665,9 +665,9 @@ START-STUFF ; leading stuff before any dot or digit (when (digitp) - (if (test letter) - (advance LAST-DIGIT-ALPHA) - (advance DIGIT))) + (if (test letter) + (advance LAST-DIGIT-ALPHA) + (advance DIGIT))) (when (test number other) (advance OTHER nil)) (when (test letter) (advance START-MARKER nil)) (when (char= current #\.) (advance START-DOT-STUFF nil)) @@ -703,15 +703,15 @@ LAST-DIGIT-ALPHA ; previous char is a letter digit... (when (or (digitp) (test sign slash)) - (advance ALPHA-DIGIT)) + (advance ALPHA-DIGIT)) (when (test letter number other dot) (advance OTHER nil)) (return t) ALPHA-DIGIT ; seen a digit which is a letter... (when (or (digitp) (test sign slash)) - (if (test letter) - (advance LAST-DIGIT-ALPHA) - (advance ALPHA-DIGIT))) + (if (test letter) + (advance LAST-DIGIT-ALPHA) + (advance ALPHA-DIGIT))) (when (test letter) (advance ALPHA-MARKER)) (when (test number other dot) (advance OTHER nil)) (return t) @@ -722,9 +722,9 @@ DIGIT ; seen only ordinary (non-alphabetic) numeric digits... (when (digitp) - (if (test letter) - (advance ALPHA-DIGIT) - (advance DIGIT))) + (if (test letter) + (advance ALPHA-DIGIT) + (advance DIGIT))) (when (test number other) (advance OTHER nil)) (when (test letter) (advance MARKER)) (when (test extension slash sign) (advance DIGIT)) @@ -745,17 +745,17 @@ ;;;; *PRINT-CASE* and READTABLE-CASE. ;;; called when: -;;; READTABLE-CASE *PRINT-CASE* -;;; :UPCASE :UPCASE -;;; :DOWNCASE :DOWNCASE -;;; :PRESERVE any +;;; READTABLE-CASE *PRINT-CASE* +;;; :UPCASE :UPCASE +;;; :DOWNCASE :DOWNCASE +;;; :PRESERVE any (defun output-preserve-symbol (pname stream) (declare (simple-string pname)) (write-string pname stream)) ;;; called when: -;;; READTABLE-CASE *PRINT-CASE* -;;; :UPCASE :DOWNCASE +;;; READTABLE-CASE *PRINT-CASE* +;;; :UPCASE :DOWNCASE (defun output-lowercase-symbol (pname stream) (declare (simple-string pname)) (dotimes (index (length pname)) @@ -763,8 +763,8 @@ (write-char (char-downcase char) stream)))) ;;; called when: -;;; READTABLE-CASE *PRINT-CASE* -;;; :DOWNCASE :UPCASE +;;; READTABLE-CASE *PRINT-CASE* +;;; :DOWNCASE :UPCASE (defun output-uppercase-symbol (pname stream) (declare (simple-string pname)) (dotimes (index (length pname)) @@ -772,70 +772,70 @@ (write-char (char-upcase char) stream)))) ;;; called when: -;;; READTABLE-CASE *PRINT-CASE* -;;; :UPCASE :CAPITALIZE -;;; :DOWNCASE :CAPITALIZE +;;; READTABLE-CASE *PRINT-CASE* +;;; :UPCASE :CAPITALIZE +;;; :DOWNCASE :CAPITALIZE (defun output-capitalize-symbol (pname stream) (declare (simple-string pname)) (let ((prev-not-alphanum t) - (up (eq (readtable-case *readtable*) :upcase))) + (up (eq (readtable-case *readtable*) :upcase))) (dotimes (i (length pname)) (let ((char (char pname i))) - (write-char (if up - (if (or prev-not-alphanum (lower-case-p char)) - char - (char-downcase char)) - (if prev-not-alphanum - (char-upcase char) - char)) - stream) - (setq prev-not-alphanum (not (alphanumericp char))))))) + (write-char (if up + (if (or prev-not-alphanum (lower-case-p char)) + char + (char-downcase char)) + (if prev-not-alphanum + (char-upcase char) + char)) + stream) + (setq prev-not-alphanum (not (alphanumericp char))))))) ;;; called when: -;;; READTABLE-CASE *PRINT-CASE* -;;; :INVERT any +;;; READTABLE-CASE *PRINT-CASE* +;;; :INVERT any (defun output-invert-symbol (pname stream) (declare (simple-string pname)) (let ((all-upper t) - (all-lower t)) + (all-lower t)) (dotimes (i (length pname)) (let ((ch (schar pname i))) - (when (both-case-p ch) - (if (upper-case-p ch) - (setq all-lower nil) - (setq all-upper nil))))) + (when (both-case-p ch) + (if (upper-case-p ch) + (setq all-lower nil) + (setq all-upper nil))))) (cond (all-upper (output-lowercase-symbol pname stream)) - (all-lower (output-uppercase-symbol pname stream)) - (t - (write-string pname stream))))) + (all-lower (output-uppercase-symbol pname stream)) + (t + (write-string pname stream))))) #| (defun test1 () (let ((*readtable* (copy-readtable nil))) (format t "READTABLE-CASE Input Symbol-name~@ - ----------------------------------~%") + ----------------------------------~%") (dolist (readtable-case '(:upcase :downcase :preserve :invert)) (setf (readtable-case *readtable*) readtable-case) (dolist (input '("ZEBRA" "Zebra" "zebra")) - (format t "~&:~A~16T~A~24T~A" - (string-upcase readtable-case) - input - (symbol-name (read-from-string input))))))) + (format t "~&:~A~16T~A~24T~A" + (string-upcase readtable-case) + input + (symbol-name (read-from-string input))))))) (defun test2 () (let ((*readtable* (copy-readtable nil))) (format t "READTABLE-CASE *PRINT-CASE* Symbol-name Output Princ~@ - --------------------------------------------------------~%") + --------------------------------------------------------~%") (dolist (readtable-case '(:upcase :downcase :preserve :invert)) (setf (readtable-case *readtable*) readtable-case) (dolist (*print-case* '(:upcase :downcase :capitalize)) - (dolist (symbol '(|ZEBRA| |Zebra| |zebra|)) - (format t "~&:~A~15T:~A~29T~A~42T~A~50T~A" - (string-upcase readtable-case) - (string-upcase *print-case*) - (symbol-name symbol) - (prin1-to-string symbol) - (princ-to-string symbol))))))) + (dolist (symbol '(|ZEBRA| |Zebra| |zebra|)) + (format t "~&:~A~15T:~A~29T~A~42T~A~50T~A" + (string-upcase readtable-case) + (string-upcase *print-case*) + (symbol-name symbol) + (prin1-to-string symbol) + (princ-to-string symbol))))))) |# ;;;; recursive objects @@ -844,80 +844,80 @@ (descend-into (stream) (write-char #\( stream) (let ((length 0) - (list list)) + (list list)) (loop - (punt-print-if-too-long length stream) - (output-object (pop list) stream) - (unless list - (return)) - (when (or (atom list) + (punt-print-if-too-long length stream) + (output-object (pop list) stream) + (unless list + (return)) + (when (or (atom list) (check-for-circularity list)) - (write-string " . " stream) - (output-object list stream) - (return)) - (write-char #\space stream) - (incf length))) + (write-string " . " stream) + (output-object list stream) + (return)) + (write-char #\space stream) + (incf length))) (write-char #\) stream))) (defun output-vector (vector stream) (declare (vector vector)) (cond ((stringp vector) - (cond ((and *print-readably* - (not (eq (array-element-type vector) - (load-time-value - (array-element-type - (make-array 0 :element-type 'character)))))) - (error 'print-not-readable :object vector)) - ((or *print-escape* *print-readably*) - (write-char #\" stream) - (quote-string vector stream) - (write-char #\" stream)) - (t - (write-string vector stream)))) - ((not (or *print-array* *print-readably*)) - (output-terse-array vector stream)) - ((bit-vector-p vector) - (write-string "#*" stream) - (dovector (bit vector) - ;; (Don't use OUTPUT-OBJECT here, since this code - ;; has to work for all possible *PRINT-BASE* values.) - (write-char (if (zerop bit) #\0 #\1) stream))) - (t - (when (and *print-readably* - (not (array-readably-printable-p vector))) - (error 'print-not-readable :object vector)) - (descend-into (stream) - (write-string "#(" stream) - (dotimes (i (length vector)) - (unless (zerop i) - (write-char #\space stream)) - (punt-print-if-too-long i stream) - (output-object (aref vector i) stream)) - (write-string ")" stream))))) + (cond ((and *print-readably* + (not (eq (array-element-type vector) + (load-time-value + (array-element-type + (make-array 0 :element-type 'character)))))) + (error 'print-not-readable :object vector)) + ((or *print-escape* *print-readably*) + (write-char #\" stream) + (quote-string vector stream) + (write-char #\" stream)) + (t + (write-string vector stream)))) + ((not (or *print-array* *print-readably*)) + (output-terse-array vector stream)) + ((bit-vector-p vector) + (write-string "#*" stream) + (dovector (bit vector) + ;; (Don't use OUTPUT-OBJECT here, since this code + ;; has to work for all possible *PRINT-BASE* values.) + (write-char (if (zerop bit) #\0 #\1) stream))) + (t + (when (and *print-readably* + (not (array-readably-printable-p vector))) + (error 'print-not-readable :object vector)) + (descend-into (stream) + (write-string "#(" stream) + (dotimes (i (length vector)) + (unless (zerop i) + (write-char #\space stream)) + (punt-print-if-too-long i stream) + (output-object (aref vector i) stream)) + (write-string ")" stream))))) ;;; This function outputs a string quoting characters sufficiently ;;; so that someone can read it in again. Basically, put a slash in ;;; front of an character satisfying NEEDS-SLASH-P. (defun quote-string (string stream) (macrolet ((needs-slash-p (char) - ;; KLUDGE: We probably should look at the readtable, but just do - ;; this for now. [noted by anonymous long ago] -- WHN 19991130 - `(or (char= ,char #\\) + ;; KLUDGE: We probably should look at the readtable, but just do + ;; this for now. [noted by anonymous long ago] -- WHN 19991130 + `(or (char= ,char #\\) (char= ,char #\")))) (with-array-data ((data string) (start) (end (length string))) (do ((index start (1+ index))) - ((>= index end)) - (let ((char (schar data index))) - (when (needs-slash-p char) (write-char #\\ stream)) - (write-char char stream)))))) + ((>= index end)) + (let ((char (schar data index))) + (when (needs-slash-p char) (write-char #\\ stream)) + (write-char char stream)))))) (defun array-readably-printable-p (array) (and (eq (array-element-type array) t) (let ((zero (position 0 (array-dimensions array))) - (number (position 0 (array-dimensions array) - :test (complement #'eql) - :from-end t))) - (or (null zero) (null number) (> zero number))))) + (number (position 0 (array-dimensions array) + :test (complement #'eql) + :from-end t))) + (or (null zero) (null number) (> zero number))))) ;;; Output the printed representation of any array in either the #< or #A ;;; form. @@ -929,17 +929,17 @@ ;;; Output the abbreviated #< form of an array. (defun output-terse-array (array stream) (let ((*print-level* nil) - (*print-length* nil)) + (*print-length* nil)) (print-unreadable-object (array stream :type t :identity t)))) ;;; Output the readable #A form of an array. (defun output-array-guts (array stream) (when (and *print-readably* - (not (array-readably-printable-p array))) + (not (array-readably-printable-p array))) (error 'print-not-readable :object array)) (write-char #\# stream) (let ((*print-base* 10) - (*print-radix* nil)) + (*print-radix* nil)) (output-integer (array-rank array) stream)) (write-char #\A stream) (with-array-data ((data array) (start) (end)) @@ -949,20 +949,20 @@ (defun sub-output-array-guts (array dimensions stream index) (declare (type (simple-array * (*)) array) (fixnum index)) (cond ((null dimensions) - (output-object (aref array index) stream)) - (t - (descend-into (stream) - (write-char #\( stream) - (let* ((dimension (car dimensions)) - (dimensions (cdr dimensions)) - (count (reduce #'* dimensions))) - (dotimes (i dimension) - (unless (zerop i) - (write-char #\space stream)) - (punt-print-if-too-long i stream) - (sub-output-array-guts array dimensions stream index) - (incf index count))) - (write-char #\) stream))))) + (output-object (aref array index) stream)) + (t + (descend-into (stream) + (write-char #\( stream) + (let* ((dimension (car dimensions)) + (dimensions (cdr dimensions)) + (count (reduce #'* dimensions))) + (dotimes (i dimension) + (unless (zerop i) + (write-char #\space stream)) + (punt-print-if-too-long i stream) + (sub-output-array-guts array dimensions stream index) + (incf index count))) + (write-char #\) stream))))) ;;; a trivial non-generic-function placeholder for PRINT-OBJECT, for ;;; use until CLOS is set up (at which time it will be replaced with @@ -992,8 +992,8 @@ ;; Then as each recursive call unwinds, turn the ;; digit (in remainder) into a character and output ;; the character. - (write-char - (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" r) + (write-char + (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" r) stream))) ;; Algorithm by Harald Hanche-Olsen, sbcl-devel 2005-02-05 @@ -1008,30 +1008,30 @@ ;; IEEE Transactions on Computers, volume 43, number 8, August ;; 1994, pp. 899-908. (do ((p base (* p p))) - ((> p n)) + ((> p n)) (vector-push-extend p power)) ;; (aref power k) == (expt base (expt 2 k)) (labels ((bisect (n k exactp) - (declare (fixnum k)) - ;; N is the number to bisect - ;; K on initial entry BASE^(2^K) > N - ;; EXACTP is true if 2^K is the exact number of digits - (cond ((zerop n) - (when exactp - (loop repeat (ash 1 k) do (write-char #\0 stream)))) - ((zerop k) - (write-char - (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" n) - stream)) - (t - (setf k (1- k)) - (multiple-value-bind (q r) (truncate n (aref power k)) - ;; EXACTP is NIL only at the head of the - ;; initial number, as we don't know the number - ;; of digits there, but we do know that it - ;; doesn't get any leading zeros. - (bisect q k exactp) - (bisect r k (or exactp (plusp q)))))))) + (declare (fixnum k)) + ;; N is the number to bisect + ;; K on initial entry BASE^(2^K) > N + ;; EXACTP is true if 2^K is the exact number of digits + (cond ((zerop n) + (when exactp + (loop repeat (ash 1 k) do (write-char #\0 stream)))) + ((zerop k) + (write-char + (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" n) + stream)) + (t + (setf k (1- k)) + (multiple-value-bind (q r) (truncate n (aref power k)) + ;; EXACTP is NIL only at the head of the + ;; initial number, as we don't know the number + ;; of digits there, but we do know that it + ;; doesn't get any leading zeros. + (bisect q k exactp) + (bisect r k (or exactp (plusp q)))))))) (bisect n (fill-pointer power) nil)))) (defun %output-integer-in-base (integer base stream) @@ -1060,7 +1060,7 @@ (defun output-complex (complex stream) (write-string "#C(" stream) - ;; FIXME: Could this just be OUTPUT-NUMBER? + ;; FIXME: Could this just be OUTPUT-NUMBER? (output-object (realpart complex) stream) (write-char #\space stream) (output-object (imagpart complex) stream) @@ -1074,29 +1074,29 @@ ;;; or fixed format with no exponent. The interpretation of the ;;; arguments is as follows: ;;; -;;; X - The floating point number to convert, which must not be -;;; negative. +;;; X - The floating point number to convert, which must not be +;;; negative. ;;; WIDTH - The preferred field width, used to determine the number -;;; of fraction digits to produce if the FDIGITS parameter -;;; is unspecified or NIL. If the non-fraction digits and the -;;; decimal point alone exceed this width, no fraction digits -;;; will be produced unless a non-NIL value of FDIGITS has been -;;; specified. Field overflow is not considerd an error at this -;;; level. +;;; of fraction digits to produce if the FDIGITS parameter +;;; is unspecified or NIL. If the non-fraction digits and the +;;; decimal point alone exceed this width, no fraction digits +;;; will be produced unless a non-NIL value of FDIGITS has been +;;; specified. Field overflow is not considerd an error at this +;;; level. ;;; FDIGITS - The number of fractional digits to produce. Insignificant -;;; trailing zeroes may be introduced as needed. May be -;;; unspecified or NIL, in which case as many digits as possible -;;; are generated, subject to the constraint that there are no -;;; trailing zeroes. +;;; trailing zeroes may be introduced as needed. May be +;;; unspecified or NIL, in which case as many digits as possible +;;; are generated, subject to the constraint that there are no +;;; trailing zeroes. ;;; SCALE - If this parameter is specified or non-NIL, then the number -;;; printed is (* x (expt 10 scale)). This scaling is exact, -;;; and cannot lose precision. +;;; printed is (* x (expt 10 scale)). This scaling is exact, +;;; and cannot lose precision. ;;; FMIN - This parameter, if specified or non-NIL, is the minimum -;;; number of fraction digits which will be produced, regardless -;;; of the value of WIDTH or FDIGITS. This feature is used by -;;; the ~E format directive to prevent complete loss of -;;; significance in the printed value due to a bogus choice of -;;; scale factor. +;;; number of fraction digits which will be produced, regardless +;;; of the value of WIDTH or FDIGITS. This feature is used by +;;; the ~E format directive to prevent complete loss of +;;; significance in the printed value due to a bogus choice of +;;; scale factor. ;;; ;;; Returns: ;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT) @@ -1105,11 +1105,11 @@ ;;; DIGIT-STRING - The decimal representation of X, with decimal point. ;;; DIGIT-LENGTH - The length of the string DIGIT-STRING. ;;; LEADING-POINT - True if the first character of DIGIT-STRING is the -;;; decimal point. +;;; decimal point. ;;; TRAILING-POINT - True if the last character of DIGIT-STRING is the -;;; decimal point. +;;; decimal point. ;;; POINT-POS - The position of the digit preceding the decimal -;;; point. Zero indicates point before first digit. +;;; point. Zero indicates point before first digit. ;;; ;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee ;;; accuracy. Specifically, the decimal number printed is the closest @@ -1131,51 +1131,51 @@ ;; possibly-negative X. (setf x (abs x)) (cond ((zerop x) - ;; Zero is a special case which FLOAT-STRING cannot handle. - (if fdigits - (let ((s (make-string (1+ fdigits) :initial-element #\0))) - (setf (schar s 0) #\.) - (values s (length s) t (zerop fdigits) 0)) - (values "." 1 t t 0))) - (t - (multiple-value-bind (e string) - (if fdigits - (flonum-to-digits x (min (- fdigits) (- (or fmin 0)))) - (if (and width (> width 1)) - (let ((w (multiple-value-list (flonum-to-digits x (1- width) t))) - (f (multiple-value-list (flonum-to-digits x (- (or fmin 0)))))) - (cond - ((>= (length (cadr w)) (length (cadr f))) - (values-list w)) - (t (values-list f)))) - (flonum-to-digits x))) - (let ((e (+ e (or scale 0))) - (stream (make-string-output-stream))) - (if (plusp e) - (progn - (write-string string stream :end (min (length string) e)) - (dotimes (i (- e (length string))) - (write-char #\0 stream)) - (write-char #\. stream) - (write-string string stream :start (min (length string) e)) - (when fdigits - (dotimes (i (- fdigits - (- (length string) - (min (length string) e)))) - (write-char #\0 stream)))) - (progn - (write-string "." stream) - (dotimes (i (- e)) - (write-char #\0 stream)) - (write-string string stream) - (when fdigits - (dotimes (i (+ fdigits e (- (length string)))) - (write-char #\0 stream))))) - (let ((string (get-output-stream-string stream))) - (values string (length string) - (char= (char string 0) #\.) - (char= (char string (1- (length string))) #\.) - (position #\. string)))))))) + ;; Zero is a special case which FLOAT-STRING cannot handle. + (if fdigits + (let ((s (make-string (1+ fdigits) :initial-element #\0))) + (setf (schar s 0) #\.) + (values s (length s) t (zerop fdigits) 0)) + (values "." 1 t t 0))) + (t + (multiple-value-bind (e string) + (if fdigits + (flonum-to-digits x (min (- fdigits) (- (or fmin 0)))) + (if (and width (> width 1)) + (let ((w (multiple-value-list (flonum-to-digits x (1- width) t))) + (f (multiple-value-list (flonum-to-digits x (- (or fmin 0)))))) + (cond + ((>= (length (cadr w)) (length (cadr f))) + (values-list w)) + (t (values-list f)))) + (flonum-to-digits x))) + (let ((e (+ e (or scale 0))) + (stream (make-string-output-stream))) + (if (plusp e) + (progn + (write-string string stream :end (min (length string) e)) + (dotimes (i (- e (length string))) + (write-char #\0 stream)) + (write-char #\. stream) + (write-string string stream :start (min (length string) e)) + (when fdigits + (dotimes (i (- fdigits + (- (length string) + (min (length string) e)))) + (write-char #\0 stream)))) + (progn + (write-string "." stream) + (dotimes (i (- e)) + (write-char #\0 stream)) + (write-string string stream) + (when fdigits + (dotimes (i (+ fdigits e (- (length string)))) + (write-char #\0 stream))))) + (let ((string (get-output-stream-string stream))) + (values string (length string) + (char= (char string 0) #\.) + (char= (char string (1- (length string))) #\.) + (position #\. string)))))))) ;;; implementation of figure 1 from Burger and Dybvig, 1996. As the ;;; implementation of the Dragon from Classic CMUCL (and previously in @@ -1201,105 +1201,105 @@ (defun flonum-to-digits (v &optional position relativep) (let ((print-base 10) ; B - (float-radix 2) ; b - (float-digits (float-digits v)) ; p + (float-radix 2) ; b + (float-digits (float-digits v)) ; p (digit-characters "0123456789") - (min-e - (etypecase v - (single-float single-float-min-e) - (double-float double-float-min-e) - #!+long-float - (long-float long-float-min-e)))) + (min-e + (etypecase v + (single-float single-float-min-e) + (double-float double-float-min-e) + #!+long-float + (long-float long-float-min-e)))) (multiple-value-bind (f e) - (integer-decode-float v) + (integer-decode-float v) (let (;; FIXME: these even tests assume normal IEEE rounding - ;; mode. I wonder if we should cater for non-normal? - (high-ok (evenp f)) - (low-ok (evenp f)) - (result (make-array 50 :element-type 'base-char - :fill-pointer 0 :adjustable t))) - (labels ((scale (r s m+ m-) - (do ((k 0 (1+ k)) - (s s (* s print-base))) - ((not (or (> (+ r m+) s) - (and high-ok (= (+ r m+) s)))) - (do ((k k (1- k)) - (r r (* r print-base)) - (m+ m+ (* m+ print-base)) - (m- m- (* m- print-base))) - ((not (or (< (* (+ r m+) print-base) s) - (and (not high-ok) + ;; mode. I wonder if we should cater for non-normal? + (high-ok (evenp f)) + (low-ok (evenp f)) + (result (make-array 50 :element-type 'base-char + :fill-pointer 0 :adjustable t))) + (labels ((scale (r s m+ m-) + (do ((k 0 (1+ k)) + (s s (* s print-base))) + ((not (or (> (+ r m+) s) + (and high-ok (= (+ r m+) s)))) + (do ((k k (1- k)) + (r r (* r print-base)) + (m+ m+ (* m+ print-base)) + (m- m- (* m- print-base))) + ((not (or (< (* (+ r m+) print-base) s) + (and (not high-ok) (= (* (+ r m+) print-base) s)))) - (values k (generate r s m+ m-))))))) - (generate (r s m+ m-) - (let (d tc1 tc2) - (tagbody - loop - (setf (values d r) (truncate (* r print-base) s)) - (setf m+ (* m+ print-base)) - (setf m- (* m- print-base)) - (setf tc1 (or (< r m-) (and low-ok (= r m-)))) - (setf tc2 (or (> (+ r m+) s) - (and high-ok (= (+ r m+) s)))) - (when (or tc1 tc2) - (go end)) - (vector-push-extend (char digit-characters d) result) - (go loop) - end - (let ((d (cond - ((and (not tc1) tc2) (1+ d)) - ((and tc1 (not tc2)) d) - (t ; (and tc1 tc2) - (if (< (* r 2) s) d (1+ d)))))) - (vector-push-extend (char digit-characters d) result) - (return-from generate result))))) - (initialize () - (let (r s m+ m-) - (if (>= e 0) - (let* ((be (expt float-radix e)) - (be1 (* be float-radix))) - (if (/= f (expt float-radix (1- float-digits))) - (setf r (* f be 2) - s 2 - m+ be - m- be) - (setf r (* f be1 2) - s (* float-radix 2) - m+ be1 - m- be))) - (if (or (= e min-e) - (/= f (expt float-radix (1- float-digits)))) - (setf r (* f 2) - s (* (expt float-radix (- e)) 2) - m+ 1 - m- 1) - (setf r (* f float-radix 2) - s (* (expt float-radix (- 1 e)) 2) - m+ float-radix - m- 1))) - (when position - (when relativep - (aver (> position 0)) - (do ((k 0 (1+ k)) - ;; running out of letters here - (l 1 (* l print-base))) - ((>= (* s l) (+ r m+)) - ;; k is now \hat{k} - (if (< (+ r (* s (/ (expt print-base (- k position)) 2))) - (* s (expt print-base k))) - (setf position (- k position)) - (setf position (- k position 1)))))) - (let ((low (max m- (/ (* s (expt print-base position)) 2))) - (high (max m+ (/ (* s (expt print-base position)) 2)))) - (when (<= m- low) - (setf m- low) - (setf low-ok t)) - (when (<= m+ high) - (setf m+ high) - (setf high-ok t)))) - (values r s m+ m-)))) - (multiple-value-bind (r s m+ m-) (initialize) - (scale r s m+ m-))))))) + (values k (generate r s m+ m-))))))) + (generate (r s m+ m-) + (let (d tc1 tc2) + (tagbody + loop + (setf (values d r) (truncate (* r print-base) s)) + (setf m+ (* m+ print-base)) + (setf m- (* m- print-base)) + (setf tc1 (or (< r m-) (and low-ok (= r m-)))) + (setf tc2 (or (> (+ r m+) s) + (and high-ok (= (+ r m+) s)))) + (when (or tc1 tc2) + (go end)) + (vector-push-extend (char digit-characters d) result) + (go loop) + end + (let ((d (cond + ((and (not tc1) tc2) (1+ d)) + ((and tc1 (not tc2)) d) + (t ; (and tc1 tc2) + (if (< (* r 2) s) d (1+ d)))))) + (vector-push-extend (char digit-characters d) result) + (return-from generate result))))) + (initialize () + (let (r s m+ m-) + (if (>= e 0) + (let* ((be (expt float-radix e)) + (be1 (* be float-radix))) + (if (/= f (expt float-radix (1- float-digits))) + (setf r (* f be 2) + s 2 + m+ be + m- be) + (setf r (* f be1 2) + s (* float-radix 2) + m+ be1 + m- be))) + (if (or (= e min-e) + (/= f (expt float-radix (1- float-digits)))) + (setf r (* f 2) + s (* (expt float-radix (- e)) 2) + m+ 1 + m- 1) + (setf r (* f float-radix 2) + s (* (expt float-radix (- 1 e)) 2) + m+ float-radix + m- 1))) + (when position + (when relativep + (aver (> position 0)) + (do ((k 0 (1+ k)) + ;; running out of letters here + (l 1 (* l print-base))) + ((>= (* s l) (+ r m+)) + ;; k is now \hat{k} + (if (< (+ r (* s (/ (expt print-base (- k position)) 2))) + (* s (expt print-base k))) + (setf position (- k position)) + (setf position (- k position 1)))))) + (let ((low (max m- (/ (* s (expt print-base position)) 2))) + (high (max m+ (/ (* s (expt print-base position)) 2)))) + (when (<= m- low) + (setf m- low) + (setf low-ok t)) + (when (<= m+ high) + (setf m+ high) + (setf high-ok t)))) + (values r s m+ m-)))) + (multiple-value-bind (r s m+ m-) (initialize) + (scale r s m+ m-))))))) ;;; Given a non-negative floating point number, SCALE-EXPONENT returns ;;; a new floating point number Z in the range (0.1, 1.0] and an @@ -1316,33 +1316,33 @@ (eval-when (:compile-toplevel :execute) (setf *read-default-float-format* - #!+long-float 'long-float #!-long-float 'double-float)) + #!+long-float 'long-float #!-long-float 'double-float)) (defun scale-exponent (original-x) (let* ((x (coerce original-x 'long-float))) (multiple-value-bind (sig exponent) (decode-float x) (declare (ignore sig)) (if (= x 0.0e0) - (values (float 0.0e0 original-x) 1) - (let* ((ex (locally (declare (optimize (safety 0))) + (values (float 0.0e0 original-x) 1) + (let* ((ex (locally (declare (optimize (safety 0))) (the fixnum (round (* exponent (log 2e0 10)))))) - (x (if (minusp ex) - (if (float-denormalized-p x) - #!-long-float - (* x 1.0e16 (expt 10.0e0 (- (- ex) 16))) - #!+long-float - (* x 1.0e18 (expt 10.0e0 (- (- ex) 18))) - (* x 10.0e0 (expt 10.0e0 (- (- ex) 1)))) - (/ x 10.0e0 (expt 10.0e0 (1- ex)))))) - (do ((d 10.0e0 (* d 10.0e0)) - (y x (/ x d)) - (ex ex (1+ ex))) - ((< y 1.0e0) - (do ((m 10.0e0 (* m 10.0e0)) - (z y (* y m)) - (ex ex (1- ex))) - ((>= z 0.1e0) - (values (float z original-x) ex)) + (x (if (minusp ex) + (if (float-denormalized-p x) + #!-long-float + (* x 1.0e16 (expt 10.0e0 (- (- ex) 16))) + #!+long-float + (* x 1.0e18 (expt 10.0e0 (- (- ex) 18))) + (* x 10.0e0 (expt 10.0e0 (- (- ex) 1)))) + (/ x 10.0e0 (expt 10.0e0 (1- ex)))))) + (do ((d 10.0e0 (* d 10.0e0)) + (y x (/ x d)) + (ex ex (1+ ex))) + ((< y 1.0e0) + (do ((m 10.0e0 (* m 10.0e0)) + (z y (* y m)) + (ex ex (1- ex))) + ((>= z 0.1e0) + (values (float z original-x) ex)) (declare (long-float m) (integer ex)))) (declare (long-float d)))))))) (eval-when (:compile-toplevel :execute) @@ -1376,17 +1376,17 @@ (defun print-float-exponent (x exp stream) (declare (type float x) (type integer exp) (type stream stream)) (let ((*print-radix* nil) - (plusp (plusp exp))) + (plusp (plusp exp))) (if (typep x *read-default-float-format*) - (unless (eql exp 0) - (format stream "e~:[~;+~]~D" plusp exp)) - (format stream "~C~:[~;+~]~D" - (etypecase x - (single-float #\f) - (double-float #\d) - (short-float #\s) - (long-float #\L)) - plusp exp)))) + (unless (eql exp 0) + (format stream "e~:[~;+~]~D" plusp exp)) + (format stream "~C~:[~;+~]~D" + (etypecase x + (single-float #\f) + (double-float #\d) + (short-float #\s) + (long-float #\L)) + plusp exp)))) (defun output-float-infinity (x stream) (declare (float x) (stream stream)) @@ -1419,43 +1419,43 @@ (output-float-nan x stream)) (t (let ((x (cond ((minusp (float-sign x)) - (write-char #\- stream) - (- x)) - (t - x)))) + (write-char #\- stream) + (- x)) + (t + x)))) (cond ((zerop x) - (write-string "0.0" stream) - (print-float-exponent x 0 stream)) + (write-string "0.0" stream) + (print-float-exponent x 0 stream)) (t - (output-float-aux x stream -3 8))))))) + (output-float-aux x stream -3 8))))))) (defun output-float-aux (x stream e-min e-max) (multiple-value-bind (e string) (flonum-to-digits x) (cond ((< e-min e e-max) (if (plusp e) - (progn - (write-string string stream :end (min (length string) e)) - (dotimes (i (- e (length string))) - (write-char #\0 stream)) - (write-char #\. stream) - (write-string string stream :start (min (length string) e)) - (when (<= (length string) e) - (write-char #\0 stream)) - (print-float-exponent x 0 stream)) - (progn - (write-string "0." stream) - (dotimes (i (- e)) - (write-char #\0 stream)) - (write-string string stream) - (print-float-exponent x 0 stream)))) + (progn + (write-string string stream :end (min (length string) e)) + (dotimes (i (- e (length string))) + (write-char #\0 stream)) + (write-char #\. stream) + (write-string string stream :start (min (length string) e)) + (when (<= (length string) e) + (write-char #\0 stream)) + (print-float-exponent x 0 stream)) + (progn + (write-string "0." stream) + (dotimes (i (- e)) + (write-char #\0 stream)) + (write-string string stream) + (print-float-exponent x 0 stream)))) (t (write-string string stream :end 1) - (write-char #\. stream) - (write-string string stream :start 1) - (when (= (length string) 1) - (write-char #\0 stream)) - (print-float-exponent x (1- e) stream))))) + (write-char #\. stream) + (write-string string stream :start 1) + (when (= (length string) 1) + (write-char #\0 stream)) + (print-float-exponent x (1- e) stream))))) ;;;; other leaf objects @@ -1464,41 +1464,41 @@ (defun output-character (char stream) (if (or *print-escape* *print-readably*) (let ((graphicp (graphic-char-p char)) - (name (char-name char))) - (write-string "#\\" stream) - (if (and name (not graphicp)) - (quote-string name stream) - (write-char char stream))) + (name (char-name char))) + (write-string "#\\" stream) + (if (and name (not graphicp)) + (quote-string name stream) + (write-char char stream))) (write-char char stream))) (defun output-sap (sap stream) (declare (type system-area-pointer sap)) (cond (*read-eval* - (format stream "#.(~S #X~8,'0X)" 'int-sap (sap-int sap))) - (t - (print-unreadable-object (sap stream) - (format stream "system area pointer: #X~8,'0X" (sap-int sap)))))) + (format stream "#.(~S #X~8,'0X)" 'int-sap (sap-int sap))) + (t + (print-unreadable-object (sap stream) + (format stream "system area pointer: #X~8,'0X" (sap-int sap)))))) (defun output-weak-pointer (weak-pointer stream) (declare (type weak-pointer weak-pointer)) (print-unreadable-object (weak-pointer stream) (multiple-value-bind (value validp) (weak-pointer-value weak-pointer) (cond (validp - (write-string "weak pointer: " stream) - (write value :stream stream)) - (t - (write-string "broken weak pointer" stream)))))) + (write-string "weak pointer: " stream) + (write value :stream stream)) + (t + (write-string "broken weak pointer" stream)))))) (defun output-code-component (component stream) (print-unreadable-object (component stream :identity t) (let ((dinfo (%code-debug-info component))) (cond ((eq dinfo :bogus-lra) - (write-string "bogus code object" stream)) - (t - (write-string "code object" stream) - (when dinfo - (write-char #\space stream) - (output-object (sb!c::debug-info-name dinfo) stream))))))) + (write-string "bogus code object" stream)) + (t + (write-string "code object" stream) + (when dinfo + (write-char #\space stream) + (output-object (sb!c::debug-info-name dinfo) stream))))))) (defun output-lra (lra stream) (print-unreadable-object (lra stream :identity t) @@ -1528,7 +1528,7 @@ (proper-name-p (and (legal-fun-name-p name) (fboundp name) (eq (fdefinition name) object)))) (print-unreadable-object (object stream :identity (not proper-name-p)) - (format stream "~:[FUNCTION~;CLOSURE~]~@[ ~S~]" + (format stream "~:[FUNCTION~;CLOSURE~]~@[ ~S~]" (closurep object) name)))) @@ -1538,30 +1538,30 @@ (print-unreadable-object (object stream :identity t) (let ((lowtag (lowtag-of object))) (case lowtag - (#.sb!vm:other-pointer-lowtag - (let ((widetag (widetag-of object))) - (case widetag - (#.sb!vm:value-cell-header-widetag - (write-string "value cell " stream) - (output-object (value-cell-ref object) stream)) - (t - (write-string "unknown pointer object, widetag=" stream) - (let ((*print-base* 16) (*print-radix* t)) - (output-integer widetag stream)))))) - ((#.sb!vm:fun-pointer-lowtag - #.sb!vm:instance-pointer-lowtag - #.sb!vm:list-pointer-lowtag) - (write-string "unknown pointer object, lowtag=" stream) - (let ((*print-base* 16) (*print-radix* t)) - (output-integer lowtag stream))) - (t - (case (widetag-of object) - (#.sb!vm:unbound-marker-widetag - (write-string "unbound marker" stream)) - (t - (write-string "unknown immediate object, lowtag=" stream) - (let ((*print-base* 2) (*print-radix* t)) - (output-integer lowtag stream)) - (write-string ", widetag=" stream) - (let ((*print-base* 16) (*print-radix* t)) - (output-integer (widetag-of object) stream))))))))) + (#.sb!vm:other-pointer-lowtag + (let ((widetag (widetag-of object))) + (case widetag + (#.sb!vm:value-cell-header-widetag + (write-string "value cell " stream) + (output-object (value-cell-ref object) stream)) + (t + (write-string "unknown pointer object, widetag=" stream) + (let ((*print-base* 16) (*print-radix* t)) + (output-integer widetag stream)))))) + ((#.sb!vm:fun-pointer-lowtag + #.sb!vm:instance-pointer-lowtag + #.sb!vm:list-pointer-lowtag) + (write-string "unknown pointer object, lowtag=" stream) + (let ((*print-base* 16) (*print-radix* t)) + (output-integer lowtag stream))) + (t + (case (widetag-of object) + (#.sb!vm:unbound-marker-widetag + (write-string "unbound marker" stream)) + (t + (write-string "unknown immediate object, lowtag=" stream) + (let ((*print-base* 2) (*print-radix* t)) + (output-integer lowtag stream)) + (write-string ", widetag=" stream) + (let ((*print-base* 16) (*print-radix* t)) + (output-integer (widetag-of object) stream))))))))) diff --git a/src/code/profile.lisp b/src/code/profile.lisp index 48cd92a..e2f98f9 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -34,12 +34,12 @@ (defun fun-signature (name) (let ((type (info :function :type name))) (cond ((not (fun-type-p type)) - (values 0 t)) - (t - (values (length (fun-type-required type)) - (or (fun-type-optional type) - (fun-type-keyp type) - (fun-type-rest type))))))) + (values 0 t)) + (t + (values (length (fun-type-required type)) + (or (fun-type-optional type) + (fun-type-keyp type) + (fun-type-rest type))))))) |# ;;;; global data structures @@ -106,17 +106,17 @@ (defmacro fastbig- (x y) (once-only ((x x) (y y)) `(if (and (typep ,x '(and fixnum unsigned-byte)) - (typep ,y '(and fixnum unsigned-byte))) - ;; special case: can use fixnum arithmetic and be guaranteed - ;; the result is also a fixnum - (- ,x ,y) - ;; general case - (- ,x ,y)))) + (typep ,y '(and fixnum unsigned-byte))) + ;; special case: can use fixnum arithmetic and be guaranteed + ;; the result is also a fixnum + (- ,x ,y) + ;; general case + (- ,x ,y)))) (defmacro fastbig-1+ (x) (once-only ((x x)) `(if (typep ,x 'index) - (1+ ,x) - (1+ ,x)))) + (1+ ,x) + (1+ ,x)))) ;;; Return a collection of closures over the same lexical context, ;;; (VALUES ENCAPSULATION-FUN READ-STATS-FUN CLEAR-STATS-FUN). @@ -142,9 +142,9 @@ (defun profile-encapsulation-lambdas (encapsulated-fun) (declare (type function encapsulated-fun)) (let* ((count 0) - (ticks 0) - (consing 0) - (profiles 0)) + (ticks 0) + (consing 0) + (profiles 0)) (declare (type (or pcounter fixnum) count ticks consing profiles)) (values ;; ENCAPSULATION-FUN @@ -152,71 +152,71 @@ (declare (optimize speed safety)) ;; Make sure that we're not recursing infinitely. (when (boundp '*computing-profiling-data-for*) - (unprofile-all) ; to avoid further recursion - (error "~@" - *computing-profiling-data-for* - encapsulated-fun - encapsulated-fun)) + (unprofile-all) ; to avoid further recursion + (error "~@" + *computing-profiling-data-for* + encapsulated-fun + encapsulated-fun)) ;; FIXME: Probably when this is stable, we should optimize (SAFETY 0). (fastbig-incf-pcounter-or-fixnum count 1) (let ((dticks 0) - (dconsing 0) - (inner-enclosed-profiles 0)) - (declare (type unsigned-byte dticks dconsing)) - (declare (type unsigned-byte inner-enclosed-profiles)) - (aver (typep dticks 'unsigned-byte)) - (aver (typep dconsing 'unsigned-byte)) - (aver (typep inner-enclosed-profiles 'unsigned-byte)) - (unwind-protect - (let* ((start-ticks (get-internal-ticks)) - (*enclosed-ticks* 0) - (*enclosed-consing* 0) - (*enclosed-profiles* 0) - (nbf0 *n-bytes-freed-or-purified*) - (dynamic-usage-0 (sb-kernel:dynamic-usage))) - (declare (inline pcounter-or-fixnum->integer)) - (unwind-protect - (multiple-value-call encapsulated-fun - (sb-c:%more-arg-values arg-context - 0 - arg-count)) - (let ((*computing-profiling-data-for* encapsulated-fun) - (dynamic-usage-1 (sb-kernel:dynamic-usage))) - (setf dticks (fastbig- (get-internal-ticks) start-ticks)) - (setf dconsing - (if (eql *n-bytes-freed-or-purified* nbf0) - ;; common special case where we can avoid - ;; bignum arithmetic - (- dynamic-usage-1 dynamic-usage-0) - ;; general case - (- (get-bytes-consed) nbf0 dynamic-usage-0))) - (setf inner-enclosed-profiles - (pcounter-or-fixnum->integer *enclosed-profiles*)) - (let ((net-dticks (fastbig- dticks *enclosed-ticks*))) - (fastbig-incf-pcounter-or-fixnum ticks net-dticks)) - (let ((net-dconsing (fastbig- dconsing - (pcounter-or-fixnum->integer - *enclosed-consing*)))) - (fastbig-incf-pcounter-or-fixnum consing net-dconsing)) - (fastbig-incf-pcounter-or-fixnum profiles - inner-enclosed-profiles)))) - (fastbig-incf-pcounter-or-fixnum *enclosed-ticks* dticks) - (fastbig-incf-pcounter-or-fixnum *enclosed-consing* dconsing) - (fastbig-incf-pcounter-or-fixnum *enclosed-profiles* - (fastbig-1+ - inner-enclosed-profiles))))) + (dconsing 0) + (inner-enclosed-profiles 0)) + (declare (type unsigned-byte dticks dconsing)) + (declare (type unsigned-byte inner-enclosed-profiles)) + (aver (typep dticks 'unsigned-byte)) + (aver (typep dconsing 'unsigned-byte)) + (aver (typep inner-enclosed-profiles 'unsigned-byte)) + (unwind-protect + (let* ((start-ticks (get-internal-ticks)) + (*enclosed-ticks* 0) + (*enclosed-consing* 0) + (*enclosed-profiles* 0) + (nbf0 *n-bytes-freed-or-purified*) + (dynamic-usage-0 (sb-kernel:dynamic-usage))) + (declare (inline pcounter-or-fixnum->integer)) + (unwind-protect + (multiple-value-call encapsulated-fun + (sb-c:%more-arg-values arg-context + 0 + arg-count)) + (let ((*computing-profiling-data-for* encapsulated-fun) + (dynamic-usage-1 (sb-kernel:dynamic-usage))) + (setf dticks (fastbig- (get-internal-ticks) start-ticks)) + (setf dconsing + (if (eql *n-bytes-freed-or-purified* nbf0) + ;; common special case where we can avoid + ;; bignum arithmetic + (- dynamic-usage-1 dynamic-usage-0) + ;; general case + (- (get-bytes-consed) nbf0 dynamic-usage-0))) + (setf inner-enclosed-profiles + (pcounter-or-fixnum->integer *enclosed-profiles*)) + (let ((net-dticks (fastbig- dticks *enclosed-ticks*))) + (fastbig-incf-pcounter-or-fixnum ticks net-dticks)) + (let ((net-dconsing (fastbig- dconsing + (pcounter-or-fixnum->integer + *enclosed-consing*)))) + (fastbig-incf-pcounter-or-fixnum consing net-dconsing)) + (fastbig-incf-pcounter-or-fixnum profiles + inner-enclosed-profiles)))) + (fastbig-incf-pcounter-or-fixnum *enclosed-ticks* dticks) + (fastbig-incf-pcounter-or-fixnum *enclosed-consing* dconsing) + (fastbig-incf-pcounter-or-fixnum *enclosed-profiles* + (fastbig-1+ + inner-enclosed-profiles))))) ;; READ-STATS-FUN (lambda () (values (pcounter-or-fixnum->integer count) - (pcounter-or-fixnum->integer ticks) - (pcounter-or-fixnum->integer consing) - (pcounter-or-fixnum->integer profiles))) + (pcounter-or-fixnum->integer ticks) + (pcounter-or-fixnum->integer consing) + (pcounter-or-fixnum->integer profiles))) ;; CLEAR-STATS-FUN (lambda () (setf count 0 - ticks 0 - consing 0 - profiles 0))))) + ticks 0 + consing 0 + profiles 0))))) ;;;; interfaces @@ -231,15 +231,15 @@ ;; Then we map onto it. (funcall function name)) (string (let ((package (find-undeleted-package-or-lose name))) - (do-symbols (symbol package) - (when (eq (symbol-package symbol) package) - (when (and (fboundp symbol) - (not (macro-function symbol)) - (not (special-operator-p symbol))) - (funcall function symbol)) - (let ((setf-name `(setf ,symbol))) - (when (fboundp setf-name) - (funcall function setf-name))))))))) + (do-symbols (symbol package) + (when (eq (symbol-package symbol) package) + (when (and (fboundp symbol) + (not (macro-function symbol)) + (not (special-operator-p symbol))) + (funcall function symbol)) + (let ((setf-name `(setf ,symbol))) + (when (fboundp setf-name) + (funcall function setf-name))))))))) (values)) ;;; Profile the named function, which should exist and not be profiled @@ -247,41 +247,41 @@ (defun profile-1-unprofiled-fun (name) (let ((encapsulated-fun (fdefinition name))) (multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun) - (profile-encapsulation-lambdas encapsulated-fun) + (profile-encapsulation-lambdas encapsulated-fun) (without-package-locks (setf (fdefinition name) - encapsulation-fun)) + encapsulation-fun)) (setf (gethash name *profiled-fun-name->info*) - (make-profile-info :name name - :encapsulated-fun encapsulated-fun - :encapsulation-fun encapsulation-fun - :read-stats-fun read-stats-fun - :clear-stats-fun clear-stats-fun)) + (make-profile-info :name name + :encapsulated-fun encapsulated-fun + :encapsulation-fun encapsulation-fun + :read-stats-fun read-stats-fun + :clear-stats-fun clear-stats-fun)) (values)))) ;;; Profile the named function. If already profiled, unprofile first. (defun profile-1-fun (name) (cond ((fboundp name) - (when (gethash name *profiled-fun-name->info*) - (warn "~S is already profiled, so unprofiling it first." name) - (unprofile-1-fun name)) - (profile-1-unprofiled-fun name)) - (t - (warn "ignoring undefined function ~S" name))) + (when (gethash name *profiled-fun-name->info*) + (warn "~S is already profiled, so unprofiling it first." name) + (unprofile-1-fun name)) + (profile-1-unprofiled-fun name)) + (t + (warn "ignoring undefined function ~S" name))) (values)) ;;; Unprofile the named function, if it is profiled. (defun unprofile-1-fun (name) (let ((pinfo (gethash name *profiled-fun-name->info*))) (cond (pinfo - (remhash name *profiled-fun-name->info*) - (if (eq (fdefinition name) (profile-info-encapsulation-fun pinfo)) - (without-package-locks - (setf (fdefinition name) (profile-info-encapsulated-fun pinfo))) - (warn "preserving current definition of redefined function ~S" - name))) - (t - (warn "~S is not a profiled function." name)))) + (remhash name *profiled-fun-name->info*) + (if (eq (fdefinition name) (profile-info-encapsulation-fun pinfo)) + (without-package-locks + (setf (fdefinition name) (profile-info-encapsulated-fun pinfo))) + (warn "preserving current definition of redefined function ~S" + name))) + (t + (warn "~S is not a profiled function." name)))) (values)) (defmacro profile (&rest names) @@ -299,7 +299,7 @@ UNPROFILE, REPORT and RESET." (if (null names) `(loop for k being each hash-key in *profiled-fun-name->info* - collecting k) + collecting k) `(mapc-on-named-funs #'profile-1-fun ',names))) (defmacro unprofile (&rest names) @@ -307,7 +307,7 @@ "Unwrap any profiling code around the named functions, or if no names are given, unprofile all profiled functions. A symbol names a function. A string names all the functions named by symbols in the - named package. NAMES defaults to the list of names of all currently + named package. NAMES defaults to the list of names of all currently profiled functions." (if names `(mapc-on-named-funs #'unprofile-1-fun ',names) @@ -346,11 +346,11 @@ ;;; the enclosing function. (defun compensate-time (calls ticks profile) (let ((raw-compensated - (- (/ (float ticks) (float +ticks-per-second+)) - (* (overhead-internal *overhead*) (float calls)) - (* (- (overhead-total *overhead*) - (overhead-internal *overhead*)) - (float profile))))) + (- (/ (float ticks) (float +ticks-per-second+)) + (* (overhead-internal *overhead*) (float calls)) + (* (- (overhead-total *overhead*) + (overhead-internal *overhead*)) + (float profile))))) (max raw-compensated 0.0))) (defun report () @@ -360,39 +360,39 @@ bignums are involved in runtime calculation, as in a very-long-running Lisp process." (unless (boundp '*overhead*) (setf *overhead* - (compute-overhead))) + (compute-overhead))) (let ((time-info-list ()) - (no-call-name-list ())) + (no-call-name-list ())) (dohash (name pinfo *profiled-fun-name->info*) (unless (eq (fdefinition name) - (profile-info-encapsulation-fun pinfo)) - (warn "Function ~S has been redefined, so times may be inaccurate.~@ - PROFILE it again to record calls to the new definition." - name)) + (profile-info-encapsulation-fun pinfo)) + (warn "Function ~S has been redefined, so times may be inaccurate.~@ + PROFILE it again to record calls to the new definition." + name)) (multiple-value-bind (calls ticks consing profile) - (funcall (profile-info-read-stats-fun pinfo)) - (if (zerop calls) - (push name no-call-name-list) - (push (make-time-info :name name - :calls calls - :seconds (compensate-time calls - ticks - profile) - :consing consing) - time-info-list)))) + (funcall (profile-info-read-stats-fun pinfo)) + (if (zerop calls) + (push name no-call-name-list) + (push (make-time-info :name name + :calls calls + :seconds (compensate-time calls + ticks + profile) + :consing consing) + time-info-list)))) (setf time-info-list - (sort time-info-list - #'>= - :key #'time-info-seconds)) + (sort time-info-list + #'>= + :key #'time-info-seconds)) (print-profile-table time-info-list) (when no-call-name-list (format *trace-output* - "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%" - (sort no-call-name-list #'string< - :key (lambda (name) - (symbol-name (fun-name-block-name name)))))) + "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%" + (sort no-call-name-list #'string< + :key (lambda (name) + (symbol-name (fun-name-block-name name)))))) (values))) @@ -449,13 +449,13 @@ Lisp process." calls-width total-calls) (format *trace-output* - "~%estimated total profiling overhead: ~4,2F seconds~%" - (* (overhead-total *overhead*) (float total-calls))) + "~%estimated total profiling overhead: ~4,2F seconds~%" + (* (overhead-total *overhead*) (float total-calls))) (format *trace-output* - "~&overhead estimation parameters:~% ~Ss/call, ~Ss total profiling, ~Ss internal profiling~%" - (overhead-call *overhead*) - (overhead-total *overhead*) - (overhead-internal *overhead*))))) + "~&overhead estimation parameters:~% ~Ss/call, ~Ss total profiling, ~Ss internal profiling~%" + (overhead-call *overhead*) + (overhead-total *overhead*) + (overhead-internal *overhead*))))) ;;;; overhead estimation @@ -479,38 +479,38 @@ Lisp process." (defun compute-overhead () (format *debug-io* "~&measuring PROFILE overhead..") (flet ((frob () - (let ((start (get-internal-ticks)) - (fun (symbol-function 'compute-overhead-aux))) + (let ((start (get-internal-ticks)) + (fun (symbol-function 'compute-overhead-aux))) (declare (type function fun)) - (dotimes (i *timer-overhead-iterations*) - (funcall fun fun)) - (/ (float (- (get-internal-ticks) start)) - (float +ticks-per-second+) - (float *timer-overhead-iterations*))))) + (dotimes (i *timer-overhead-iterations*) + (funcall fun fun)) + (/ (float (- (get-internal-ticks) start)) + (float +ticks-per-second+) + (float *timer-overhead-iterations*))))) (let (;; Measure unprofiled calls to estimate call overhead. - (call-overhead (frob)) - total-overhead - internal-overhead) + (call-overhead (frob)) + total-overhead + internal-overhead) ;; Measure profiled calls to estimate profiling overhead. (unwind-protect - (progn - (profile compute-overhead-aux) - (setf total-overhead - (- (frob) call-overhead))) - (let* ((pinfo (gethash 'compute-overhead-aux - *profiled-fun-name->info*)) - (read-stats-fun (profile-info-read-stats-fun pinfo)) - (time (nth-value 1 (funcall read-stats-fun)))) - (setf internal-overhead - (/ (float time) - (float +ticks-per-second+) - (float *timer-overhead-iterations*)))) - (unprofile compute-overhead-aux)) + (progn + (profile compute-overhead-aux) + (setf total-overhead + (- (frob) call-overhead))) + (let* ((pinfo (gethash 'compute-overhead-aux + *profiled-fun-name->info*)) + (read-stats-fun (profile-info-read-stats-fun pinfo)) + (time (nth-value 1 (funcall read-stats-fun)))) + (setf internal-overhead + (/ (float time) + (float +ticks-per-second+) + (float *timer-overhead-iterations*)))) + (unprofile compute-overhead-aux)) (prog1 - (make-overhead :call call-overhead - :total total-overhead - :internal internal-overhead) - (format *debug-io* "done~%"))))) + (make-overhead :call call-overhead + :total total-overhead + :internal internal-overhead) + (format *debug-io* "done~%"))))) ;;; It would be bad to compute *OVERHEAD*, save it into a .core file, ;;; then load the old *OVERHEAD* value from the .core file into a diff --git a/src/code/purify.lisp b/src/code/purify.lisp index 162b86c..82cc7cd 100644 --- a/src/code/purify.lisp +++ b/src/code/purify.lisp @@ -21,10 +21,10 @@ ((zerop n) (let ((old-ie (car *info-environment*))) (setq *info-environment* - (list* (make-info-environment :name "Working") - (compact-info-environment (first *info-environment*) - :name name) - (rest *info-environment*))) + (list* (make-info-environment :name "Working") + (compact-info-environment (first *info-environment*) + :name name) + (rest *info-environment*))) (shrink-vector (sb!c::volatile-info-env-table old-ie) 0))) (t (compact-environment-aux name (1- n)) @@ -46,4 +46,4 @@ (when environment-name (compact-environment-aux environment-name 200)) (%purify (get-lisp-obj-address root-structures) - (get-lisp-obj-address nil))) + (get-lisp-obj-address nil))) diff --git a/src/code/query.lisp b/src/code/query.lisp index 0312137..4dc5d6a 100644 --- a/src/code/query.lisp +++ b/src/code/query.lisp @@ -30,7 +30,7 @@ (defun clarify-legal-query-input (yes no) (format *query-io* "~&Please type \"~A\" for yes or \"~A\" for no.~%" - yes no)) + yes no)) (defun y-or-n-p (&optional format-string &rest arguments) #!+sb-doc @@ -39,24 +39,24 @@ n or N as a negative answer. It asks again if you enter any other characters." (flet ((print-query () - (apply #'maybe-print-query "(y or n)" format-string arguments))) + (apply #'maybe-print-query "(y or n)" format-string arguments))) (loop (print-query) - (case (query-read-char) - ((#\y #\Y) (return t)) - ((#\n #\N) (return nil)) - (t (clarify-legal-query-input "y" "n")))))) - + (case (query-read-char) + ((#\y #\Y) (return t)) + ((#\n #\N) (return nil)) + (t (clarify-legal-query-input "y" "n")))))) + (defun yes-or-no-p (&optional format-string &rest arguments) #!+sb-doc "YES-OR-NO-P is similar to Y-OR-N-P, except that it clears the input buffer, beeps, and uses READ-LINE to get the strings YES or NO." (flet ((print-query () - (apply #'maybe-print-query "(yes or no)" format-string arguments))) + (apply #'maybe-print-query "(yes or no)" format-string arguments))) (beep *query-io*) (loop (print-query) - (let ((input (query-read-line))) - (cond - ((string-equal input "yes") (return t)) - ((string-equal input "no") (return nil)) - (t (clarify-legal-query-input "yes" "no"))))))) + (let ((input (query-read-line))) + (cond + ((string-equal input "yes") (return t)) + ((string-equal input "no") (return nil)) + (t (clarify-legal-query-input "yes" "no"))))))) diff --git a/src/code/random.lisp b/src/code/random.lisp index 4126036..373a3b2 100644 --- a/src/code/random.lisp +++ b/src/code/random.lisp @@ -25,5 +25,5 @@ (1- (ash 1 (- random-chunk-length random-integer-extra-bits)))) (sb!xc:defstruct (random-state (:constructor %make-random-state) - (:copier nil)) ; since shallow copy is wrong + (:copier nil)) ; since shallow copy is wrong (state (init-random-state) :type (simple-array (unsigned-byte 32) (627)))) diff --git a/src/code/reader.lisp b/src/code/reader.lisp index cbdb50d..bf17289 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -18,7 +18,7 @@ ;;; E for an exponent marker" (defvar *read-default-float-format* 'single-float) (declaim (type (member short-float single-float double-float long-float) - *read-default-float-format*)) + *read-default-float-format*)) (defvar *readtable*) (declaim (type readtable *readtable*)) @@ -46,14 +46,14 @@ (defun reader-eof-error (stream context) (error 'reader-eof-error - :stream stream - :context context)) + :stream stream + :context context)) (defun %reader-error (stream control &rest args) (error 'reader-error - :stream stream - :format-control control - :format-arguments args)) + :stream stream + :format-control control + :format-arguments args)) ;;;; macros and functions for character tables @@ -90,9 +90,9 @@ ;;; a function value represents itself, and a NIL value represents the ;;; default behavior. (defun get-coerced-cmt-entry (char readtable) - (the function + (the function (or (get-raw-cmt-entry char readtable) - #'read-token))) + #'read-token))) (defun set-cmt-entry (char new-value-designator &optional (rt *readtable*)) (if (typep char 'base-char) @@ -100,7 +100,7 @@ (and new-value-designator (%coerce-callable-to-fun new-value-designator))) (setf (gethash char (character-macro-hash-table rt)) - (and new-value-designator + (and new-value-designator (%coerce-callable-to-fun new-value-designator))))) (defun undefined-macro-char (stream char) @@ -145,12 +145,12 @@ (defun !set-constituent-trait (char trait) (aver (typep char 'base-char)) (setf (elt *constituent-trait-table* (char-code char)) - trait)) + trait)) (defun !cold-init-constituent-trait-table () (setq *constituent-trait-table* - (make-array base-char-code-limit :element-type '(unsigned-byte 8) - :initial-element +char-attr-constituent+)) + (make-array base-char-code-limit :element-type '(unsigned-byte 8) + :initial-element +char-attr-constituent+)) (!set-constituent-trait #\: +char-attr-package-delimiter+) (!set-constituent-trait #\. +char-attr-constituent-dot+) (!set-constituent-trait #\+ +char-attr-constituent-sign+) @@ -172,9 +172,9 @@ (!set-constituent-trait #\Space +char-attr-invalid+) (!set-constituent-trait #\Newline +char-attr-invalid+) (dolist (c (list backspace-char-code tab-char-code form-feed-char-code - return-char-code rubout-char-code)) + return-char-code rubout-char-code)) (!set-constituent-trait (code-char c) +char-attr-invalid+))) - + (defmacro get-constituent-trait (char) `(if (typep ,char 'base-char) (elt *constituent-trait-table* (char-code ,char)) @@ -186,71 +186,71 @@ (maphash (lambda (k v) (setf (gethash k to) v)) from)) (defun copy-readtable (&optional (from-readtable *readtable*) - to-readtable) + to-readtable) (let ((really-from-readtable (or from-readtable *standard-readtable*)) (really-to-readtable (or to-readtable (make-readtable)))) (replace (character-attribute-array really-to-readtable) - (character-attribute-array really-from-readtable)) + (character-attribute-array really-from-readtable)) (shallow-replace/eql-hash-table (character-attribute-hash-table really-to-readtable) (character-attribute-hash-table really-from-readtable)) (replace (character-macro-array really-to-readtable) - (character-macro-array really-from-readtable)) + (character-macro-array really-from-readtable)) (shallow-replace/eql-hash-table (character-macro-hash-table really-to-readtable) (character-macro-hash-table really-from-readtable)) (setf (dispatch-tables really-to-readtable) - (mapcar (lambda (pair) + (mapcar (lambda (pair) (cons (car pair) (let ((table (make-hash-table))) (shallow-replace/eql-hash-table table (cdr pair)) table))) - (dispatch-tables really-from-readtable))) + (dispatch-tables really-from-readtable))) (setf (readtable-case really-to-readtable) - (readtable-case really-from-readtable)) + (readtable-case really-from-readtable)) really-to-readtable)) (defun set-syntax-from-char (to-char from-char &optional - (to-readtable *readtable*) - (from-readtable ())) + (to-readtable *readtable*) + (from-readtable ())) #!+sb-doc "Causes the syntax of TO-CHAR to be the same as FROM-CHAR in the optional readtable (defaults to the current readtable). The FROM-TABLE defaults to the standard Lisp readtable when NIL." (let ((really-from-readtable (or from-readtable *standard-readtable*))) (let ((att (get-cat-entry from-char really-from-readtable)) - (mac (get-raw-cmt-entry from-char really-from-readtable)) - (from-dpair (find from-char (dispatch-tables really-from-readtable) - :test #'char= :key #'car)) - (to-dpair (find to-char (dispatch-tables to-readtable) - :test #'char= :key #'car))) + (mac (get-raw-cmt-entry from-char really-from-readtable)) + (from-dpair (find from-char (dispatch-tables really-from-readtable) + :test #'char= :key #'car)) + (to-dpair (find to-char (dispatch-tables to-readtable) + :test #'char= :key #'car))) (set-cat-entry to-char att to-readtable) (set-cmt-entry to-char mac to-readtable) (when from-dpair - (cond - (to-dpair - (let ((table (cdr to-dpair))) - (clrhash table) - (shallow-replace/eql-hash-table table (cdr from-dpair)))) - (t - (let ((pair (cons to-char (make-hash-table)))) - (shallow-replace/eql-hash-table (cdr pair) (cdr from-dpair)) - (setf (dispatch-tables to-readtable) - (push pair (dispatch-tables to-readtable))))))))) + (cond + (to-dpair + (let ((table (cdr to-dpair))) + (clrhash table) + (shallow-replace/eql-hash-table table (cdr from-dpair)))) + (t + (let ((pair (cons to-char (make-hash-table)))) + (shallow-replace/eql-hash-table (cdr pair) (cdr from-dpair)) + (setf (dispatch-tables to-readtable) + (push pair (dispatch-tables to-readtable))))))))) t) (defun set-macro-character (char function &optional - (non-terminatingp nil) - (readtable *readtable*)) + (non-terminatingp nil) + (readtable *readtable*)) #!+sb-doc "Causes CHAR to be a macro character which invokes FUNCTION when seen by the reader. The NON-TERMINATINGP flag can be used to make the macro character non-terminating, i.e. embeddable in a symbol name." (let ((designated-readtable (or readtable *standard-readtable*))) (set-cat-entry char (if non-terminatingp - +char-attr-constituent+ - +char-attr-terminating-macro+) - designated-readtable) + +char-attr-constituent+ + +char-attr-terminating-macro+) + designated-readtable) (set-cmt-entry char function designated-readtable) t)) ; (ANSI-specified return value) @@ -261,19 +261,19 @@ T if CHAR is a macro character which is non-terminating, i.e. which can be embedded in a symbol name." (let* ((designated-readtable (or readtable *standard-readtable*)) - ;; the first return value: a FUNCTION if CHAR is a macro - ;; character, or NIL otherwise - (fun-value (get-raw-cmt-entry char designated-readtable))) + ;; the first return value: a FUNCTION if CHAR is a macro + ;; character, or NIL otherwise + (fun-value (get-raw-cmt-entry char designated-readtable))) (values fun-value - ;; NON-TERMINATING-P return value: - (if fun-value - (or (constituentp char) - (not (terminating-macrop char))) - ;; ANSI's definition of GET-MACRO-CHARACTER says this - ;; value is NIL when CHAR is not a macro character. - ;; I.e. this value means not just "non-terminating - ;; character?" but "non-terminating macro character?". - nil)))) + ;; NON-TERMINATING-P return value: + (if fun-value + (or (constituentp char) + (not (terminating-macrop char))) + ;; ANSI's definition of GET-MACRO-CHARACTER says this + ;; value is NIL when CHAR is not a macro character. + ;; I.e. this value means not just "non-terminating + ;; character?" but "non-terminating macro character?". + nil)))) ;;;; definitions to support internal programming conventions @@ -285,34 +285,34 @@ ;; non-white one). It always gets an error on end-of-file. (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) - (prepare-for-fast-read-char stream - (do ((attribute-array (character-attribute-array *readtable*)) + (prepare-for-fast-read-char stream + (do ((attribute-array (character-attribute-array *readtable*)) (attribute-hash-table (character-attribute-hash-table *readtable*)) - (char (fast-read-char t) (fast-read-char t))) - ((/= (the fixnum + (char (fast-read-char t) (fast-read-char t))) + ((/= (the fixnum (if (typep char 'base-char) (aref attribute-array (char-code char)) (gethash char attribute-hash-table +char-attr-constituent+))) - +char-attr-whitespace+) - (done-with-fast-read-char) - char))) - ;; CLOS stream - (do ((attribute-array (character-attribute-array *readtable*)) + +char-attr-whitespace+) + (done-with-fast-read-char) + char))) + ;; CLOS stream + (do ((attribute-array (character-attribute-array *readtable*)) (attribute-hash-table (character-attribute-hash-table *readtable*)) - (char (read-char stream nil :eof) (read-char stream nil :eof))) - ((or (eq char :eof) - (/= (the fixnum + (char (read-char stream nil :eof) (read-char stream nil :eof))) + ((or (eq char :eof) + (/= (the fixnum (if (typep char 'base-char) (aref attribute-array (char-code char)) (gethash char attribute-hash-table +char-attr-constituent+))) - +char-attr-whitespace+)) - (if (eq char :eof) - (error 'end-of-file :stream stream) - char)))))) + +char-attr-whitespace+)) + (if (eq char :eof) + (error 'end-of-file :stream stream) + char)))))) ;;;; temporary initialization hack @@ -324,8 +324,8 @@ (let ((*readtable* *standard-readtable*)) (flet ((whitespaceify (char) - (set-cmt-entry char nil) - (set-cat-entry char +char-attr-whitespace+))) + (set-cmt-entry char nil) + (set-cat-entry char +char-attr-whitespace+))) (whitespaceify (code-char tab-char-code)) (whitespaceify #\Newline) (whitespaceify #\Space) @@ -349,11 +349,11 @@ ;; all constituents (do ((ichar 0 (1+ ichar)) - (char)) - ((= ichar base-char-code-limit)) + (char)) + ((= ichar base-char-code-limit)) (setq char (code-char ichar)) (when (constituentp char *standard-readtable*) - (set-cmt-entry char nil))))) + (set-cmt-entry char nil))))) ;;;; implementation of the read buffer @@ -400,9 +400,9 @@ (defun grow-read-buffer () (let ((rbl (length (the simple-string *read-buffer*)))) (setq *read-buffer* - (concatenate 'simple-string - *read-buffer* - (make-string rbl))) + (concatenate 'simple-string + *read-buffer* + (make-string rbl))) (setq *read-buffer-length* (* 2 rbl)))) (defun inchpeek-read-buffer () @@ -414,8 +414,8 @@ (if (>= *inch-ptr* *ouch-ptr*) *eof-object* (prog1 - (elt *read-buffer* *inch-ptr*) - (incf *inch-ptr*)))) + (elt *read-buffer* *inch-ptr*) + (incf *inch-ptr*)))) (defmacro unread-buffer () `(decf *inch-ptr*)) @@ -457,9 +457,9 @@ variables to allow for nested and thread safe reading." ;;; sure to leave terminating whitespace in the stream. (This is a ;;; COMMON-LISP exported symbol.) (defun read-preserving-whitespace (&optional (stream *standard-input*) - (eof-error-p t) - (eof-value nil) - (recursivep nil)) + (eof-error-p t) + (eof-value nil) + (recursivep nil)) #!+sb-doc "Read from STREAM and return the value read, preserving any whitespace that followed the object." @@ -474,7 +474,7 @@ variables to allow for nested and thread safe reading." (result (multiple-value-list (funcall macrofun stream char)))) ;; Repeat if macro returned nothing. - (when result + (when result (return (unless *read-suppress* (car result))))))))) (with-reader () (let ((*sharp-equal-alist* nil)) @@ -486,35 +486,35 @@ variables to allow for nested and thread safe reading." ;;; past them. We assume CHAR is not whitespace. (defun read-maybe-nothing (stream char) (let ((retval (multiple-value-list - (funcall (get-coerced-cmt-entry char *readtable*) - stream - char)))) + (funcall (get-coerced-cmt-entry char *readtable*) + stream + char)))) (if retval (rplacd retval nil)))) (defun read (&optional (stream *standard-input*) - (eof-error-p t) - (eof-value ()) - (recursivep ())) + (eof-error-p t) + (eof-value ()) + (recursivep ())) #!+sb-doc "Read the next Lisp value from STREAM, and return it." (let ((result (read-preserving-whitespace stream - eof-error-p - eof-value - recursivep))) + eof-error-p + eof-value + recursivep))) ;; This function generally discards trailing whitespace. If you ;; don't want to discard trailing whitespace, call ;; CL:READ-PRESERVING-WHITESPACE instead. (unless (or (eql result eof-value) recursivep) (let ((next-char (read-char stream nil nil))) - (unless (or (null next-char) - (whitespacep next-char)) - (unread-char next-char stream)))) + (unless (or (null next-char) + (whitespacep next-char)) + (unread-char next-char stream)))) result)) ;;; (This is a COMMON-LISP exported symbol.) (defun read-delimited-list (endchar &optional - (input-stream *standard-input*) - recursive-p) + (input-stream *standard-input*) + recursive-p) #!+sb-doc "Read Lisp values from INPUT-STREAM until the next character after a value's representation is ENDCHAR, and return the objects as a list." @@ -538,72 +538,72 @@ variables to allow for nested and thread safe reading." (declare (ignore ignore)) (handler-bind ((character-decoding-error - #'(lambda (decoding-error) - (declare (ignorable decoding-error)) - (style-warn "Character decoding error in a ;-comment at position ~A reading source file ~A, resyncing." (file-position stream) stream) - (invoke-restart 'attempt-resync)))) + #'(lambda (decoding-error) + (declare (ignorable decoding-error)) + (style-warn "Character decoding error in a ;-comment at position ~A reading source file ~A, resyncing." (file-position stream) stream) + (invoke-restart 'attempt-resync)))) (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) - (prepare-for-fast-read-char stream - (do ((char (fast-read-char nil nil) - (fast-read-char nil nil))) - ((or (not char) (char= char #\newline)) - (done-with-fast-read-char)))) - ;; CLOS stream - (do ((char (read-char stream nil :eof) (read-char stream nil :eof))) - ((or (eq char :eof) (char= char #\newline))))))) + (prepare-for-fast-read-char stream + (do ((char (fast-read-char nil nil) + (fast-read-char nil nil))) + ((or (not char) (char= char #\newline)) + (done-with-fast-read-char)))) + ;; CLOS stream + (do ((char (read-char stream nil :eof) (read-char stream nil :eof))) + ((or (eq char :eof) (char= char #\newline))))))) ;; Don't return anything. (values)) (defun read-list (stream ignore) (declare (ignore ignore)) (let* ((thelist (list nil)) - (listtail thelist)) + (listtail thelist)) (do ((firstchar (flush-whitespace stream) (flush-whitespace stream))) - ((char= firstchar #\) ) (cdr thelist)) + ((char= firstchar #\) ) (cdr thelist)) (when (char= firstchar #\.) - (let ((nextchar (read-char stream t))) - (cond ((token-delimiterp nextchar) - (cond ((eq listtail thelist) - (unless *read-suppress* - (%reader-error - stream - "Nothing appears before . in list."))) - ((whitespacep nextchar) - (setq nextchar (flush-whitespace stream)))) - (rplacd listtail - ;; Return list containing last thing. - (car (read-after-dot stream nextchar))) - (return (cdr thelist))) - ;; Put back NEXTCHAR so that we can read it normally. - (t (unread-char nextchar stream))))) + (let ((nextchar (read-char stream t))) + (cond ((token-delimiterp nextchar) + (cond ((eq listtail thelist) + (unless *read-suppress* + (%reader-error + stream + "Nothing appears before . in list."))) + ((whitespacep nextchar) + (setq nextchar (flush-whitespace stream)))) + (rplacd listtail + ;; Return list containing last thing. + (car (read-after-dot stream nextchar))) + (return (cdr thelist))) + ;; Put back NEXTCHAR so that we can read it normally. + (t (unread-char nextchar stream))))) ;; Next thing is not an isolated dot. (let ((listobj (read-maybe-nothing stream firstchar))) - ;; allows the possibility that a comment was read - (when listobj - (rplacd listtail listobj) - (setq listtail listobj)))))) + ;; allows the possibility that a comment was read + (when listobj + (rplacd listtail listobj) + (setq listtail listobj)))))) (defun read-after-dot (stream firstchar) ;; FIRSTCHAR is non-whitespace! (let ((lastobj ())) (do ((char firstchar (flush-whitespace stream))) - ((char= char #\) ) - (if *read-suppress* - (return-from read-after-dot nil) - (%reader-error stream "Nothing appears after . in list."))) + ((char= char #\) ) + (if *read-suppress* + (return-from read-after-dot nil) + (%reader-error stream "Nothing appears after . in list."))) ;; See whether there's something there. (setq lastobj (read-maybe-nothing stream char)) (when lastobj (return t))) ;; At least one thing appears after the dot. ;; Check for more than one thing following dot. (do ((lastchar (flush-whitespace stream) - (flush-whitespace stream))) - ((char= lastchar #\) ) lastobj) ;success! + (flush-whitespace stream))) + ((char= lastchar #\) ) lastobj) ;success! ;; Try reading virtual whitespace. (if (and (read-maybe-nothing stream lastchar) - (not *read-suppress*)) - (%reader-error stream "More than one object follows . in list."))))) + (not *read-suppress*)) + (%reader-error stream "More than one object follows . in list."))))) (defun read-string (stream closech) ;; This accumulates chars until it sees same char that invoked it. @@ -611,22 +611,22 @@ variables to allow for nested and thread safe reading." (reset-read-buffer) (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) - (prepare-for-fast-read-char stream - (do ((char (fast-read-char t) (fast-read-char t))) - ((char= char closech) - (done-with-fast-read-char)) - (if (single-escape-p char) (setq char (fast-read-char t))) - (ouch-read-buffer char))) - ;; CLOS stream - (do ((char (read-char stream nil :eof) (read-char stream nil :eof))) - ((or (eq char :eof) (char= char closech)) - (if (eq char :eof) - (error 'end-of-file :stream stream))) - (when (single-escape-p char) - (setq char (read-char stream nil :eof)) - (if (eq char :eof) - (error 'end-of-file :stream stream))) - (ouch-read-buffer char)))) + (prepare-for-fast-read-char stream + (do ((char (fast-read-char t) (fast-read-char t))) + ((char= char closech) + (done-with-fast-read-char)) + (if (single-escape-p char) (setq char (fast-read-char t))) + (ouch-read-buffer char))) + ;; CLOS stream + (do ((char (read-char stream nil :eof) (read-char stream nil :eof))) + ((or (eq char :eof) (char= char closech)) + (if (eq char :eof) + (error 'end-of-file :stream stream))) + (when (single-escape-p char) + (setq char (read-char stream nil :eof)) + (if (eq char :eof) + (error 'end-of-file :stream stream))) + (ouch-read-buffer char)))) (read-buffer-to-string)) (defun read-right-paren (stream ignore) @@ -647,45 +647,45 @@ variables to allow for nested and thread safe reading." (do ((char firstchar (read-char stream nil *eof-object*)) (colon nil)) ((cond ((eofp char) t) - ((token-delimiterp char) - (unread-char char stream) - t) - (t nil)) + ((token-delimiterp char) + (unread-char char stream) + t) + (t nil)) (values escapes colon)) (cond ((single-escape-p char) - ;; It can't be a number, even if it's 1\23. - ;; Read next char here, so it won't be casified. - (push *ouch-ptr* escapes) - (let ((nextchar (read-char stream nil *eof-object*))) - (if (eofp nextchar) - (reader-eof-error stream "after escape character") - (ouch-read-buffer nextchar)))) - ((multiple-escape-p char) - ;; Read to next multiple-escape, escaping single chars - ;; along the way. - (loop - (let ((ch (read-char stream nil *eof-object*))) - (cond - ((eofp ch) - (reader-eof-error stream "inside extended token")) - ((multiple-escape-p ch) (return)) - ((single-escape-p ch) - (let ((nextchar (read-char stream nil *eof-object*))) - (cond ((eofp nextchar) - (reader-eof-error stream "after escape character")) - (t - (push *ouch-ptr* escapes) - (ouch-read-buffer nextchar))))) - (t - (push *ouch-ptr* escapes) - (ouch-read-buffer ch)))))) - (t - (when (and (constituentp char) - (eql (get-constituent-trait char) - +char-attr-package-delimiter+) - (not colon)) - (setq colon *ouch-ptr*)) - (ouch-read-buffer char)))))) + ;; It can't be a number, even if it's 1\23. + ;; Read next char here, so it won't be casified. + (push *ouch-ptr* escapes) + (let ((nextchar (read-char stream nil *eof-object*))) + (if (eofp nextchar) + (reader-eof-error stream "after escape character") + (ouch-read-buffer nextchar)))) + ((multiple-escape-p char) + ;; Read to next multiple-escape, escaping single chars + ;; along the way. + (loop + (let ((ch (read-char stream nil *eof-object*))) + (cond + ((eofp ch) + (reader-eof-error stream "inside extended token")) + ((multiple-escape-p ch) (return)) + ((single-escape-p ch) + (let ((nextchar (read-char stream nil *eof-object*))) + (cond ((eofp nextchar) + (reader-eof-error stream "after escape character")) + (t + (push *ouch-ptr* escapes) + (ouch-read-buffer nextchar))))) + (t + (push *ouch-ptr* escapes) + (ouch-read-buffer ch)))))) + (t + (when (and (constituentp char) + (eql (get-constituent-trait char) + +char-attr-package-delimiter+) + (not colon)) + (setq colon *ouch-ptr*)) + (ouch-read-buffer char)))))) ;;;; character classes @@ -702,9 +702,9 @@ variables to allow for nested and thread safe reading." ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+) ((< att +char-attr-constituent+) att) (t (setf att (get-constituent-trait ,char)) - (if (= att +char-attr-invalid+) - (%reader-error stream "invalid constituent") - att))))) + (if (= att +char-attr-invalid+) + (%reader-error stream "invalid constituent") + att))))) ;;; Return the character class for CHAR, which might be part of a ;;; rational number. @@ -717,12 +717,12 @@ variables to allow for nested and thread safe reading." ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+) ((< att +char-attr-constituent+) att) (t (setf att (get-constituent-trait ,char)) - (cond - ((digit-char-p ,char *read-base*) +char-attr-constituent-digit+) - ((= att +char-attr-constituent-digit+) +char-attr-constituent+) - ((= att +char-attr-invalid+) - (%reader-error stream "invalid constituent")) - (t att)))))) + (cond + ((digit-char-p ,char *read-base*) +char-attr-constituent-digit+) + ((= att +char-attr-constituent-digit+) +char-attr-constituent+) + ((= att +char-attr-invalid+) + (%reader-error stream "invalid constituent")) + (t att)))))) ;;; Return the character class for a char which might be part of a ;;; rational or floating number. (Assume that it is a digit if it @@ -736,24 +736,24 @@ variables to allow for nested and thread safe reading." ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+) ((< att +char-attr-constituent+) att) (t (setf att (get-constituent-trait ,char)) - (when possibly-rational - (setq possibly-rational - (or (digit-char-p ,char *read-base*) - (= att +char-attr-constituent-slash+)))) - (when possibly-float - (setq possibly-float - (or (digit-char-p ,char 10) - (= att +char-attr-constituent-dot+)))) - (cond - ((digit-char-p ,char (max *read-base* 10)) - (if (digit-char-p ,char *read-base*) - (if (= att +char-attr-constituent-expt+) - +char-attr-constituent-digit-or-expt+ - +char-attr-constituent-digit+) - +char-attr-constituent-decimal-digit+)) - ((= att +char-attr-invalid+) - (%reader-error stream "invalid constituent")) - (t att)))))) + (when possibly-rational + (setq possibly-rational + (or (digit-char-p ,char *read-base*) + (= att +char-attr-constituent-slash+)))) + (when possibly-float + (setq possibly-float + (or (digit-char-p ,char 10) + (= att +char-attr-constituent-dot+)))) + (cond + ((digit-char-p ,char (max *read-base* 10)) + (if (digit-char-p ,char *read-base*) + (if (= att +char-attr-constituent-expt+) + +char-attr-constituent-digit-or-expt+ + +char-attr-constituent-digit+) + +char-attr-constituent-decimal-digit+)) + ((= att +char-attr-invalid+) + (%reader-error stream "invalid constituent")) + (t att)))))) ;;;; token fetching @@ -774,42 +774,42 @@ variables to allow for nested and thread safe reading." (cond ((and (null escapes) (eq case :upcase)) (dotimes (i *ouch-ptr*) - (setf (schar *read-buffer* i) - (char-upcase (schar *read-buffer* i))))) + (setf (schar *read-buffer* i) + (char-upcase (schar *read-buffer* i))))) ((eq case :preserve)) (t (macrolet ((skip-esc (&body body) - `(do ((i (1- *ouch-ptr*) (1- i)) - (escapes escapes)) - ((minusp i)) - (declare (fixnum i)) - (when (or (null escapes) - (let ((esc (first escapes))) - (declare (fixnum esc)) - (cond ((< esc i) t) - (t - (aver (= esc i)) - (pop escapes) - nil)))) - (let ((ch (schar *read-buffer* i))) - ,@body))))) - (flet ((lower-em () - (skip-esc (setf (schar *read-buffer* i) (char-downcase ch)))) - (raise-em () - (skip-esc (setf (schar *read-buffer* i) (char-upcase ch))))) - (ecase case - (:upcase (raise-em)) - (:downcase (lower-em)) - (:invert - (let ((all-upper t) - (all-lower t)) - (skip-esc - (when (both-case-p ch) - (if (upper-case-p ch) - (setq all-lower nil) - (setq all-upper nil)))) - (cond (all-lower (raise-em)) - (all-upper (lower-em)))))))))))) + `(do ((i (1- *ouch-ptr*) (1- i)) + (escapes escapes)) + ((minusp i)) + (declare (fixnum i)) + (when (or (null escapes) + (let ((esc (first escapes))) + (declare (fixnum esc)) + (cond ((< esc i) t) + (t + (aver (= esc i)) + (pop escapes) + nil)))) + (let ((ch (schar *read-buffer* i))) + ,@body))))) + (flet ((lower-em () + (skip-esc (setf (schar *read-buffer* i) (char-downcase ch)))) + (raise-em () + (skip-esc (setf (schar *read-buffer* i) (char-upcase ch))))) + (ecase case + (:upcase (raise-em)) + (:downcase (lower-em)) + (:invert + (let ((all-upper t) + (all-lower t)) + (skip-esc + (when (both-case-p ch) + (if (upper-case-p ch) + (setq all-lower nil) + (setq all-upper nil)))) + (cond (all-lower (raise-em)) + (all-upper (lower-em)))))))))))) (defun read-token (stream firstchar) #!+sb-doc @@ -826,378 +826,378 @@ variables to allow for nested and thread safe reading." (return-from read-token nil)) (let ((attribute-array (character-attribute-array *readtable*)) (attribute-hash-table (character-attribute-hash-table *readtable*)) - (package-designator nil) - (colons 0) - (possibly-rational t) - (seen-digit-or-expt nil) - (possibly-float t) - (was-possibly-float nil) - (escapes ()) - (seen-multiple-escapes nil)) + (package-designator nil) + (colons 0) + (possibly-rational t) + (seen-digit-or-expt nil) + (possibly-float t) + (was-possibly-float nil) + (escapes ()) + (seen-multiple-escapes nil)) (reset-read-buffer) (prog ((char firstchar)) (case (char-class3 char attribute-array attribute-hash-table) - (#.+char-attr-constituent-sign+ (go SIGN)) - (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) - (#.+char-attr-constituent-digit-or-expt+ - (setq seen-digit-or-expt t) - (go LEFTDIGIT)) - (#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT)) - (#.+char-attr-constituent-dot+ (go FRONTDOT)) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-invalid+ (%reader-error stream "invalid constituent")) - ;; can't have eof, whitespace, or terminating macro as first char! - (t (go SYMBOL))) + (#.+char-attr-constituent-sign+ (go SIGN)) + (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) + (#.+char-attr-constituent-digit-or-expt+ + (setq seen-digit-or-expt t) + (go LEFTDIGIT)) + (#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT)) + (#.+char-attr-constituent-dot+ (go FRONTDOT)) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-invalid+ (%reader-error stream "invalid constituent")) + ;; can't have eof, whitespace, or terminating macro as first char! + (t (go SYMBOL))) SIGN ; saw "sign" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (setq possibly-rational t - possibly-float t) + possibly-float t) (case (char-class3 char attribute-array attribute-hash-table) - (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) - (#.+char-attr-constituent-digit-or-expt+ - (setq seen-digit-or-expt t) - (go LEFTDIGIT)) - (#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT)) - (#.+char-attr-constituent-dot+ (go SIGNDOT)) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) - (t (go SYMBOL))) + (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) + (#.+char-attr-constituent-digit-or-expt+ + (setq seen-digit-or-expt t) + (go LEFTDIGIT)) + (#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT)) + (#.+char-attr-constituent-dot+ (go SIGNDOT)) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (t (go SYMBOL))) LEFTDIGIT ; saw "[sign] {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-integer))) (setq was-possibly-float possibly-float) (case (char-class3 char attribute-array attribute-hash-table) - (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) - (#.+char-attr-constituent-decimal-digit+ (if possibly-float - (go LEFTDECIMALDIGIT) - (go SYMBOL))) - (#.+char-attr-constituent-dot+ (if possibly-float - (go MIDDLEDOT) - (go SYMBOL))) - (#.+char-attr-constituent-digit-or-expt+ - (if (or seen-digit-or-expt (not was-possibly-float)) - (progn (setq seen-digit-or-expt t) (go LEFTDIGIT)) - (progn (setq seen-digit-or-expt t) (go LEFTDIGIT-OR-EXPT)))) - (#.+char-attr-constituent-expt+ - (if was-possibly-float - (go EXPONENT) - (go SYMBOL))) - (#.+char-attr-constituent-slash+ (if possibly-rational - (go RATIO) - (go SYMBOL))) - (#.+char-attr-delimiter+ (unread-char char stream) - (return (make-integer))) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (t (go SYMBOL))) + (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) + (#.+char-attr-constituent-decimal-digit+ (if possibly-float + (go LEFTDECIMALDIGIT) + (go SYMBOL))) + (#.+char-attr-constituent-dot+ (if possibly-float + (go MIDDLEDOT) + (go SYMBOL))) + (#.+char-attr-constituent-digit-or-expt+ + (if (or seen-digit-or-expt (not was-possibly-float)) + (progn (setq seen-digit-or-expt t) (go LEFTDIGIT)) + (progn (setq seen-digit-or-expt t) (go LEFTDIGIT-OR-EXPT)))) + (#.+char-attr-constituent-expt+ + (if was-possibly-float + (go EXPONENT) + (go SYMBOL))) + (#.+char-attr-constituent-slash+ (if possibly-rational + (go RATIO) + (go SYMBOL))) + (#.+char-attr-delimiter+ (unread-char char stream) + (return (make-integer))) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) LEFTDIGIT-OR-EXPT (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-integer))) (case (char-class3 char attribute-array attribute-hash-table) - (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) - (#.+char-attr-constituent-decimal-digit+ (bug "impossible!")) - (#.+char-attr-constituent-dot+ (go SYMBOL)) - (#.+char-attr-constituent-digit-or-expt+ (go LEFTDIGIT)) - (#.+char-attr-constituent-expt+ (go SYMBOL)) - (#.+char-attr-constituent-sign+ (go EXPTSIGN)) - (#.+char-attr-constituent-slash+ (if possibly-rational - (go RATIO) - (go SYMBOL))) - (#.+char-attr-delimiter+ (unread-char char stream) - (return (make-integer))) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (t (go SYMBOL))) + (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) + (#.+char-attr-constituent-decimal-digit+ (bug "impossible!")) + (#.+char-attr-constituent-dot+ (go SYMBOL)) + (#.+char-attr-constituent-digit-or-expt+ (go LEFTDIGIT)) + (#.+char-attr-constituent-expt+ (go SYMBOL)) + (#.+char-attr-constituent-sign+ (go EXPTSIGN)) + (#.+char-attr-constituent-slash+ (if possibly-rational + (go RATIO) + (go SYMBOL))) + (#.+char-attr-delimiter+ (unread-char char stream) + (return (make-integer))) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) LEFTDECIMALDIGIT ; saw "[sign] {decimal-digit}+" (aver possibly-float) (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-array attribute-hash-table) - (#.+char-attr-constituent-digit+ (go LEFTDECIMALDIGIT)) - (#.+char-attr-constituent-dot+ (go MIDDLEDOT)) - (#.+char-attr-constituent-expt+ (go EXPONENT)) - (#.+char-attr-constituent-slash+ (aver (not possibly-rational)) - (go SYMBOL)) - (#.+char-attr-delimiter+ (unread-char char stream) - (go RETURN-SYMBOL)) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (t (go SYMBOL))) + (#.+char-attr-constituent-digit+ (go LEFTDECIMALDIGIT)) + (#.+char-attr-constituent-dot+ (go MIDDLEDOT)) + (#.+char-attr-constituent-expt+ (go EXPONENT)) + (#.+char-attr-constituent-slash+ (aver (not possibly-rational)) + (go SYMBOL)) + (#.+char-attr-delimiter+ (unread-char char stream) + (go RETURN-SYMBOL)) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) MIDDLEDOT ; saw "[sign] {digit}+ dot" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (let ((*read-base* 10)) - (make-integer)))) + (make-integer)))) (case (char-class char attribute-array attribute-hash-table) - (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) - (#.+char-attr-constituent-expt+ (go EXPONENT)) - (#.+char-attr-delimiter+ - (unread-char char stream) - (return (let ((*read-base* 10)) - (make-integer)))) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (t (go SYMBOL))) + (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) + (#.+char-attr-constituent-expt+ (go EXPONENT)) + (#.+char-attr-delimiter+ + (unread-char char stream) + (return (let ((*read-base* 10)) + (make-integer)))) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) RIGHTDIGIT ; saw "[sign] {decimal-digit}* dot {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-float stream))) (case (char-class char attribute-array attribute-hash-table) - (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) - (#.+char-attr-constituent-expt+ (go EXPONENT)) - (#.+char-attr-delimiter+ - (unread-char char stream) - (return (make-float stream))) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (t (go SYMBOL))) + (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) + (#.+char-attr-constituent-expt+ (go EXPONENT)) + (#.+char-attr-delimiter+ + (unread-char char stream) + (return (make-float stream))) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) SIGNDOT ; saw "[sign] dot" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-array attribute-hash-table) - (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) - (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (t (go SYMBOL))) + (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (t (go SYMBOL))) FRONTDOT ; saw "dot" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (%reader-error stream "dot context error")) (case (char-class char attribute-array attribute-hash-table) - (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) - (#.+char-attr-constituent-dot+ (go DOTS)) - (#.+char-attr-delimiter+ (%reader-error stream "dot context error")) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (t (go SYMBOL))) + (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) + (#.+char-attr-constituent-dot+ (go DOTS)) + (#.+char-attr-delimiter+ (%reader-error stream "dot context error")) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) EXPONENT (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (setq possibly-float t) (case (char-class char attribute-array attribute-hash-table) - (#.+char-attr-constituent-sign+ (go EXPTSIGN)) - (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) - (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (t (go SYMBOL))) + (#.+char-attr-constituent-sign+ (go EXPTSIGN)) + (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) EXPTSIGN ; got to EXPONENT, and saw a sign character (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-array attribute-hash-table) - (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) - (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (t (go SYMBOL))) + (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) EXPTDIGIT ; got to EXPONENT, saw "[sign] {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-float stream))) (case (char-class char attribute-array attribute-hash-table) - (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) - (#.+char-attr-delimiter+ - (unread-char char stream) - (return (make-float stream))) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (t (go SYMBOL))) + (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) + (#.+char-attr-delimiter+ + (unread-char char stream) + (return (make-float stream))) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) RATIO ; saw "[sign] {digit}+ slash" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class2 char attribute-array attribute-hash-table) - (#.+char-attr-constituent-digit+ (go RATIODIGIT)) - (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (t (go SYMBOL))) + (#.+char-attr-constituent-digit+ (go RATIODIGIT)) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) RATIODIGIT ; saw "[sign] {digit}+ slash {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-ratio stream))) (case (char-class2 char attribute-array attribute-hash-table) - (#.+char-attr-constituent-digit+ (go RATIODIGIT)) - (#.+char-attr-delimiter+ - (unread-char char stream) - (return (make-ratio stream))) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (t (go SYMBOL))) + (#.+char-attr-constituent-digit+ (go RATIODIGIT)) + (#.+char-attr-delimiter+ + (unread-char char stream) + (return (make-ratio stream))) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) DOTS ; saw "dot {dot}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (%reader-error stream "too many dots")) (case (char-class char attribute-array attribute-hash-table) - (#.+char-attr-constituent-dot+ (go DOTS)) - (#.+char-attr-delimiter+ - (unread-char char stream) - (%reader-error stream "too many dots")) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (t (go SYMBOL))) + (#.+char-attr-constituent-dot+ (go DOTS)) + (#.+char-attr-delimiter+ + (unread-char char stream) + (%reader-error stream "too many dots")) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) SYMBOL ; not a dot, dots, or number (let ((stream (in-synonym-of stream))) - (if (ansi-stream-p stream) - (prepare-for-fast-read-char stream - (prog () - SYMBOL-LOOP - (ouch-read-buffer char) - (setq char (fast-read-char nil nil)) - (unless char (go RETURN-SYMBOL)) - (case (char-class char attribute-array attribute-hash-table) - (#.+char-attr-single-escape+ (done-with-fast-read-char) - (go SINGLE-ESCAPE)) - (#.+char-attr-delimiter+ (done-with-fast-read-char) - (unread-char char stream) - (go RETURN-SYMBOL)) - (#.+char-attr-multiple-escape+ (done-with-fast-read-char) - (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (done-with-fast-read-char) - (go COLON)) - (t (go SYMBOL-LOOP))))) - ;; CLOS stream - (prog () - SYMBOL-LOOP - (ouch-read-buffer char) - (setq char (read-char stream nil :eof)) - (when (eq char :eof) (go RETURN-SYMBOL)) - (case (char-class char attribute-array attribute-hash-table) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-delimiter+ (unread-char char stream) - (go RETURN-SYMBOL)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (t (go SYMBOL-LOOP)))))) + (if (ansi-stream-p stream) + (prepare-for-fast-read-char stream + (prog () + SYMBOL-LOOP + (ouch-read-buffer char) + (setq char (fast-read-char nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-array attribute-hash-table) + (#.+char-attr-single-escape+ (done-with-fast-read-char) + (go SINGLE-ESCAPE)) + (#.+char-attr-delimiter+ (done-with-fast-read-char) + (unread-char char stream) + (go RETURN-SYMBOL)) + (#.+char-attr-multiple-escape+ (done-with-fast-read-char) + (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (done-with-fast-read-char) + (go COLON)) + (t (go SYMBOL-LOOP))))) + ;; CLOS stream + (prog () + SYMBOL-LOOP + (ouch-read-buffer char) + (setq char (read-char stream nil :eof)) + (when (eq char :eof) (go RETURN-SYMBOL)) + (case (char-class char attribute-array attribute-hash-table) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-delimiter+ (unread-char char stream) + (go RETURN-SYMBOL)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL-LOOP)))))) SINGLE-ESCAPE ; saw a single-escape ;; Don't put the escape character in the read buffer. ;; READ-NEXT CHAR, put in buffer (no case conversion). (let ((nextchar (read-char stream nil nil))) - (unless nextchar - (reader-eof-error stream "after single-escape character")) - (push *ouch-ptr* escapes) - (ouch-read-buffer nextchar)) + (unless nextchar + (reader-eof-error stream "after single-escape character")) + (push *ouch-ptr* escapes) + (ouch-read-buffer nextchar)) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-array attribute-hash-table) - (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (t (go SYMBOL))) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) MULT-ESCAPE (setq seen-multiple-escapes t) (do ((char (read-char stream t) (read-char stream t))) - ((multiple-escape-p char)) - (if (single-escape-p char) (setq char (read-char stream t))) - (push *ouch-ptr* escapes) - (ouch-read-buffer char)) + ((multiple-escape-p char)) + (if (single-escape-p char) (setq char (read-char stream t))) + (push *ouch-ptr* escapes) + (ouch-read-buffer char)) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-array attribute-hash-table) - (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (t (go SYMBOL))) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) COLON (casify-read-buffer escapes) (unless (zerop colons) - (%reader-error stream "too many colons in ~S" - (read-buffer-to-string))) + (%reader-error stream "too many colons in ~S" + (read-buffer-to-string))) (setq colons 1) (setq package-designator - (if (plusp *ouch-ptr*) - ;; FIXME: It seems inefficient to cons up a package - ;; designator string every time we read a symbol with an - ;; explicit package prefix. Perhaps we could implement - ;; a FIND-PACKAGE* function analogous to INTERN* - ;; and friends? - (read-buffer-to-string) - (if seen-multiple-escapes - (read-buffer-to-string) - *keyword-package*))) + (if (plusp *ouch-ptr*) + ;; FIXME: It seems inefficient to cons up a package + ;; designator string every time we read a symbol with an + ;; explicit package prefix. Perhaps we could implement + ;; a FIND-PACKAGE* function analogous to INTERN* + ;; and friends? + (read-buffer-to-string) + (if seen-multiple-escapes + (read-buffer-to-string) + *keyword-package*))) (reset-read-buffer) (setq escapes ()) (setq char (read-char stream nil nil)) (unless char (reader-eof-error stream "after reading a colon")) (case (char-class char attribute-array attribute-hash-table) - (#.+char-attr-delimiter+ - (unread-char char stream) - (%reader-error stream - "illegal terminating character after a colon: ~S" - char)) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go INTERN)) - (t (go SYMBOL))) + (#.+char-attr-delimiter+ + (unread-char char stream) + (%reader-error stream + "illegal terminating character after a colon: ~S" + char)) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go INTERN)) + (t (go SYMBOL))) INTERN (setq colons 2) (setq char (read-char stream nil nil)) (unless char - (reader-eof-error stream "after reading a colon")) + (reader-eof-error stream "after reading a colon")) (case (char-class char attribute-array attribute-hash-table) - (#.+char-attr-delimiter+ - (unread-char char stream) - (%reader-error stream - "illegal terminating character after a colon: ~S" - char)) - (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ - (%reader-error stream - "too many colons after ~S name" - package-designator)) - (t (go SYMBOL))) + (#.+char-attr-delimiter+ + (unread-char char stream) + (%reader-error stream + "illegal terminating character after a colon: ~S" + char)) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ + (%reader-error stream + "too many colons after ~S name" + package-designator)) + (t (go SYMBOL))) RETURN-SYMBOL (casify-read-buffer escapes) (let ((found (if package-designator - (find-package package-designator) - (sane-package)))) - (unless found - (error 'reader-package-error :stream stream - :format-arguments (list package-designator) - :format-control "package ~S not found")) - - (if (or (zerop colons) (= colons 2) (eq found *keyword-package*)) - (return (intern* *read-buffer* *ouch-ptr* found)) - (multiple-value-bind (symbol test) - (find-symbol* *read-buffer* *ouch-ptr* found) - (when (eq test :external) (return symbol)) - (let ((name (read-buffer-to-string))) - (with-simple-restart (continue "Use symbol anyway.") - (error 'reader-package-error :stream stream - :format-arguments (list name (package-name found)) - :format-control - (if test - "The symbol ~S is not external in the ~A package." - "Symbol ~S not found in the ~A package."))) - (return (intern name found))))))))) + (find-package package-designator) + (sane-package)))) + (unless found + (error 'reader-package-error :stream stream + :format-arguments (list package-designator) + :format-control "package ~S not found")) + + (if (or (zerop colons) (= colons 2) (eq found *keyword-package*)) + (return (intern* *read-buffer* *ouch-ptr* found)) + (multiple-value-bind (symbol test) + (find-symbol* *read-buffer* *ouch-ptr* found) + (when (eq test :external) (return symbol)) + (let ((name (read-buffer-to-string))) + (with-simple-restart (continue "Use symbol anyway.") + (error 'reader-package-error :stream stream + :format-arguments (list name (package-name found)) + :format-control + (if test + "The symbol ~S is not external in the ~A package." + "Symbol ~S not found in the ~A package."))) + (return (intern name found))))))))) ;;; for semi-external use: ;;; @@ -1207,12 +1207,12 @@ variables to allow for nested and thread safe reading." (defun read-extended-token (stream &optional (*readtable* *readtable*)) (let ((first-char (read-char stream nil nil t))) (cond (first-char - (multiple-value-bind (escapes colon) + (multiple-value-bind (escapes colon) (internal-read-extended-token stream first-char nil) - (casify-read-buffer escapes) - (values (read-buffer-to-string) (not (null escapes)) colon))) - (t - (values "" nil nil))))) + (casify-read-buffer escapes) + (values (read-buffer-to-string) (not (null escapes)) colon))) + (t + (values "" nil nil))))) ;;; for semi-external use: ;;; @@ -1257,20 +1257,20 @@ variables to allow for nested and thread safe reading." #!+sb-doc "the largest fixnum power of the base for MAKE-INTEGER") (declaim (simple-vector *integer-reader-safe-digits* - *integer-reader-base-power*)) + *integer-reader-base-power*)) #| (defun !cold-init-integer-reader () (do ((base 2 (1+ base))) ((> base 36)) (let ((digits - (do ((fix (truncate most-positive-fixnum base) - (truncate fix base)) - (digits 0 (1+ digits))) - ((zerop fix) digits)))) + (do ((fix (truncate most-positive-fixnum base) + (truncate fix base)) + (digits 0 (1+ digits))) + ((zerop fix) digits)))) (setf (aref *integer-reader-safe-digits* base) - digits - (aref *integer-reader-base-power* base) - (expt base digits))))) + digits + (aref *integer-reader-base-power* base) + (expt base digits))))) |# (defun make-integer () @@ -1278,31 +1278,31 @@ variables to allow for nested and thread safe reading." "Minimizes bignum-fixnum multiplies by reading a 'safe' number of digits, then multiplying by a power of the base and adding." (let* ((base *read-base*) - (digits-per (aref *integer-reader-safe-digits* base)) - (base-power (aref *integer-reader-base-power* base)) - (negativep nil) - (number 0)) + (digits-per (aref *integer-reader-safe-digits* base)) + (base-power (aref *integer-reader-base-power* base)) + (negativep nil) + (number 0)) (declare (type index digits-per base-power)) (read-unwind-read-buffer) (let ((char (inch-read-buffer))) (cond ((char= char #\-) - (setq negativep t)) - ((char= char #\+)) - (t (unread-buffer)))) + (setq negativep t)) + ((char= char #\+)) + (t (unread-buffer)))) (loop (let ((num 0)) (declare (type index num)) (dotimes (digit digits-per) - (let* ((ch (inch-read-buffer))) - (cond ((or (eofp ch) (char= ch #\.)) - (return-from make-integer - (let ((res - (if (zerop number) num - (+ num (* number - (expt base digit)))))) - (if negativep (- res) res)))) - (t (setq num (+ (digit-char-p ch base) - (the index (* num base)))))))) + (let* ((ch (inch-read-buffer))) + (cond ((or (eofp ch) (char= ch #\.)) + (return-from make-integer + (let ((res + (if (zerop number) num + (+ num (* number + (expt base digit)))))) + (if negativep (- res) res)))) + (t (setq num (+ (digit-char-p ch base) + (the index (* num base)))))))) (setq number (+ num (* number base-power))))))) (defun make-float (stream) @@ -1310,74 +1310,74 @@ variables to allow for nested and thread safe reading." ;; else after it. (read-unwind-read-buffer) (let ((negative-fraction nil) - (number 0) - (divisor 1) - (negative-exponent nil) - (exponent 0) - (float-char ()) - (char (inch-read-buffer))) + (number 0) + (divisor 1) + (negative-exponent nil) + (exponent 0) + (float-char ()) + (char (inch-read-buffer))) (if (cond ((char= char #\+) t) - ((char= char #\-) (setq negative-fraction t))) - ;; Flush it. - (setq char (inch-read-buffer))) + ((char= char #\-) (setq negative-fraction t))) + ;; Flush it. + (setq char (inch-read-buffer))) ;; Read digits before the dot. (do* ((ch char (inch-read-buffer)) - (dig (digit-char-p ch) (digit-char-p ch))) - ((not dig) (setq char ch)) + (dig (digit-char-p ch) (digit-char-p ch))) + ((not dig) (setq char ch)) (setq number (+ (* number 10) dig))) ;; Deal with the dot, if it's there. (when (char= char #\.) (setq char (inch-read-buffer)) ;; Read digits after the dot. (do* ((ch char (inch-read-buffer)) - (dig (and (not (eofp ch)) (digit-char-p ch)) - (and (not (eofp ch)) (digit-char-p ch)))) - ((not dig) (setq char ch)) - (setq divisor (* divisor 10)) - (setq number (+ (* number 10) dig)))) + (dig (and (not (eofp ch)) (digit-char-p ch)) + (and (not (eofp ch)) (digit-char-p ch)))) + ((not dig) (setq char ch)) + (setq divisor (* divisor 10)) + (setq number (+ (* number 10) dig)))) ;; Is there an exponent letter? (cond ((eofp char) - ;; If not, we've read the whole number. - (let ((num (make-float-aux number divisor - *read-default-float-format* - stream))) - (return-from make-float (if negative-fraction (- num) num)))) - ((exponent-letterp char) - (setq float-char char) - ;; Build exponent. - (setq char (inch-read-buffer)) - ;; Check leading sign. - (if (cond ((char= char #\+) t) - ((char= char #\-) (setq negative-exponent t))) - ;; Flush sign. - (setq char (inch-read-buffer))) - ;; Read digits for exponent. - (do* ((ch char (inch-read-buffer)) - (dig (and (not (eofp ch)) (digit-char-p ch)) - (and (not (eofp ch)) (digit-char-p ch)))) - ((not dig) - (setq exponent (if negative-exponent (- exponent) exponent))) - (setq exponent (+ (* exponent 10) dig))) - ;; Generate and return the float, depending on FLOAT-CHAR: - (let* ((float-format (case (char-upcase float-char) - (#\E *read-default-float-format*) - (#\S 'short-float) - (#\F 'single-float) - (#\D 'double-float) - (#\L 'long-float))) - (result (make-float-aux (* (expt 10 exponent) number) - divisor float-format stream))) - (return-from make-float - (if negative-fraction (- result) result)))) - (t (bug "bad fallthrough in floating point reader"))))) + ;; If not, we've read the whole number. + (let ((num (make-float-aux number divisor + *read-default-float-format* + stream))) + (return-from make-float (if negative-fraction (- num) num)))) + ((exponent-letterp char) + (setq float-char char) + ;; Build exponent. + (setq char (inch-read-buffer)) + ;; Check leading sign. + (if (cond ((char= char #\+) t) + ((char= char #\-) (setq negative-exponent t))) + ;; Flush sign. + (setq char (inch-read-buffer))) + ;; Read digits for exponent. + (do* ((ch char (inch-read-buffer)) + (dig (and (not (eofp ch)) (digit-char-p ch)) + (and (not (eofp ch)) (digit-char-p ch)))) + ((not dig) + (setq exponent (if negative-exponent (- exponent) exponent))) + (setq exponent (+ (* exponent 10) dig))) + ;; Generate and return the float, depending on FLOAT-CHAR: + (let* ((float-format (case (char-upcase float-char) + (#\E *read-default-float-format*) + (#\S 'short-float) + (#\F 'single-float) + (#\D 'double-float) + (#\L 'long-float))) + (result (make-float-aux (* (expt 10 exponent) number) + divisor float-format stream))) + (return-from make-float + (if negative-fraction (- result) result)))) + (t (bug "bad fallthrough in floating point reader"))))) (defun make-float-aux (number divisor float-format stream) (handler-case (coerce (/ number divisor) float-format) (type-error (c) (error 'reader-impossible-number-error - :error c :stream stream - :format-control "failed to build float")))) + :error c :stream stream + :format-control "failed to build float")))) (defun make-ratio (stream) ;; Assume *READ-BUFFER* contains a legal ratio. Build the number from @@ -1388,27 +1388,27 @@ variables to allow for nested and thread safe reading." (read-unwind-read-buffer) (setq char (inch-read-buffer)) (cond ((char= char #\+) - (setq char (inch-read-buffer))) - ((char= char #\-) - (setq char (inch-read-buffer)) - (setq negative-number t))) + (setq char (inch-read-buffer))) + ((char= char #\-) + (setq char (inch-read-buffer)) + (setq negative-number t))) ;; Get numerator. (do* ((ch char (inch-read-buffer)) - (dig (digit-char-p ch *read-base*) - (digit-char-p ch *read-base*))) - ((not dig)) - (setq numerator (+ (* numerator *read-base*) dig))) + (dig (digit-char-p ch *read-base*) + (digit-char-p ch *read-base*))) + ((not dig)) + (setq numerator (+ (* numerator *read-base*) dig))) ;; Get denominator. (do* ((ch (inch-read-buffer) (inch-read-buffer)) - (dig ())) - ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*))))) - (setq denominator (+ (* denominator *read-base*) dig))) + (dig ())) + ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*))))) + (setq denominator (+ (* denominator *read-base*) dig))) (let ((num (handler-case - (/ numerator denominator) - (arithmetic-error (c) - (error 'reader-impossible-number-error - :error c :stream stream - :format-control "failed to build ratio"))))) + (/ numerator denominator) + (arithmetic-error (c) + (error 'reader-impossible-number-error + :error c :stream stream + :format-control "failed to build ratio"))))) (if negative-number (- num) num)))) ;;;; cruft for dispatch macros @@ -1423,20 +1423,20 @@ variables to allow for nested and thread safe reading." (%reader-error stream "no dispatch function defined for ~S" sub-char))) (defun make-dispatch-macro-character (char &optional - (non-terminating-p nil) - (rt *readtable*)) + (non-terminating-p nil) + (rt *readtable*)) #!+sb-doc "Cause CHAR to become a dispatching macro character in readtable (which defaults to the current readtable). If NON-TERMINATING-P, the char will be non-terminating." (set-macro-character char #'read-dispatch-char non-terminating-p rt) (let* ((dalist (dispatch-tables rt)) - (dtable (cdr (find char dalist :test #'char= :key #'car)))) + (dtable (cdr (find char dalist :test #'char= :key #'car)))) (cond (dtable - (error "The dispatch character ~S already exists." char)) - (t - (setf (dispatch-tables rt) - (push (cons char (make-char-dispatch-table)) dalist))))) + (error "The dispatch character ~S already exists." char)) + (t + (setf (dispatch-tables rt) + (push (cons char (make-char-dispatch-table)) dalist))))) t) (defun set-dispatch-macro-character (disp-char sub-char function @@ -1450,11 +1450,11 @@ variables to allow for nested and thread safe reading." (error "SUB-CHAR must not be a decimal digit: ~S" sub-char)) (let* ((sub-char (char-upcase sub-char)) (rt (or rt *standard-readtable*)) - (dpair (find disp-char (dispatch-tables rt) - :test #'char= :key #'car))) + (dpair (find disp-char (dispatch-tables rt) + :test #'char= :key #'car))) (if dpair - (setf (gethash sub-char (cdr dpair)) (coerce function 'function)) - (error "~S is not a dispatch char." disp-char)))) + (setf (gethash sub-char (cdr dpair)) (coerce function 'function)) + (error "~S is not a dispatch char." disp-char)))) (defun get-dispatch-macro-character (disp-char sub-char &optional (rt *readtable*)) @@ -1472,41 +1472,41 @@ variables to allow for nested and thread safe reading." (defun read-dispatch-char (stream char) ;; Read some digits. (let ((numargp nil) - (numarg 0) - (sub-char ())) + (numarg 0) + (sub-char ())) (do* ((ch (read-char stream nil *eof-object*) - (read-char stream nil *eof-object*)) - (dig ())) - ((or (eofp ch) - (not (setq dig (digit-char-p ch)))) - ;; Take care of the extra char. - (if (eofp ch) - (reader-eof-error stream "inside dispatch character") - (setq sub-char (char-upcase ch)))) + (read-char stream nil *eof-object*)) + (dig ())) + ((or (eofp ch) + (not (setq dig (digit-char-p ch)))) + ;; Take care of the extra char. + (if (eofp ch) + (reader-eof-error stream "inside dispatch character") + (setq sub-char (char-upcase ch)))) (setq numargp t) (setq numarg (+ (* numarg 10) dig))) ;; Look up the function and call it. (let ((dpair (find char (dispatch-tables *readtable*) - :test #'char= :key #'car))) + :test #'char= :key #'car))) (if dpair - (funcall (the function + (funcall (the function (gethash sub-char (cdr dpair) #'dispatch-char-error)) - stream sub-char (if numargp numarg nil)) - (%reader-error stream "no dispatch table for dispatch char"))))) + stream sub-char (if numargp numarg nil)) + (%reader-error stream "no dispatch table for dispatch char"))))) ;;;; READ-FROM-STRING (defun read-from-string (string &optional (eof-error-p t) eof-value - &key (start 0) end - preserve-whitespace) + &key (start 0) end + preserve-whitespace) #!+sb-doc "The characters of string are successively given to the lisp reader and the lisp object built by the reader is returned. Macro chars will take effect." (declare (string string)) (with-array-data ((string string :offset-var offset) - (start start) - (end (%check-vector-sequence-bounds string start end))) + (start start) + (end (%check-vector-sequence-bounds string start end))) (let ((stream (make-string-input-stream string start end))) (values (if preserve-whitespace (read-preserving-whitespace stream eof-error-p eof-value) @@ -1522,54 +1522,54 @@ variables to allow for nested and thread safe reading." whitespace characters and then tries to parse an integer. The radix parameter must be between 2 and 36." (macrolet ((parse-error (format-control) - `(error 'simple-parse-error - :format-control ,format-control - :format-arguments (list string)))) + `(error 'simple-parse-error + :format-control ,format-control + :format-arguments (list string)))) (with-array-data ((string string :offset-var offset) - (start start) - (end (%check-vector-sequence-bounds string start end))) + (start start) + (end (%check-vector-sequence-bounds string start end))) (let ((index (do ((i start (1+ i))) - ((= i end) - (if junk-allowed - (return-from parse-integer (values nil end)) - (parse-error "no non-whitespace characters in string ~S."))) - (declare (fixnum i)) - (unless (whitespacep (char string i)) (return i)))) - (minusp nil) - (found-digit nil) - (result 0)) - (declare (fixnum index)) - (let ((char (char string index))) - (cond ((char= char #\-) - (setq minusp t) - (incf index)) - ((char= char #\+) - (incf index)))) - (loop - (when (= index end) (return nil)) - (let* ((char (char string index)) - (weight (digit-char-p char radix))) - (cond (weight - (setq result (+ weight (* result radix)) - found-digit t)) - (junk-allowed (return nil)) - ((whitespacep char) + ((= i end) + (if junk-allowed + (return-from parse-integer (values nil end)) + (parse-error "no non-whitespace characters in string ~S."))) + (declare (fixnum i)) + (unless (whitespacep (char string i)) (return i)))) + (minusp nil) + (found-digit nil) + (result 0)) + (declare (fixnum index)) + (let ((char (char string index))) + (cond ((char= char #\-) + (setq minusp t) + (incf index)) + ((char= char #\+) + (incf index)))) + (loop + (when (= index end) (return nil)) + (let* ((char (char string index)) + (weight (digit-char-p char radix))) + (cond (weight + (setq result (+ weight (* result radix)) + found-digit t)) + (junk-allowed (return nil)) + ((whitespacep char) (loop (incf index) (when (= index end) (return)) (unless (whitespacep (char string index)) - (parse-error "junk in string ~S"))) - (return nil)) - (t - (parse-error "junk in string ~S")))) - (incf index)) - (values - (if found-digit - (if minusp (- result) result) - (if junk-allowed - nil - (parse-error "no digits in string ~S"))) - (- index offset)))))) + (parse-error "junk in string ~S"))) + (return nil)) + (t + (parse-error "junk in string ~S")))) + (incf index)) + (values + (if found-digit + (if minusp (- result) result) + (if junk-allowed + nil + (parse-error "no digits in string ~S"))) + (- index offset)))))) ;;;; reader initialization code diff --git a/src/code/readtable.lisp b/src/code/readtable.lisp index 615bc98..c4b711a 100644 --- a/src/code/readtable.lisp +++ b/src/code/readtable.lisp @@ -45,11 +45,11 @@ (def!constant +char-attr-delimiter+ 14) ; (a fake for READ-UNQUALIFIED-TOKEN) (sb!xc:defstruct (readtable (:conc-name nil) - (:predicate readtablep) - ;; ANSI requires a CL:COPY-READTABLE to do - ;; a deep copy, so the DEFSTRUCT-generated - ;; default is not suitable. - (:copier nil)) + (:predicate readtablep) + ;; ANSI requires a CL:COPY-READTABLE to do + ;; a deep copy, so the DEFSTRUCT-generated + ;; default is not suitable. + (:copier nil)) #!+sb-doc "A READTABLE is a data structure that maps characters into syntax types for the Common Lisp expression reader." @@ -66,8 +66,8 @@ ;; constituents. (character-attribute-array (make-array base-char-code-limit - :element-type '(unsigned-byte 8) - :initial-element +char-attr-constituent+) + :element-type '(unsigned-byte 8) + :initial-element +char-attr-constituent+) :type attribute-table) (character-attribute-hash-table (make-hash-table) :type hash-table) ;; The CHARACTER-MACRO-TABLE is a vector of CHAR-CODE-LIMIT diff --git a/src/code/room.lisp b/src/code/room.lisp index 1116735..6033ac0 100644 --- a/src/code/room.lisp +++ b/src/code/room.lisp @@ -19,8 +19,8 @@ (name nil :type symbol) ;; kind of type (how we determine length) (kind (missing-arg) - :type (member :lowtag :fixed :header :vector - :string :code :closure :instance)) + :type (member :lowtag :fixed :header :vector + :string :code :closure :instance)) ;; length if fixed-length, shift amount for element size if :VECTOR (length nil :type (or fixnum null)))) @@ -30,10 +30,10 @@ (dolist (obj *primitive-objects*) (let ((widetag (primitive-object-widetag obj)) - (lowtag (primitive-object-lowtag obj)) - (name (primitive-object-name obj)) - (variable (primitive-object-variable-length-p obj)) - (size (primitive-object-size obj))) + (lowtag (primitive-object-lowtag obj)) + (name (primitive-object-name obj)) + (variable (primitive-object-variable-length-p obj)) + (size (primitive-object-size obj))) (cond ((not lowtag)) (;; KLUDGE described in dan_b message "Another one for the @@ -60,93 +60,93 @@ (eql name 'thread)) ((not widetag) (let ((info (make-room-info :name name - :kind :lowtag)) - (lowtag (symbol-value lowtag))) - (declare (fixnum lowtag)) - (dotimes (i 32) - (setf (svref *meta-room-info* (logior lowtag (ash i 3))) info)))) + :kind :lowtag)) + (lowtag (symbol-value lowtag))) + (declare (fixnum lowtag)) + (dotimes (i 32) + (setf (svref *meta-room-info* (logior lowtag (ash i 3))) info)))) (variable) (t (setf (svref *meta-room-info* (symbol-value widetag)) - (make-room-info :name name - :kind :fixed - :length size)))))) + (make-room-info :name name + :kind :fixed + :length size)))))) (dolist (code (list #!+sb-unicode complex-character-string-widetag complex-base-string-widetag simple-array-widetag - complex-bit-vector-widetag complex-vector-widetag - complex-array-widetag complex-vector-nil-widetag)) + complex-bit-vector-widetag complex-vector-widetag + complex-array-widetag complex-vector-nil-widetag)) (setf (svref *meta-room-info* code) - (make-room-info :name 'array-header - :kind :header))) + (make-room-info :name 'array-header + :kind :header))) (setf (svref *meta-room-info* bignum-widetag) (make-room-info :name 'bignum - :kind :header)) + :kind :header)) (setf (svref *meta-room-info* closure-header-widetag) (make-room-info :name 'closure - :kind :closure)) + :kind :closure)) (dolist (stuff '((simple-bit-vector-widetag . -3) - (simple-vector-widetag . 2) - (simple-array-unsigned-byte-2-widetag . -2) - (simple-array-unsigned-byte-4-widetag . -1) - (simple-array-unsigned-byte-7-widetag . 0) - (simple-array-unsigned-byte-8-widetag . 0) - (simple-array-unsigned-byte-15-widetag . 1) - (simple-array-unsigned-byte-16-widetag . 1) - (simple-array-unsigned-byte-31-widetag . 2) - (simple-array-unsigned-byte-32-widetag . 2) - (simple-array-unsigned-byte-60-widetag . 3) - (simple-array-unsigned-byte-63-widetag . 3) - (simple-array-unsigned-byte-64-widetag . 3) - (simple-array-signed-byte-8-widetag . 0) - (simple-array-signed-byte-16-widetag . 1) - (simple-array-unsigned-byte-29-widetag . 2) - (simple-array-signed-byte-30-widetag . 2) - (simple-array-signed-byte-32-widetag . 2) - (simple-array-signed-byte-61-widetag . 3) - (simple-array-signed-byte-64-widetag . 3) - (simple-array-single-float-widetag . 2) - (simple-array-double-float-widetag . 3) - (simple-array-complex-single-float-widetag . 3) - (simple-array-complex-double-float-widetag . 4))) + (simple-vector-widetag . 2) + (simple-array-unsigned-byte-2-widetag . -2) + (simple-array-unsigned-byte-4-widetag . -1) + (simple-array-unsigned-byte-7-widetag . 0) + (simple-array-unsigned-byte-8-widetag . 0) + (simple-array-unsigned-byte-15-widetag . 1) + (simple-array-unsigned-byte-16-widetag . 1) + (simple-array-unsigned-byte-31-widetag . 2) + (simple-array-unsigned-byte-32-widetag . 2) + (simple-array-unsigned-byte-60-widetag . 3) + (simple-array-unsigned-byte-63-widetag . 3) + (simple-array-unsigned-byte-64-widetag . 3) + (simple-array-signed-byte-8-widetag . 0) + (simple-array-signed-byte-16-widetag . 1) + (simple-array-unsigned-byte-29-widetag . 2) + (simple-array-signed-byte-30-widetag . 2) + (simple-array-signed-byte-32-widetag . 2) + (simple-array-signed-byte-61-widetag . 3) + (simple-array-signed-byte-64-widetag . 3) + (simple-array-single-float-widetag . 2) + (simple-array-double-float-widetag . 3) + (simple-array-complex-single-float-widetag . 3) + (simple-array-complex-double-float-widetag . 4))) (let* ((name (car stuff)) - (size (cdr stuff)) - (sname (string name))) + (size (cdr stuff)) + (sname (string name))) (when (boundp name) (setf (svref *meta-room-info* (symbol-value name)) - (make-room-info :name (intern (subseq sname - 0 - (mismatch sname "-WIDETAG" - :from-end t))) - :kind :vector - :length size))))) + (make-room-info :name (intern (subseq sname + 0 + (mismatch sname "-WIDETAG" + :from-end t))) + :kind :vector + :length size))))) (setf (svref *meta-room-info* simple-base-string-widetag) (make-room-info :name 'simple-base-string - :kind :string - :length 0)) + :kind :string + :length 0)) #!+sb-unicode (setf (svref *meta-room-info* simple-character-string-widetag) (make-room-info :name 'simple-character-string - :kind :string - :length 2)) + :kind :string + :length 2)) (setf (svref *meta-room-info* simple-array-nil-widetag) (make-room-info :name 'simple-array-nil - :kind :fixed - :length 2)) + :kind :fixed + :length 2)) (setf (svref *meta-room-info* code-header-widetag) (make-room-info :name 'code - :kind :code)) + :kind :code)) (setf (svref *meta-room-info* instance-header-widetag) (make-room-info :name 'instance - :kind :instance)) + :kind :instance)) ) ; EVAL-WHEN @@ -158,21 +158,21 @@ ;;; Since they're represented as counts of words, we should never ;;; need bignums to represent these: (declaim (type fixnum - *static-space-free-pointer* - *read-only-space-free-pointer*)) + *static-space-free-pointer* + *read-only-space-free-pointer*)) (defun space-bounds (space) (declare (type spaces space)) (ecase space (:static (values (int-sap static-space-start) - (int-sap (* *static-space-free-pointer* n-word-bytes)))) + (int-sap (* *static-space-free-pointer* n-word-bytes)))) (:read-only (values (int-sap read-only-space-start) - (int-sap (* *read-only-space-free-pointer* n-word-bytes)))) + (int-sap (* *read-only-space-free-pointer* n-word-bytes)))) (:dynamic (values (int-sap (current-dynamic-space-start)) - (dynamic-space-free-pointer))))) + (dynamic-space-free-pointer))))) ;;; Return the total number of bytes used in SPACE. (defun space-bytes (space) @@ -189,20 +189,20 @@ #!-sb-fluid (declaim (inline vector-total-size)) (defun vector-total-size (obj info) (let ((shift (room-info-length info)) - (len (+ (length (the (simple-array * (*)) obj)) - (ecase (room-info-kind info) - (:vector 0) - (:string 1))))) + (len (+ (length (the (simple-array * (*)) obj)) + (ecase (room-info-kind info) + (:vector 0) + (:string 1))))) (declare (type (integer -3 3) shift)) (round-to-dualword (+ (* vector-data-offset n-word-bytes) - (the fixnum - (if (minusp shift) - (ash (the fixnum - (+ len (the fixnum - (1- (the fixnum (ash 1 (- shift))))))) - shift) - (ash len shift))))))) + (the fixnum + (if (minusp shift) + (ash (the fixnum + (+ len (the fixnum + (1- (the fixnum (ash 1 (- shift))))))) + shift) + (ash len shift))))))) ;;; Iterate over all the objects allocated in SPACE, calling FUN with ;;; the object, the object's type code, and the object's total size in @@ -215,80 +215,80 @@ (declare (type system-area-pointer start end)) (declare (optimize (speed 3) (safety 0))) (let ((current start) - #+nil - (prev nil)) - (loop - (let* ((header (sap-ref-word current 0)) - (header-widetag (logand header #xFF)) - (info (svref *room-info* header-widetag))) - (cond - ((or (not info) - (eq (room-info-kind info) :lowtag)) - (let ((size (* cons-size n-word-bytes))) - (funcall fun - (make-lisp-obj (logior (sap-int current) - list-pointer-lowtag)) - list-pointer-lowtag - size) - (setq current (sap+ current size)))) - ((eql header-widetag closure-header-widetag) - (let* ((obj (make-lisp-obj (logior (sap-int current) - fun-pointer-lowtag))) - (size (round-to-dualword - (* (the fixnum (1+ (get-closure-length obj))) - n-word-bytes)))) - (funcall fun obj header-widetag size) - (setq current (sap+ current size)))) - ((eq (room-info-kind info) :instance) - (let* ((obj (make-lisp-obj - (logior (sap-int current) instance-pointer-lowtag))) - (size (round-to-dualword - (* (+ (%instance-length obj) 1) n-word-bytes)))) - (declare (fixnum size)) - (funcall fun obj header-widetag size) - (aver (zerop (logand size lowtag-mask))) - #+nil - (when (> size 200000) (break "implausible size, prev ~S" prev)) - #+nil - (setq prev current) - (setq current (sap+ current size)))) - (t - (let* ((obj (make-lisp-obj - (logior (sap-int current) other-pointer-lowtag))) - (size (ecase (room-info-kind info) - (:fixed - (aver (or (eql (room-info-length info) - (1+ (get-header-data obj))) - (floatp obj) - (simple-array-nil-p obj))) - (round-to-dualword - (* (room-info-length info) n-word-bytes))) - ((:vector :string) - (vector-total-size obj info)) - (:header - (round-to-dualword - (* (1+ (get-header-data obj)) n-word-bytes))) - (:code - (+ (the fixnum - (* (get-header-data obj) n-word-bytes)) - (round-to-dualword - (* (the fixnum (%code-code-size obj)) - n-word-bytes))))))) - (declare (fixnum size)) - (funcall fun obj header-widetag size) - (aver (zerop (logand size lowtag-mask))) - #+nil - (when (> size 200000) - (break "Implausible size, prev ~S" prev)) - #+nil - (setq prev current) - (setq current (sap+ current size)))))) - (unless (sap< current end) - (aver (sap= current end)) - (return))) - - #+nil - prev)))) + #+nil + (prev nil)) + (loop + (let* ((header (sap-ref-word current 0)) + (header-widetag (logand header #xFF)) + (info (svref *room-info* header-widetag))) + (cond + ((or (not info) + (eq (room-info-kind info) :lowtag)) + (let ((size (* cons-size n-word-bytes))) + (funcall fun + (make-lisp-obj (logior (sap-int current) + list-pointer-lowtag)) + list-pointer-lowtag + size) + (setq current (sap+ current size)))) + ((eql header-widetag closure-header-widetag) + (let* ((obj (make-lisp-obj (logior (sap-int current) + fun-pointer-lowtag))) + (size (round-to-dualword + (* (the fixnum (1+ (get-closure-length obj))) + n-word-bytes)))) + (funcall fun obj header-widetag size) + (setq current (sap+ current size)))) + ((eq (room-info-kind info) :instance) + (let* ((obj (make-lisp-obj + (logior (sap-int current) instance-pointer-lowtag))) + (size (round-to-dualword + (* (+ (%instance-length obj) 1) n-word-bytes)))) + (declare (fixnum size)) + (funcall fun obj header-widetag size) + (aver (zerop (logand size lowtag-mask))) + #+nil + (when (> size 200000) (break "implausible size, prev ~S" prev)) + #+nil + (setq prev current) + (setq current (sap+ current size)))) + (t + (let* ((obj (make-lisp-obj + (logior (sap-int current) other-pointer-lowtag))) + (size (ecase (room-info-kind info) + (:fixed + (aver (or (eql (room-info-length info) + (1+ (get-header-data obj))) + (floatp obj) + (simple-array-nil-p obj))) + (round-to-dualword + (* (room-info-length info) n-word-bytes))) + ((:vector :string) + (vector-total-size obj info)) + (:header + (round-to-dualword + (* (1+ (get-header-data obj)) n-word-bytes))) + (:code + (+ (the fixnum + (* (get-header-data obj) n-word-bytes)) + (round-to-dualword + (* (the fixnum (%code-code-size obj)) + n-word-bytes))))))) + (declare (fixnum size)) + (funcall fun obj header-widetag size) + (aver (zerop (logand size lowtag-mask))) + #+nil + (when (> size 200000) + (break "Implausible size, prev ~S" prev)) + #+nil + (setq prev current) + (setq current (sap+ current size)))))) + (unless (sap< current end) + (aver (sap= current end)) + (return))) + + #+nil + prev)))) ;;;; MEMORY-USAGE @@ -296,7 +296,7 @@ ;;; allocated in Space. (defun type-breakdown (space) (let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum)) - (counts (make-array 256 :initial-element 0 :element-type 'fixnum))) + (counts (make-array 256 :initial-element 0 :element-type 'fixnum))) (map-allocated-objects (lambda (obj type size) (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj)) @@ -306,24 +306,24 @@ (let ((totals (make-hash-table :test 'eq))) (dotimes (i 256) - (let ((total-count (aref counts i))) - (unless (zerop total-count) - (let* ((total-size (aref sizes i)) - (name (room-info-name (aref *room-info* i))) - (found (gethash name totals))) - (cond (found - (incf (first found) total-size) - (incf (second found) total-count)) - (t - (setf (gethash name totals) - (list total-size total-count name)))))))) + (let ((total-count (aref counts i))) + (unless (zerop total-count) + (let* ((total-size (aref sizes i)) + (name (room-info-name (aref *room-info* i))) + (found (gethash name totals))) + (cond (found + (incf (first found) total-size) + (incf (second found) total-count)) + (t + (setf (gethash name totals) + (list total-size total-count name)))))))) (collect ((totals-list)) - (maphash (lambda (k v) - (declare (ignore k)) - (totals-list v)) - totals) - (sort (totals-list) #'> :key #'first))))) + (maphash (lambda (k v) + (declare (ignore k)) + (totals-list v)) + totals) + (sort (totals-list) #'> :key #'first))))) ;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists ;;; (space-name . totals-for-space), where totals-for-space is the list @@ -332,74 +332,74 @@ (let ((summary (make-hash-table :test 'eq))) (dolist (space-total totals) (dolist (total (cdr space-total)) - (push (cons (car space-total) total) - (gethash (third total) summary)))) + (push (cons (car space-total) total) + (gethash (third total) summary)))) (collect ((summary-totals)) (maphash (lambda (k v) - (declare (ignore k)) - (let ((sum 0)) - (declare (fixnum sum)) - (dolist (space-total v) - (incf sum (first (cdr space-total)))) - (summary-totals (cons sum v)))) - summary) + (declare (ignore k)) + (let ((sum 0)) + (declare (fixnum sum)) + (dolist (space-total v) + (incf sum (first (cdr space-total)))) + (summary-totals (cons sum v)))) + summary) (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces) (let ((summary-total-bytes 0) - (summary-total-objects 0)) - (declare (fixnum summary-total-bytes summary-total-objects)) - (dolist (space-totals - (mapcar #'cdr (sort (summary-totals) #'> :key #'car))) - (let ((total-objects 0) - (total-bytes 0) - name) - (declare (fixnum total-objects total-bytes)) - (collect ((spaces)) - (dolist (space-total space-totals) - (let ((total (cdr space-total))) - (setq name (third total)) - (incf total-bytes (first total)) - (incf total-objects (second total)) - (spaces (cons (car space-total) (first total))))) - (format t "~%~A:~% ~:D bytes, ~:D object~:P" - name total-bytes total-objects) - (dolist (space (spaces)) - (format t ", ~W% ~(~A~)" - (round (* (cdr space) 100) total-bytes) - (car space))) - (format t ".~%") - (incf summary-total-bytes total-bytes) - (incf summary-total-objects total-objects)))) - (format t "~%Summary total:~% ~:D bytes, ~:D objects.~%" - summary-total-bytes summary-total-objects))))) + (summary-total-objects 0)) + (declare (fixnum summary-total-bytes summary-total-objects)) + (dolist (space-totals + (mapcar #'cdr (sort (summary-totals) #'> :key #'car))) + (let ((total-objects 0) + (total-bytes 0) + name) + (declare (fixnum total-objects total-bytes)) + (collect ((spaces)) + (dolist (space-total space-totals) + (let ((total (cdr space-total))) + (setq name (third total)) + (incf total-bytes (first total)) + (incf total-objects (second total)) + (spaces (cons (car space-total) (first total))))) + (format t "~%~A:~% ~:D bytes, ~:D object~:P" + name total-bytes total-objects) + (dolist (space (spaces)) + (format t ", ~W% ~(~A~)" + (round (* (cdr space) 100) total-bytes) + (car space))) + (format t ".~%") + (incf summary-total-bytes total-bytes) + (incf summary-total-objects total-objects)))) + (format t "~%Summary total:~% ~:D bytes, ~:D objects.~%" + summary-total-bytes summary-total-objects))))) ;;; Report object usage for a single space. (defun report-space-total (space-total cutoff) (declare (list space-total) (type (or single-float null) cutoff)) (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total)) (let* ((types (cdr space-total)) - (total-bytes (reduce #'+ (mapcar #'first types))) - (total-objects (reduce #'+ (mapcar #'second types))) - (cutoff-point (if cutoff - (truncate (* (float total-bytes) cutoff)) - 0)) - (reported-bytes 0) - (reported-objects 0)) + (total-bytes (reduce #'+ (mapcar #'first types))) + (total-objects (reduce #'+ (mapcar #'second types))) + (cutoff-point (if cutoff + (truncate (* (float total-bytes) cutoff)) + 0)) + (reported-bytes 0) + (reported-objects 0)) (declare (fixnum total-objects total-bytes cutoff-point reported-objects - reported-bytes)) + reported-bytes)) (loop for (bytes objects name) in types do (when (<= bytes cutoff-point) - (format t " ~10:D bytes for ~9:D other object~2:*~P.~%" - (- total-bytes reported-bytes) - (- total-objects reported-objects)) - (return)) + (format t " ~10:D bytes for ~9:D other object~2:*~P.~%" + (- total-bytes reported-bytes) + (- total-objects reported-objects)) + (return)) (incf reported-bytes bytes) (incf reported-objects objects) (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%" - bytes objects name)) + bytes objects name)) (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%" - total-bytes total-objects (car space-total)))) + total-bytes total-objects (car space-total)))) ;;; Print information about the heap memory in use. PRINT-SPACES is a ;;; list of the spaces to print detailed information for. @@ -410,19 +410,19 @@ ;;; true, CUTOFF is a fraction of the usage in a report below which ;;; types will be combined as OTHER. (defun memory-usage (&key print-spaces (count-spaces '(:dynamic)) - (print-summary t) cutoff) + (print-summary t) cutoff) (declare (type (or single-float null) cutoff)) (let* ((spaces (if (eq count-spaces t) - '(:static :dynamic :read-only) - count-spaces)) - (totals (mapcar (lambda (space) - (cons space (type-breakdown space))) - spaces))) + '(:static :dynamic :read-only) + count-spaces)) + (totals (mapcar (lambda (space) + (cons space (type-breakdown space))) + spaces))) (dolist (space-total totals) (when (or (eq print-spaces t) - (member (car space-total) print-spaces)) - (report-space-total space-total cutoff))) + (member (car space-total) print-spaces)) + (report-space-total space-total cutoff))) (when print-summary (print-summary spaces totals))) @@ -432,234 +432,234 @@ (defun count-no-ops (space) (declare (type spaces space)) (let ((code-words 0) - (no-ops 0) - (total-bytes 0)) + (no-ops 0) + (total-bytes 0)) (declare (fixnum code-words no-ops) - (type unsigned-byte total-bytes)) + (type unsigned-byte total-bytes)) (map-allocated-objects (lambda (obj type size) (declare (fixnum size) (optimize (safety 0))) (when (eql type code-header-widetag) - (incf total-bytes size) - (let ((words (truly-the fixnum (%code-code-size obj))) - (sap (truly-the system-area-pointer - (%primitive code-instructions obj)))) - (incf code-words words) - (dotimes (i words) - (when (zerop (sap-ref-word sap (* i n-word-bytes))) - (incf no-ops)))))) + (incf total-bytes size) + (let ((words (truly-the fixnum (%code-code-size obj))) + (sap (truly-the system-area-pointer + (%primitive code-instructions obj)))) + (incf code-words words) + (dotimes (i words) + (when (zerop (sap-ref-word sap (* i n-word-bytes))) + (incf no-ops)))))) space) (format t - "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%" - total-bytes code-words no-ops - (round (* no-ops 100) code-words))) + "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%" + total-bytes code-words no-ops + (round (* no-ops 100) code-words))) (values)) (defun descriptor-vs-non-descriptor-storage (&rest spaces) (let ((descriptor-words 0) - (non-descriptor-headers 0) - (non-descriptor-bytes 0)) + (non-descriptor-headers 0) + (non-descriptor-bytes 0)) (declare (type unsigned-byte descriptor-words non-descriptor-headers - non-descriptor-bytes)) + non-descriptor-bytes)) (dolist (space (or spaces '(:read-only :static :dynamic))) (declare (inline map-allocated-objects)) (map-allocated-objects (lambda (obj type size) - (declare (fixnum size) (optimize (safety 0))) - (case type - (#.code-header-widetag - (let ((inst-words (truly-the fixnum (%code-code-size obj)))) - (declare (type fixnum inst-words)) - (incf non-descriptor-bytes (* inst-words n-word-bytes)) - (incf descriptor-words - (- (truncate size n-word-bytes) inst-words)))) - ((#.bignum-widetag - #.single-float-widetag - #.double-float-widetag - #.simple-base-string-widetag + (declare (fixnum size) (optimize (safety 0))) + (case type + (#.code-header-widetag + (let ((inst-words (truly-the fixnum (%code-code-size obj)))) + (declare (type fixnum inst-words)) + (incf non-descriptor-bytes (* inst-words n-word-bytes)) + (incf descriptor-words + (- (truncate size n-word-bytes) inst-words)))) + ((#.bignum-widetag + #.single-float-widetag + #.double-float-widetag + #.simple-base-string-widetag #!+sb-unicode #.simple-character-string-widetag - #.simple-array-nil-widetag - #.simple-bit-vector-widetag - #.simple-array-unsigned-byte-2-widetag - #.simple-array-unsigned-byte-4-widetag - #.simple-array-unsigned-byte-8-widetag - #.simple-array-unsigned-byte-16-widetag - #.simple-array-unsigned-byte-32-widetag - #.simple-array-signed-byte-8-widetag - #.simple-array-signed-byte-16-widetag - ; #.simple-array-signed-byte-30-widetag - #.simple-array-signed-byte-32-widetag - #.simple-array-single-float-widetag - #.simple-array-double-float-widetag - #.simple-array-complex-single-float-widetag - #.simple-array-complex-double-float-widetag) - (incf non-descriptor-headers) - (incf non-descriptor-bytes (- size n-word-bytes))) - ((#.list-pointer-lowtag - #.instance-pointer-lowtag - #.ratio-widetag - #.complex-widetag - #.simple-array-widetag - #.simple-vector-widetag - #.complex-base-string-widetag - #.complex-vector-nil-widetag - #.complex-bit-vector-widetag - #.complex-vector-widetag - #.complex-array-widetag - #.closure-header-widetag - #.funcallable-instance-header-widetag - #.value-cell-header-widetag - #.symbol-header-widetag - #.sap-widetag - #.weak-pointer-widetag - #.instance-header-widetag) - (incf descriptor-words (truncate size n-word-bytes))) - (t - (error "bogus widetag: ~W" type)))) + #.simple-array-nil-widetag + #.simple-bit-vector-widetag + #.simple-array-unsigned-byte-2-widetag + #.simple-array-unsigned-byte-4-widetag + #.simple-array-unsigned-byte-8-widetag + #.simple-array-unsigned-byte-16-widetag + #.simple-array-unsigned-byte-32-widetag + #.simple-array-signed-byte-8-widetag + #.simple-array-signed-byte-16-widetag + ; #.simple-array-signed-byte-30-widetag + #.simple-array-signed-byte-32-widetag + #.simple-array-single-float-widetag + #.simple-array-double-float-widetag + #.simple-array-complex-single-float-widetag + #.simple-array-complex-double-float-widetag) + (incf non-descriptor-headers) + (incf non-descriptor-bytes (- size n-word-bytes))) + ((#.list-pointer-lowtag + #.instance-pointer-lowtag + #.ratio-widetag + #.complex-widetag + #.simple-array-widetag + #.simple-vector-widetag + #.complex-base-string-widetag + #.complex-vector-nil-widetag + #.complex-bit-vector-widetag + #.complex-vector-widetag + #.complex-array-widetag + #.closure-header-widetag + #.funcallable-instance-header-widetag + #.value-cell-header-widetag + #.symbol-header-widetag + #.sap-widetag + #.weak-pointer-widetag + #.instance-header-widetag) + (incf descriptor-words (truncate size n-word-bytes))) + (t + (error "bogus widetag: ~W" type)))) space)) (format t "~:D words allocated for descriptor objects.~%" - descriptor-words) + descriptor-words) (format t "~:D bytes data/~:D words header for non-descriptor objects.~%" - non-descriptor-bytes non-descriptor-headers) + non-descriptor-bytes non-descriptor-headers) (values))) ;;; Print a breakdown by instance type of all the instances allocated -;;; in SPACE. If TOP-N is true, print only information for the +;;; in SPACE. If TOP-N is true, print only information for the ;;; TOP-N types with largest usage. (defun instance-usage (space &key (top-n 15)) (declare (type spaces space) (type (or fixnum null) top-n)) (format t "~2&~@[Top ~W ~]~(~A~) instance types:~%" top-n space) (let ((totals (make-hash-table :test 'eq)) - (total-objects 0) - (total-bytes 0)) + (total-objects 0) + (total-bytes 0)) (declare (fixnum total-objects total-bytes)) (map-allocated-objects (lambda (obj type size) (declare (fixnum size) (optimize (speed 3) (safety 0))) (when (eql type instance-header-widetag) - (incf total-objects) - (incf total-bytes size) - (let* ((classoid (layout-classoid (%instance-ref obj 0))) - (found (gethash classoid totals))) - (cond (found - (incf (the fixnum (car found))) - (incf (the fixnum (cdr found)) size)) - (t - (setf (gethash classoid totals) (cons 1 size))))))) + (incf total-objects) + (incf total-bytes size) + (let* ((classoid (layout-classoid (%instance-ref obj 0))) + (found (gethash classoid totals))) + (cond (found + (incf (the fixnum (car found))) + (incf (the fixnum (cdr found)) size)) + (t + (setf (gethash classoid totals) (cons 1 size))))))) space) (collect ((totals-list)) (maphash (lambda (classoid what) - (totals-list (cons (prin1-to-string - (classoid-proper-name classoid)) - what))) - totals) + (totals-list (cons (prin1-to-string + (classoid-proper-name classoid)) + what))) + totals) (let ((sorted (sort (totals-list) #'> :key #'cddr)) - (printed-bytes 0) - (printed-objects 0)) - (declare (fixnum printed-bytes printed-objects)) - (dolist (what (if top-n - (subseq sorted 0 (min (length sorted) top-n)) - sorted)) - (let ((bytes (cddr what)) - (objects (cadr what))) - (incf printed-bytes bytes) - (incf printed-objects objects) - (format t " ~A: ~:D bytes, ~:D object~:P.~%" (car what) - bytes objects))) - - (let ((residual-objects (- total-objects printed-objects)) - (residual-bytes (- total-bytes printed-bytes))) - (unless (zerop residual-objects) - (format t " Other types: ~:D bytes, ~:D object~:P.~%" - residual-bytes residual-objects)))) + (printed-bytes 0) + (printed-objects 0)) + (declare (fixnum printed-bytes printed-objects)) + (dolist (what (if top-n + (subseq sorted 0 (min (length sorted) top-n)) + sorted)) + (let ((bytes (cddr what)) + (objects (cadr what))) + (incf printed-bytes bytes) + (incf printed-objects objects) + (format t " ~A: ~:D bytes, ~:D object~:P.~%" (car what) + bytes objects))) + + (let ((residual-objects (- total-objects printed-objects)) + (residual-bytes (- total-bytes printed-bytes))) + (unless (zerop residual-objects) + (format t " Other types: ~:D bytes, ~:D object~:P.~%" + residual-bytes residual-objects)))) (format t " ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%" - space total-bytes total-objects))) + space total-bytes total-objects))) (values)) ;;;; PRINT-ALLOCATED-OBJECTS (defun print-allocated-objects (space &key (percent 0) (pages 5) - type larger smaller count - (stream *standard-output*)) + type larger smaller count + (stream *standard-output*)) (declare (type (integer 0 99) percent) (type index pages) - (type stream stream) (type spaces space) - (type (or index null) type larger smaller count)) + (type stream stream) (type spaces space) + (type (or index null) type larger smaller count)) (multiple-value-bind (start-sap end-sap) (space-bounds space) (let* ((space-start (sap-int start-sap)) - (space-end (sap-int end-sap)) - (space-size (- space-end space-start)) - (pagesize (sb!sys:get-page-size)) - (start (+ space-start (round (* space-size percent) 100))) - (printed-conses (make-hash-table :test 'eq)) - (pages-so-far 0) - (count-so-far 0) - (last-page 0)) + (space-end (sap-int end-sap)) + (space-size (- space-end space-start)) + (pagesize (sb!sys:get-page-size)) + (start (+ space-start (round (* space-size percent) 100))) + (printed-conses (make-hash-table :test 'eq)) + (pages-so-far 0) + (count-so-far 0) + (last-page 0)) (declare (type (unsigned-byte 32) last-page start) - (fixnum pages-so-far count-so-far pagesize)) + (fixnum pages-so-far count-so-far pagesize)) (labels ((note-conses (x) - (unless (or (atom x) (gethash x printed-conses)) - (setf (gethash x printed-conses) t) - (note-conses (car x)) - (note-conses (cdr x))))) - (map-allocated-objects - (lambda (obj obj-type size) - (declare (optimize (safety 0))) - (let ((addr (get-lisp-obj-address obj))) - (when (>= addr start) - (when (if count - (> count-so-far count) - (> pages-so-far pages)) - (return-from print-allocated-objects (values))) - - (unless count - (let ((this-page (* (the (values (unsigned-byte 32) t) - (truncate addr pagesize)) - pagesize))) - (declare (type (unsigned-byte 32) this-page)) - (when (/= this-page last-page) - (when (< pages-so-far pages) - ;; FIXME: What is this? (ERROR "Argh..")? or - ;; a warning? or code that can be removed - ;; once the system is stable? or what? - (format stream "~2&**** Page ~W, address ~X:~%" - pages-so-far addr)) - (setq last-page this-page) - (incf pages-so-far)))) - - (when (and (or (not type) (eql obj-type type)) - (or (not smaller) (<= size smaller)) - (or (not larger) (>= size larger))) - (incf count-so-far) - (case type - (#.code-header-widetag - (let ((dinfo (%code-debug-info obj))) - (format stream "~&Code object: ~S~%" - (if dinfo - (sb!c::compiled-debug-info-name dinfo) - "No debug info.")))) - (#.symbol-header-widetag - (format stream "~&~S~%" obj)) - (#.list-pointer-lowtag - (unless (gethash obj printed-conses) - (note-conses obj) - (let ((*print-circle* t) - (*print-level* 5) - (*print-length* 10)) - (format stream "~&~S~%" obj)))) - (t - (fresh-line stream) - (let ((str (write-to-string obj :level 5 :length 10 - :pretty nil))) - (unless (eql type instance-header-widetag) - (format stream "~S: " (type-of obj))) - (format stream "~A~%" - (subseq str 0 (min (length str) 60)))))))))) - space)))) + (unless (or (atom x) (gethash x printed-conses)) + (setf (gethash x printed-conses) t) + (note-conses (car x)) + (note-conses (cdr x))))) + (map-allocated-objects + (lambda (obj obj-type size) + (declare (optimize (safety 0))) + (let ((addr (get-lisp-obj-address obj))) + (when (>= addr start) + (when (if count + (> count-so-far count) + (> pages-so-far pages)) + (return-from print-allocated-objects (values))) + + (unless count + (let ((this-page (* (the (values (unsigned-byte 32) t) + (truncate addr pagesize)) + pagesize))) + (declare (type (unsigned-byte 32) this-page)) + (when (/= this-page last-page) + (when (< pages-so-far pages) + ;; FIXME: What is this? (ERROR "Argh..")? or + ;; a warning? or code that can be removed + ;; once the system is stable? or what? + (format stream "~2&**** Page ~W, address ~X:~%" + pages-so-far addr)) + (setq last-page this-page) + (incf pages-so-far)))) + + (when (and (or (not type) (eql obj-type type)) + (or (not smaller) (<= size smaller)) + (or (not larger) (>= size larger))) + (incf count-so-far) + (case type + (#.code-header-widetag + (let ((dinfo (%code-debug-info obj))) + (format stream "~&Code object: ~S~%" + (if dinfo + (sb!c::compiled-debug-info-name dinfo) + "No debug info.")))) + (#.symbol-header-widetag + (format stream "~&~S~%" obj)) + (#.list-pointer-lowtag + (unless (gethash obj printed-conses) + (note-conses obj) + (let ((*print-circle* t) + (*print-level* 5) + (*print-length* 10)) + (format stream "~&~S~%" obj)))) + (t + (fresh-line stream) + (let ((str (write-to-string obj :level 5 :length 10 + :pretty nil))) + (unless (eql type instance-header-widetag) + (format stream "~S: " (type-of obj))) + (format stream "~A~%" + (subseq str 0 (min (length str) 60)))))))))) + space)))) (values)) ;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS @@ -678,25 +678,25 @@ stuff)) (defun list-allocated-objects (space &key type larger smaller count - test) + test) (declare (type spaces space) - (type (or index null) larger smaller type count) - (type (or function null) test) - (inline map-allocated-objects)) + (type (or index null) larger smaller type count) + (type (or function null) test) + (inline map-allocated-objects)) (unless *ignore-after* (setq *ignore-after* (cons 1 2))) (collect ((counted 0 1+)) (let ((res ())) (map-allocated-objects (lambda (obj obj-type size) - (declare (optimize (safety 0))) - (when (and (or (not type) (eql obj-type type)) - (or (not smaller) (<= size smaller)) - (or (not larger) (>= size larger)) - (or (not test) (funcall test obj))) - (setq res (maybe-cons space obj res)) - (when (and count (>= (counted) count)) - (return-from list-allocated-objects res)))) + (declare (optimize (safety 0))) + (when (and (or (not type) (eql obj-type type)) + (or (not smaller) (<= size smaller)) + (or (not larger) (>= size larger)) + (or (not test) (funcall test obj))) + (setq res (maybe-cons space obj res)) + (when (and count (>= (counted) count)) + (return-from list-allocated-objects res)))) space) res))) @@ -705,39 +705,39 @@ (unless *ignore-after* (setq *ignore-after* (cons 1 2))) (flet ((maybe-call (fun obj) - (when (valid-obj space obj) - (funcall fun obj)))) + (when (valid-obj space obj) + (funcall fun obj)))) (map-allocated-objects (lambda (obj obj-type size) (declare (optimize (safety 0)) (ignore obj-type size)) (typecase obj - (cons - (when (or (eq (car obj) object) - (eq (cdr obj) object)) - (maybe-call fun obj))) - (instance - (dotimes (i (%instance-length obj)) - (when (eq (%instance-ref obj i) object) - (maybe-call fun obj) - (return)))) - (code-component - (let ((length (get-header-data obj))) - (do ((i code-constants-offset (1+ i))) - ((= i length)) - (when (eq (code-header-ref obj i) object) - (maybe-call fun obj) - (return))))) - (simple-vector - (dotimes (i (length obj)) - (when (eq (svref obj i) object) - (maybe-call fun obj) - (return)))) - (symbol - (when (or (eq (symbol-name obj) object) - (eq (symbol-package obj) object) - (eq (symbol-plist obj) object) - (eq (symbol-value obj) object)) - (maybe-call fun obj))))) + (cons + (when (or (eq (car obj) object) + (eq (cdr obj) object)) + (maybe-call fun obj))) + (instance + (dotimes (i (%instance-length obj)) + (when (eq (%instance-ref obj i) object) + (maybe-call fun obj) + (return)))) + (code-component + (let ((length (get-header-data obj))) + (do ((i code-constants-offset (1+ i))) + ((= i length)) + (when (eq (code-header-ref obj i) object) + (maybe-call fun obj) + (return))))) + (simple-vector + (dotimes (i (length obj)) + (when (eq (svref obj i) object) + (maybe-call fun obj) + (return)))) + (symbol + (when (or (eq (symbol-name obj) object) + (eq (symbol-package obj) object) + (eq (symbol-plist obj) object) + (eq (symbol-value obj) object)) + (maybe-call fun obj))))) space))) (defun list-referencing-objects (space object) diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 45c0ccc..ed93ebf 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -66,18 +66,18 @@ (declare (type simple-base-string string)) (let ((=-pos (position #\= string :test #'equal))) (if =-pos - (list - (let* ((key-as-string (subseq string 0 =-pos)) - (key-as-upcase-string (string-upcase key-as-string)) - (key (keywordicate key-as-upcase-string)) - (val (subseq string (1+ =-pos)))) - (unless (string= key-as-string key-as-upcase-string) - (warn "smashing case of ~S in conversion to CMU-CL-style ~ + (list + (let* ((key-as-string (subseq string 0 =-pos)) + (key-as-upcase-string (string-upcase key-as-string)) + (key (keywordicate key-as-upcase-string)) + (val (subseq string (1+ =-pos)))) + (unless (string= key-as-string key-as-upcase-string) + (warn "smashing case of ~S in conversion to CMU-CL-style ~ environment alist" - string)) - (cons key val))) - (warn "no #\\= in ~S, eliding it in CMU-CL-style environment alist" - string)))) + string)) + (cons key val))) + (warn "no #\\= in ~S, eliding it in CMU-CL-style environment alist" + string)))) sbcl)) ;;; Convert from a CMU CL representation of a Unix environment to a @@ -101,44 +101,44 @@ "Return any available status information on child process. " (multiple-value-bind (pid status) (c-wait3 (logior (if do-not-hang - sb-unix:wnohang - 0) - (if check-for-stopped - sb-unix:wuntraced - 0)) - 0) + sb-unix:wnohang + 0) + (if check-for-stopped + sb-unix:wuntraced + 0)) + 0) (cond ((or (minusp pid) - (zerop pid)) - nil) - ((eql (ldb (byte 8 0) status) - sb-unix:wstopped) - (values pid - :stopped - (ldb (byte 8 8) status))) - ((zerop (ldb (byte 7 0) status)) - (values pid - :exited - (ldb (byte 8 8) status))) - (t - (let ((signal (ldb (byte 7 0) status))) - (values pid - (if (position signal - #.(vector - sb-unix:sigstop - sb-unix:sigtstp - sb-unix:sigttin - sb-unix:sigttou)) - :stopped - :signaled) - signal - (not (zerop (ldb (byte 1 7) status))))))))) + (zerop pid)) + nil) + ((eql (ldb (byte 8 0) status) + sb-unix:wstopped) + (values pid + :stopped + (ldb (byte 8 8) status))) + ((zerop (ldb (byte 7 0) status)) + (values pid + :exited + (ldb (byte 8 8) status))) + (t + (let ((signal (ldb (byte 7 0) status))) + (values pid + (if (position signal + #.(vector + sb-unix:sigstop + sb-unix:sigtstp + sb-unix:sigttin + sb-unix:sigttou)) + :stopped + :signaled) + signal + (not (zerop (ldb (byte 1 7) status))))))))) ;;;; process control stuff (defvar *active-processes* nil "List of process structures for all active processes.") -(defvar *active-processes-lock* +(defvar *active-processes-lock* (sb-thread:make-mutex :name "Lock for active processes.")) ;;; *ACTIVE-PROCESSES* can be accessed from multiple threads so a @@ -150,24 +150,24 @@ ,@body))) (defstruct (process (:copier nil)) - pid ; PID of child process + pid ; PID of child process %status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED - exit-code ; either exit code or signal - core-dumped ; T if a core image was dumped - pty ; stream to child's pty, or NIL - input ; stream to child's input, or NIL - output ; stream from child's output, or NIL - error ; stream from child's error output, or NIL - status-hook ; closure to call when PROC changes status - plist ; a place for clients to stash things + exit-code ; either exit code or signal + core-dumped ; T if a core image was dumped + pty ; stream to child's pty, or NIL + input ; stream to child's input, or NIL + output ; stream from child's output, or NIL + error ; stream from child's error output, or NIL + status-hook ; closure to call when PROC changes status + plist ; a place for clients to stash things cookie) ; list of the number of pipes from the subproc (defmethod print-object ((process process) stream) (print-unreadable-object (process stream :type t) (format stream - "~W ~S" - (process-pid process) - (process-status process))) + "~W ~S" + (process-pid process) + (process-status process))) process) (defun process-status (proc) @@ -180,13 +180,13 @@ "Wait for PROC to quit running for some reason. Returns PROC." (loop (case (process-status proc) - (:running) - (:stopped - (when check-for-stopped - (return))) - (t - (when (zerop (car (process-cookie proc))) - (return)))) + (:running) + (:stopped + (when check-for-stopped + (return))) + (t + (when (zerop (car (process-cookie proc))) + (return)))) (sb-sys:serve-all-events 1)) proc) @@ -195,12 +195,12 @@ (defun find-current-foreground-process (proc) (with-alien ((result sb-alien:int)) (multiple-value-bind - (wonp error) - (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc)) - sb-unix:TIOCGPGRP - (alien-sap (sb-alien:addr result))) + (wonp error) + (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc)) + sb-unix:TIOCGPGRP + (alien-sap (sb-alien:addr result))) (unless wonp - (error "TIOCPGRP ioctl failed: ~S" (strerror error))) + (error "TIOCPGRP ioctl failed: ~S" (strerror error))) result)) (process-pid proc)) @@ -210,48 +210,48 @@ :PTY-PROCESS-GROUP deliver the signal to whichever process group is currently in the foreground." (let ((pid (ecase whom - ((:pid :process-group) - (process-pid proc)) - (:pty-process-group - #-hpux - (find-current-foreground-process proc))))) + ((:pid :process-group) + (process-pid proc)) + (:pty-process-group + #-hpux + (find-current-foreground-process proc))))) (multiple-value-bind - (okay errno) - (case whom - #+hpux - (:pty-process-group - (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc)) - sb-unix:TIOCSIGSEND - (sb-sys:int-sap - signal))) - ((:process-group #-hpux :pty-process-group) - (sb-unix:unix-killpg pid signal)) - (t - (sb-unix:unix-kill pid signal))) + (okay errno) + (case whom + #+hpux + (:pty-process-group + (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc)) + sb-unix:TIOCSIGSEND + (sb-sys:int-sap + signal))) + ((:process-group #-hpux :pty-process-group) + (sb-unix:unix-killpg pid signal)) + (t + (sb-unix:unix-kill pid signal))) (cond ((not okay) - (values nil errno)) - ((and (eql pid (process-pid proc)) - (= signal sb-unix:sigcont)) - (setf (process-%status proc) :running) - (setf (process-exit-code proc) nil) - (when (process-status-hook proc) - (funcall (process-status-hook proc) proc)) - t) - (t - t))))) + (values nil errno)) + ((and (eql pid (process-pid proc)) + (= signal sb-unix:sigcont)) + (setf (process-%status proc) :running) + (setf (process-exit-code proc) nil) + (when (process-status-hook proc) + (funcall (process-status-hook proc) proc)) + t) + (t + t))))) (defun process-alive-p (proc) "Return T if the process is still alive, NIL otherwise." (let ((status (process-status proc))) (if (or (eq status :running) - (eq status :stopped)) - t - nil))) + (eq status :stopped)) + t + nil))) (defun process-close (proc) "Close all streams connected to PROC and stop maintaining the status slot." (macrolet ((frob (stream abort) - `(when ,stream (close ,stream :abort ,abort)))) + `(when ,stream (close ,stream :abort ,abort)))) (frob (process-pty proc) t) ; Don't FLUSH-OUTPUT to dead process, .. (frob (process-input proc) t) ; .. 'cause it will generate SIGPIPE. (frob (process-output proc) nil) @@ -268,9 +268,9 @@ (defun get-processes-status-changes () (loop (multiple-value-bind (pid what code core) - (wait3 t t) - (unless pid - (return)) + (wait3 t t) + (unless pid + (return)) (let ((proc (with-active-processes-lock () (find pid *active-processes* :key #'process-pid)))) (when proc @@ -302,38 +302,38 @@ (dolist (char '(#\p #\q)) (dotimes (digit 16) (let* ((master-name (coerce (format nil "/dev/pty~C~X" char digit) 'base-string)) - (master-fd (sb-unix:unix-open master-name - sb-unix:o_rdwr - #o666))) - (when master-fd - (let* ((slave-name (coerce (format nil "/dev/tty~C~X" char digit) 'base-string)) - (slave-fd (sb-unix:unix-open slave-name - sb-unix:o_rdwr - #o666))) - (when slave-fd - (return-from find-a-pty - (values master-fd - slave-fd - slave-name))) - (sb-unix:unix-close master-fd)))))) + (master-fd (sb-unix:unix-open master-name + sb-unix:o_rdwr + #o666))) + (when master-fd + (let* ((slave-name (coerce (format nil "/dev/tty~C~X" char digit) 'base-string)) + (slave-fd (sb-unix:unix-open slave-name + sb-unix:o_rdwr + #o666))) + (when slave-fd + (return-from find-a-pty + (values master-fd + slave-fd + slave-name))) + (sb-unix:unix-close master-fd)))))) (error "could not find a pty")) (defun open-pty (pty cookie) (when pty (multiple-value-bind - (master slave name) - (find-a-pty) + (master slave name) + (find-a-pty) (push master *close-on-error*) (push slave *close-in-parent*) (when (streamp pty) - (multiple-value-bind (new-fd errno) (sb-unix:unix-dup master) - (unless new-fd - (error "couldn't SB-UNIX:UNIX-DUP ~W: ~A" master (strerror errno))) - (push new-fd *close-on-error*) - (copy-descriptor-to-stream new-fd pty cookie))) + (multiple-value-bind (new-fd errno) (sb-unix:unix-dup master) + (unless new-fd + (error "couldn't SB-UNIX:UNIX-DUP ~W: ~A" master (strerror errno))) + (push new-fd *close-on-error*) + (copy-descriptor-to-stream new-fd pty cookie))) (values name - (sb-sys:make-fd-stream master :input t :output t - :dual-channel-p t))))) + (sb-sys:make-fd-stream master :input t :output t + :dual-channel-p t))))) (defmacro round-bytes-to-words (n) `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3))) @@ -342,40 +342,40 @@ ;; Make a pass over STRING-LIST to calculate the amount of memory ;; needed to hold the strvec. (let ((string-bytes 0) - ;; We need an extra for the null, and an extra 'cause exect - ;; clobbers argv[-1]. - (vec-bytes (* #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits) - (+ (length string-list) 2)))) + ;; We need an extra for the null, and an extra 'cause exect + ;; clobbers argv[-1]. + (vec-bytes (* #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits) + (+ (length string-list) 2)))) (declare (fixnum string-bytes vec-bytes)) (dolist (s string-list) (enforce-type s simple-string) (incf string-bytes (round-bytes-to-words (1+ (length s))))) ;; Now allocate the memory and fill it in. (let* ((total-bytes (+ string-bytes vec-bytes)) - (vec-sap (sb-sys:allocate-system-memory total-bytes)) - (string-sap (sap+ vec-sap vec-bytes)) - (i #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits))) + (vec-sap (sb-sys:allocate-system-memory total-bytes)) + (string-sap (sap+ vec-sap vec-bytes)) + (i #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits))) (declare (type (and unsigned-byte fixnum) total-bytes i) - (type sb-sys:system-area-pointer vec-sap string-sap)) + (type sb-sys:system-area-pointer vec-sap string-sap)) (dolist (s string-list) - (declare (simple-string s)) - (let ((n (length s))) - ;; Blast the string into place. - (sb-kernel:copy-ub8-to-system-area (the simple-base-string + (declare (simple-string s)) + (let ((n (length s))) + ;; Blast the string into place. + (sb-kernel:copy-ub8-to-system-area (the simple-base-string ;; FIXME (coerce s 'simple-base-string)) 0 string-sap 0 (1+ n)) - ;; Blast the pointer to the string into place. - (setf (sap-ref-sap vec-sap i) string-sap) - (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n)))) - (incf i #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits)))) + ;; Blast the pointer to the string into place. + (setf (sap-ref-sap vec-sap i) string-sap) + (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n)))) + (incf i #.(/ sb-vm::n-machine-word-bits sb-vm::n-byte-bits)))) ;; Blast in the last null pointer. (setf (sap-ref-sap vec-sap i) (int-sap 0)) (values vec-sap (sap+ vec-sap #.(/ sb-vm::n-machine-word-bits - sb-vm::n-byte-bits)) - total-bytes)))) + sb-vm::n-byte-bits)) + total-bytes)))) (defmacro with-c-strvec ((var str-list) &body body) (with-unique-names (sap size) @@ -383,9 +383,9 @@ (,sap ,var ,size) (string-list-to-c-strvec ,str-list) (unwind-protect - (progn - ,@body) - (sb-sys:deallocate-system-memory ,sap ,size))))) + (progn + ,@body) + (sb-sys:deallocate-system-memory ,sap ,size))))) (sb-alien:define-alien-routine spawn sb-alien:int (program sb-alien:c-string) @@ -401,23 +401,23 @@ (declare (type simple-string unix-filename)) (setf unix-filename (coerce unix-filename 'base-string)) (values (and (eq (sb-unix:unix-file-kind unix-filename) :file) - (sb-unix:unix-access unix-filename sb-unix:x_ok)))) + (sb-unix:unix-access unix-filename sb-unix:x_ok)))) (defun find-executable-in-search-path (pathname - &optional - (search-path (posix-getenv "PATH"))) + &optional + (search-path (posix-getenv "PATH"))) "Find the first executable file matching PATHNAME in any of the colon-separated list of pathnames SEARCH-PATH" (loop for end = (position #\: search-path :start (if end (1+ end) 0)) - and start = 0 then (and end (1+ end)) - while start - ;; the truename of a file naming a directory is the - ;; directory, at least until pfdietz comes along and says why - ;; that's noncompliant -- CSR, c. 2003-08-10 - for truename = (probe-file (subseq search-path start end)) - for fullpath = (when truename (merge-pathnames pathname truename)) - when (and fullpath - (unix-filename-is-executable-p (namestring fullpath))) - return fullpath)) + and start = 0 then (and end (1+ end)) + while start + ;; the truename of a file naming a directory is the + ;; directory, at least until pfdietz comes along and says why + ;; that's noncompliant -- CSR, c. 2003-08-10 + for truename = (probe-file (subseq search-path start end)) + for fullpath = (when truename (merge-pathnames pathname truename)) + when (and fullpath + (unix-filename-is-executable-p (namestring fullpath))) + return fullpath)) ;;; FIXME: There shouldn't be two semiredundant versions of the ;;; documentation. Since this is a public extension function, the @@ -437,7 +437,7 @@ ;;; -- T: Just leave fd 0 alone. Pretty simple. ;;; -- "file": Read from the file. We need to open the file and ;;; pull the descriptor out of the stream. The parent should close -;;; this stream after the child is up and running to free any +;;; this stream after the child is up and running to free any ;;; storage used in the parent. ;;; -- NIL: Same as "file", but use "/dev/null" as the file. ;;; -- :STREAM: Use Unix pipe() to create two descriptors. Use @@ -446,7 +446,7 @@ ;;; the child. The parent must close the readable descriptor for ;;; EOF to be passed up correctly. ;;; -- a stream: If it's a fd-stream, just pull the descriptor out -;;; of it. Otherwise make a pipe as in :STREAM, and copy +;;; of it. Otherwise make a pipe as in :STREAM, and copy ;;; everything across. ;;; ;;; For output, there are five options: @@ -463,22 +463,22 @@ ;;; RUN-PROGRAM returns a PROCESS structure for the process if ;;; the fork worked, and NIL if it did not. (defun run-program (program args - &key - (env nil env-p) - (environment (if env-p - (unix-environment-sbcl-from-cmucl env) - (posix-environ)) - environment-p) - (wait t) - search - pty - input - if-input-does-not-exist - output - (if-output-exists :error) - (error :output) - (if-error-exists :error) - status-hook) + &key + (env nil env-p) + (environment (if env-p + (unix-environment-sbcl-from-cmucl env) + (posix-environ)) + environment-p) + (wait t) + search + pty + input + if-input-does-not-exist + output + (if-output-exists :error) + (error :output) + (if-error-exists :error) + status-hook) "RUN-PROGRAM creates a new Unix process running the Unix program found in the file specified by the PROGRAM argument. ARGS are the standard arguments that can be passed to a Unix program. For no arguments, use NIL @@ -515,38 +515,38 @@ NIL, continue running Lisp until the program finishes. :PTY Either T, NIL, or a stream. Unless NIL, the subprocess is established - under a PTY. If :pty is a stream, all output to this pty is sent to - this stream, otherwise the PROCESS-PTY slot is filled in with a stream - connected to pty that can read output and write input. + under a PTY. If :pty is a stream, all output to this pty is sent to + this stream, otherwise the PROCESS-PTY slot is filled in with a stream + connected to pty that can read output and write input. :INPUT Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard - input for the current process is inherited. If NIL, /dev/null - is used. If a pathname, the file so specified is used. If a stream, - all the input is read from that stream and send to the subprocess. If - :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends - its output to the process. Defaults to NIL. + input for the current process is inherited. If NIL, /dev/null + is used. If a pathname, the file so specified is used. If a stream, + all the input is read from that stream and send to the subprocess. If + :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends + its output to the process. Defaults to NIL. :IF-INPUT-DOES-NOT-EXIST (when :INPUT is the name of a file) can be one of: :ERROR to generate an error :CREATE to create an empty file NIL (the default) to return NIL from RUN-PROGRAM - :OUTPUT + :OUTPUT Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard - output for the current process is inherited. If NIL, /dev/null - is used. If a pathname, the file so specified is used. If a stream, - all the output from the process is written to this stream. If - :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can - be read to get the output. Defaults to NIL. + output for the current process is inherited. If NIL, /dev/null + is used. If a pathname, the file so specified is used. If a stream, + all the output from the process is written to this stream. If + :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can + be read to get the output. Defaults to NIL. :IF-OUTPUT-EXISTS (when :OUTPUT is the name of a file) can be one of: :ERROR (the default) to generate an error :SUPERSEDE to supersede the file with output from the program - :APPEND to append output from the program to the file + :APPEND to append output from the program to the file NIL to return NIL from RUN-PROGRAM, without doing anything :ERROR and :IF-ERROR-EXISTS Same as :OUTPUT and :IF-OUTPUT-EXISTS, except that :ERROR can also be - specified as :OUTPUT in which case all error output is routed to the - same place as normal output. + specified as :OUTPUT in which case all error output is routed to the + same place as normal output. :STATUS-HOOK This is a function the system calls whenever the status of the process changes. The function takes the process as an argument." @@ -558,71 +558,71 @@ ;; Prepend the program to the argument list. (push (namestring program) args) (let (;; Clear various specials used by GET-DESCRIPTOR-FOR to - ;; communicate cleanup info. - *close-on-error* - *close-in-parent* - *handlers-installed* - ;; Establish PROC at this level so that we can return it. - proc - ;; It's friendly to allow the caller to pass any string - ;; designator, but internally we'd like SIMPLE-STRINGs. - (simple-args (mapcar (lambda (x) (coerce x 'simple-string)) args))) + ;; communicate cleanup info. + *close-on-error* + *close-in-parent* + *handlers-installed* + ;; Establish PROC at this level so that we can return it. + proc + ;; It's friendly to allow the caller to pass any string + ;; designator, but internally we'd like SIMPLE-STRINGs. + (simple-args (mapcar (lambda (x) (coerce x 'simple-string)) args))) (unwind-protect - (let ((pfile - (if search - (let ((p (find-executable-in-search-path program))) - (and p (unix-namestring p t))) - (unix-namestring program t))) - (cookie (list 0))) - (unless pfile - (error "no such program: ~S" program)) - (unless (unix-filename-is-executable-p pfile) - (error "not executable: ~S" program)) - (multiple-value-bind (stdin input-stream) - (get-descriptor-for input cookie - :direction :input - :if-does-not-exist if-input-does-not-exist) - (multiple-value-bind (stdout output-stream) - (get-descriptor-for output cookie - :direction :output - :if-exists if-output-exists) - (multiple-value-bind (stderr error-stream) - (if (eq error :output) - (values stdout output-stream) - (get-descriptor-for error cookie - :direction :output - :if-exists if-error-exists)) - (multiple-value-bind (pty-name pty-stream) - (open-pty pty cookie) - ;; Make sure we are not notified about the child - ;; death before we have installed the PROCESS - ;; structure in *ACTIVE-PROCESSES*. - (with-active-processes-lock () - (with-c-strvec (args-vec simple-args) - (with-c-strvec (environment-vec environment) - (let ((child-pid - (without-gcing - (spawn pfile args-vec environment-vec pty-name - stdin stdout stderr)))) - (when (< child-pid 0) - (error "couldn't fork child process: ~A" - (strerror))) - (setf proc (make-process :pid child-pid - :%status :running - :pty pty-stream - :input input-stream - :output output-stream - :error error-stream - :status-hook status-hook - :cookie cookie)) - (push proc *active-processes*)))))))))) + (let ((pfile + (if search + (let ((p (find-executable-in-search-path program))) + (and p (unix-namestring p t))) + (unix-namestring program t))) + (cookie (list 0))) + (unless pfile + (error "no such program: ~S" program)) + (unless (unix-filename-is-executable-p pfile) + (error "not executable: ~S" program)) + (multiple-value-bind (stdin input-stream) + (get-descriptor-for input cookie + :direction :input + :if-does-not-exist if-input-does-not-exist) + (multiple-value-bind (stdout output-stream) + (get-descriptor-for output cookie + :direction :output + :if-exists if-output-exists) + (multiple-value-bind (stderr error-stream) + (if (eq error :output) + (values stdout output-stream) + (get-descriptor-for error cookie + :direction :output + :if-exists if-error-exists)) + (multiple-value-bind (pty-name pty-stream) + (open-pty pty cookie) + ;; Make sure we are not notified about the child + ;; death before we have installed the PROCESS + ;; structure in *ACTIVE-PROCESSES*. + (with-active-processes-lock () + (with-c-strvec (args-vec simple-args) + (with-c-strvec (environment-vec environment) + (let ((child-pid + (without-gcing + (spawn pfile args-vec environment-vec pty-name + stdin stdout stderr)))) + (when (< child-pid 0) + (error "couldn't fork child process: ~A" + (strerror))) + (setf proc (make-process :pid child-pid + :%status :running + :pty pty-stream + :input input-stream + :output output-stream + :error error-stream + :status-hook status-hook + :cookie cookie)) + (push proc *active-processes*)))))))))) (dolist (fd *close-in-parent*) - (sb-unix:unix-close fd)) + (sb-unix:unix-close fd)) (unless proc - (dolist (fd *close-on-error*) - (sb-unix:unix-close fd)) - (dolist (handler *handlers-installed*) - (sb-sys:remove-fd-handler handler)))) + (dolist (fd *close-on-error*) + (sb-unix:unix-close fd)) + (dolist (handler *handlers-installed*) + (sb-sys:remove-fd-handler handler)))) (when (and wait proc) (process-wait proc)) proc)) @@ -633,141 +633,141 @@ (defun copy-descriptor-to-stream (descriptor stream cookie) (incf (car cookie)) (let ((string (make-string 256 :element-type 'base-char)) - handler) + handler) (setf handler - (sb-sys:add-fd-handler - descriptor - :input (lambda (fd) - (declare (ignore fd)) - (loop - (unless handler - (return)) - (multiple-value-bind - (result readable/errno) - (sb-unix:unix-select (1+ descriptor) - (ash 1 descriptor) - 0 0 0) - (cond ((null result) - (error "~@" - (strerror readable/errno))) - ((zerop result) - (return)))) - (sb-alien:with-alien ((buf (sb-alien:array - sb-alien:char - 256))) - (multiple-value-bind - (count errno) - (sb-unix:unix-read descriptor - (alien-sap buf) - 256) - (cond ((or (and (null count) - (eql errno sb-unix:eio)) - (eql count 0)) - (sb-sys:remove-fd-handler handler) - (setf handler nil) - (decf (car cookie)) - (sb-unix:unix-close descriptor) - (return)) - ((null count) - (sb-sys:remove-fd-handler handler) - (setf handler nil) - (decf (car cookie)) - (error - "~@" - (strerror errno))) - (t - (sb-kernel:copy-ub8-from-system-area - (alien-sap buf) 0 - string 0 + (strerror errno))) + (t + (sb-kernel:copy-ub8-from-system-area + (alien-sap buf) 0 + string 0 count) - (write-string string stream - :end count))))))))))) + (write-string string stream + :end count))))))))))) ;;; Find a file descriptor to use for object given the direction. ;;; Returns the descriptor. If object is :STREAM, returns the created ;;; stream as the second value. (defun get-descriptor-for (object - cookie - &rest keys - &key direction - &allow-other-keys) + cookie + &rest keys + &key direction + &allow-other-keys) (cond ((eq object t) - ;; No new descriptor is needed. - (values -1 nil)) - ((eq object nil) - ;; Use /dev/null. - (multiple-value-bind - (fd errno) - (sb-unix:unix-open #.(coerce "/dev/null" 'base-string) - (case direction - (:input sb-unix:o_rdonly) - (:output sb-unix:o_wronly) - (t sb-unix:o_rdwr)) - #o666) - (unless fd - (error "~@" - (strerror errno))) - (push fd *close-in-parent*) - (values fd nil))) - ((eq object :stream) - (multiple-value-bind (read-fd write-fd) (sb-unix:unix-pipe) - (unless read-fd - (error "couldn't create pipe: ~A" (strerror write-fd))) - (case direction - (:input - (push read-fd *close-in-parent*) - (push write-fd *close-on-error*) - (let ((stream (sb-sys:make-fd-stream write-fd :output t))) - (values read-fd stream))) - (:output - (push read-fd *close-on-error*) - (push write-fd *close-in-parent*) - (let ((stream (sb-sys:make-fd-stream read-fd :input t))) - (values write-fd stream))) - (t - (sb-unix:unix-close read-fd) - (sb-unix:unix-close write-fd) - (error "Direction must be either :INPUT or :OUTPUT, not ~S." - direction))))) - ((or (pathnamep object) (stringp object)) - (with-open-stream (file (apply #'open object keys)) - (multiple-value-bind - (fd errno) - (sb-unix:unix-dup (sb-sys:fd-stream-fd file)) - (cond (fd - (push fd *close-in-parent*) - (values fd nil)) - (t - (error "couldn't duplicate file descriptor: ~A" - (strerror errno))))))) - ((sb-sys:fd-stream-p object) - (values (sb-sys:fd-stream-fd object) nil)) - ((streamp object) - (ecase direction - (:input - ;; FIXME: We could use a better way of setting up - ;; temporary files, both here and in LOAD-FOREIGN. - (dotimes (count - 256 - (error "could not open a temporary file in /tmp")) - (let* ((name (coerce (format nil "/tmp/.run-program-~D" count) 'base-string)) - (fd (sb-unix:unix-open name - (logior sb-unix:o_rdwr - sb-unix:o_creat - sb-unix:o_excl) - #o666))) - (sb-unix:unix-unlink name) - (when fd - (let ((newline (string #\Newline))) - (loop - (multiple-value-bind - (line no-cr) - (read-line object nil nil) - (unless line - (return)) - (sb-unix:unix-write + ;; No new descriptor is needed. + (values -1 nil)) + ((eq object nil) + ;; Use /dev/null. + (multiple-value-bind + (fd errno) + (sb-unix:unix-open #.(coerce "/dev/null" 'base-string) + (case direction + (:input sb-unix:o_rdonly) + (:output sb-unix:o_wronly) + (t sb-unix:o_rdwr)) + #o666) + (unless fd + (error "~@" + (strerror errno))) + (push fd *close-in-parent*) + (values fd nil))) + ((eq object :stream) + (multiple-value-bind (read-fd write-fd) (sb-unix:unix-pipe) + (unless read-fd + (error "couldn't create pipe: ~A" (strerror write-fd))) + (case direction + (:input + (push read-fd *close-in-parent*) + (push write-fd *close-on-error*) + (let ((stream (sb-sys:make-fd-stream write-fd :output t))) + (values read-fd stream))) + (:output + (push read-fd *close-on-error*) + (push write-fd *close-in-parent*) + (let ((stream (sb-sys:make-fd-stream read-fd :input t))) + (values write-fd stream))) + (t + (sb-unix:unix-close read-fd) + (sb-unix:unix-close write-fd) + (error "Direction must be either :INPUT or :OUTPUT, not ~S." + direction))))) + ((or (pathnamep object) (stringp object)) + (with-open-stream (file (apply #'open object keys)) + (multiple-value-bind + (fd errno) + (sb-unix:unix-dup (sb-sys:fd-stream-fd file)) + (cond (fd + (push fd *close-in-parent*) + (values fd nil)) + (t + (error "couldn't duplicate file descriptor: ~A" + (strerror errno))))))) + ((sb-sys:fd-stream-p object) + (values (sb-sys:fd-stream-fd object) nil)) + ((streamp object) + (ecase direction + (:input + ;; FIXME: We could use a better way of setting up + ;; temporary files, both here and in LOAD-FOREIGN. + (dotimes (count + 256 + (error "could not open a temporary file in /tmp")) + (let* ((name (coerce (format nil "/tmp/.run-program-~D" count) 'base-string)) + (fd (sb-unix:unix-open name + (logior sb-unix:o_rdwr + sb-unix:o_creat + sb-unix:o_excl) + #o666))) + (sb-unix:unix-unlink name) + (when fd + (let ((newline (string #\Newline))) + (loop + (multiple-value-bind + (line no-cr) + (read-line object nil nil) + (unless line + (return)) + (sb-unix:unix-write fd ;; FIXME: this really should be ;; (STRING-TO-OCTETS :EXTERNAL-FORMAT ...). @@ -777,20 +777,20 @@ ;; similar should happen on :OUTPUT, too. (map '(vector (unsigned-byte 8)) #'char-code line) 0 (length line)) - (if no-cr - (return) - (sb-unix:unix-write fd newline 0 1))))) - (sb-unix:unix-lseek fd 0 sb-unix:l_set) - (push fd *close-in-parent*) - (return (values fd nil)))))) - (:output - (multiple-value-bind (read-fd write-fd) - (sb-unix:unix-pipe) - (unless read-fd - (error "couldn't create pipe: ~S" (strerror write-fd))) - (copy-descriptor-to-stream read-fd object cookie) - (push read-fd *close-on-error*) - (push write-fd *close-in-parent*) - (values write-fd nil))))) - (t - (error "invalid option to RUN-PROGRAM: ~S" object)))) + (if no-cr + (return) + (sb-unix:unix-write fd newline 0 1))))) + (sb-unix:unix-lseek fd 0 sb-unix:l_set) + (push fd *close-in-parent*) + (return (values fd nil)))))) + (:output + (multiple-value-bind (read-fd write-fd) + (sb-unix:unix-pipe) + (unless read-fd + (error "couldn't create pipe: ~S" (strerror write-fd))) + (copy-descriptor-to-stream read-fd object cookie) + (push read-fd *close-on-error*) + (push write-fd *close-in-parent*) + (values write-fd nil))))) + (t + (error "invalid option to RUN-PROGRAM: ~S" object)))) diff --git a/src/code/save.lisp b/src/code/save.lisp index 8cefec9..defb53a 100644 --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -27,10 +27,10 @@ ;;; image to make a running Lisp, the memory never gets reclaimed. ;;; (But with the PURIFY option it seems to work OK.) (defun save-lisp-and-die (core-file-name &key - (toplevel #'toplevel-init) - (purify t) - (root-structures ()) - (environment-name "auxiliary")) + (toplevel #'toplevel-init) + (purify t) + (root-structures ()) + (environment-name "auxiliary")) #!+sb-doc "Save a \"core image\", i.e. enough information to restart a Lisp process later in the same state, in the file of the specified name. @@ -99,24 +99,24 @@ sufficiently motivated to do lengthy fixes." ;; SAVE-LISP-AND-DIE.) (if purify (purify :root-structures root-structures - :environment-name environment-name) + :environment-name environment-name) #-gencgc (gc) #+gencgc (gc :full t)) (flet ((restart-lisp () (handling-end-of-the-world - (reinit) - (funcall toplevel)))) + (reinit) + (funcall toplevel)))) ;; FIXME: Perhaps WITHOUT-GCING should be wrapped around the ;; LET as well, to avoid the off chance of an interrupt triggering ;; GC and making our saved RESTART-LISP address invalid? (without-gcing (save (unix-namestring core-file-name nil) - (get-lisp-obj-address #'restart-lisp))))) + (get-lisp-obj-address #'restart-lisp))))) (defun deinit () (dolist (hook *save-hooks*) (with-simple-restart (continue "Skip this save hook.") (funcall hook))) - (when (fboundp 'cancel-finalization) + (when (fboundp 'cancel-finalization) (cancel-finalization sb!sys:*tty*)) (profile-deinit) (debug-deinit) diff --git a/src/code/sc-offset.lisp b/src/code/sc-offset.lisp index 001367c..b05c9b7 100644 --- a/src/code/sc-offset.lisp +++ b/src/code/sc-offset.lisp @@ -22,7 +22,7 @@ (defmacro make-sc-offset (scn offset) `(dpb ,scn sc-offset-scn-byte - (dpb ,offset sc-offset-offset-byte 0))) + (dpb ,offset sc-offset-offset-byte 0))) (defmacro sc-offset-scn (sco) `(ldb sc-offset-scn-byte ,sco)) (defmacro sc-offset-offset (sco) `(ldb sc-offset-offset-byte ,sco)) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index ccc89a7..92fc34a 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -34,33 +34,33 @@ (1- most-positive-fixnum)))) (mod #.sb!xc:most-positive-fixnum)) ,@(mapcan (lambda (names) - (destructuring-bind (start end length sequence) names - (list - `(,start - 0 - nil - (if (<= 0 ,start ,length) - ,start - (signal-bounding-indices-bad-error ,sequence - ,start ,end)) - index) - `(,end - nil - nil - (if (or (null ,end) (<= ,start ,end ,length)) - ;; Defaulting of NIL is done inside the - ;; bodies, for ease of sharing with compiler - ;; transforms. - ;; - ;; FIXME: defend against non-number non-NIL - ;; stuff? - ,end - (signal-bounding-indices-bad-error ,sequence - ,start ,end)) - (or null index))))) - '((start end length sequence) - (start1 end1 length1 sequence1) - (start2 end2 length2 sequence2))) + (destructuring-bind (start end length sequence) names + (list + `(,start + 0 + nil + (if (<= 0 ,start ,length) + ,start + (signal-bounding-indices-bad-error ,sequence + ,start ,end)) + index) + `(,end + nil + nil + (if (or (null ,end) (<= ,start ,end ,length)) + ;; Defaulting of NIL is done inside the + ;; bodies, for ease of sharing with compiler + ;; transforms. + ;; + ;; FIXME: defend against non-number non-NIL + ;; stuff? + ,end + (signal-bounding-indices-bad-error ,sequence + ,start ,end)) + (or null index))))) + '((start end length sequence) + (start1 end1 length1 sequence1) + (start2 end2 length2 sequence2))) (key nil nil (and key (%coerce-callable-to-fun key)) @@ -80,36 +80,36 @@ (parse-body body :doc-string-allowed t) (collect ((new-args) (new-declarations) (adjustments)) (dolist (arg args) - (case arg - ;; FIXME: make this robust. And clean. - ((sequence) - (new-args arg) - (adjustments '(length (etypecase sequence - (list (length sequence)) - (vector (length sequence))))) - (new-declarations '(type index length))) - ((sequence1) - (new-args arg) - (adjustments '(length1 (etypecase sequence1 - (list (length sequence1)) - (vector (length sequence1))))) - (new-declarations '(type index length1))) - ((sequence2) - (new-args arg) - (adjustments '(length2 (etypecase sequence2 - (list (length sequence2)) - (vector (length sequence2))))) - (new-declarations '(type index length2))) - ((function predicate) - (new-args arg) - (adjustments `(,arg (%coerce-callable-to-fun ,arg)))) - (t (let ((info (cdr (assoc arg *sequence-keyword-info*)))) - (cond (info - (destructuring-bind (default supplied-p adjuster type) info - (new-args `(,arg ,default ,@(when supplied-p (list supplied-p)))) - (adjustments `(,arg ,adjuster)) - (new-declarations `(type ,type ,arg)))) - (t (new-args arg))))))) + (case arg + ;; FIXME: make this robust. And clean. + ((sequence) + (new-args arg) + (adjustments '(length (etypecase sequence + (list (length sequence)) + (vector (length sequence))))) + (new-declarations '(type index length))) + ((sequence1) + (new-args arg) + (adjustments '(length1 (etypecase sequence1 + (list (length sequence1)) + (vector (length sequence1))))) + (new-declarations '(type index length1))) + ((sequence2) + (new-args arg) + (adjustments '(length2 (etypecase sequence2 + (list (length sequence2)) + (vector (length sequence2))))) + (new-declarations '(type index length2))) + ((function predicate) + (new-args arg) + (adjustments `(,arg (%coerce-callable-to-fun ,arg)))) + (t (let ((info (cdr (assoc arg *sequence-keyword-info*)))) + (cond (info + (destructuring-bind (default supplied-p adjuster type) info + (new-args `(,arg ,default ,@(when supplied-p (list supplied-p)))) + (adjustments `(,arg ,adjuster)) + (new-declarations `(type ,type ,arg)))) + (t (new-args arg))))))) `(defun ,name ,(new-args) ,@(when docstring (list docstring)) ,@declarations @@ -134,13 +134,13 @@ `(if (typep ,sequence 'list) (make-list ,length) (progn - ;; This is only called from places which have already deduced - ;; that the SEQUENCE argument is actually a sequence. So - ;; this would be a candidate place for (AVER (TYPEP ,SEQUENCE - ;; 'VECTOR)), except that this seems to be a performance - ;; hotspot. - (make-array ,length - :element-type (array-element-type ,sequence))))) + ;; This is only called from places which have already deduced + ;; that the SEQUENCE argument is actually a sequence. So + ;; this would be a candidate place for (AVER (TYPEP ,SEQUENCE + ;; 'VECTOR)), except that this seems to be a performance + ;; hotspot. + (make-array ,length + :element-type (array-element-type ,sequence))))) (sb!xc:defmacro bad-sequence-type-error (type-spec) `(error 'simple-type-error @@ -155,12 +155,12 @@ `(error 'simple-type-error :datum ,length :expected-type (cond ((array-type-p ,type) - `(eql ,(car (array-type-dimensions ,type)))) - ((type= ,type (specifier-type 'null)) - '(eql 0)) - ((cons-type-p ,type) - '(integer 1)) - (t (bug "weird type in S-T-L-M-ERROR"))) + `(eql ,(car (array-type-dimensions ,type)))) + ((type= ,type (specifier-type 'null)) + '(eql 0)) + ((cons-type-p ,type) + '(integer 1)) + (t (bug "weird type in S-T-L-M-ERROR"))) ;; FIXME: this format control causes ugly printing. There's ;; probably some ~<~@:_~> incantation that would make it ;; nicer. -- CSR, 2002-10-18 @@ -190,52 +190,52 @@ (let ((actual-length (length vector))) (unless (= actual-length declared-length) (error 'simple-type-error - :datum vector - :expected-type `(vector ,declared-length) - :format-control - "Vector length (~W) doesn't match declared length (~W)." - :format-arguments (list actual-length declared-length)))) + :datum vector + :expected-type `(vector ,declared-length) + :format-control + "Vector length (~W) doesn't match declared length (~W)." + :format-arguments (list actual-length declared-length)))) vector) (defun sequence-of-checked-length-given-type (sequence result-type) (let ((ctype (specifier-type result-type))) (if (not (array-type-p ctype)) - sequence - (let ((declared-length (first (array-type-dimensions ctype)))) - (if (eq declared-length '*) - sequence - (vector-of-checked-length-given-length sequence - declared-length)))))) + sequence + (let ((declared-length (first (array-type-dimensions ctype)))) + (if (eq declared-length '*) + sequence + (vector-of-checked-length-given-length sequence + declared-length)))))) (declaim (ftype (function (sequence index) nil) signal-index-too-large-error)) (defun signal-index-too-large-error (sequence index) (let* ((length (length sequence)) - (max-index (and (plusp length) - (1- length)))) + (max-index (and (plusp length) + (1- length)))) (error 'index-too-large-error - :datum index - :expected-type (if max-index - `(integer 0 ,max-index) - ;; This seems silly, is there something better? - '(integer 0 (0)))))) + :datum index + :expected-type (if max-index + `(integer 0 ,max-index) + ;; This seems silly, is there something better? + '(integer 0 (0)))))) (defun signal-bounding-indices-bad-error (sequence start end) (let ((length (length sequence))) (error 'bounding-indices-bad-error - :datum (cons start end) - :expected-type `(cons (integer 0 ,length) - (or null (integer ,start ,length))) - :object sequence))) + :datum (cons start end) + :expected-type `(cons (integer 0 ,length) + (or null (integer ,start ,length))) + :object sequence))) (defun elt (sequence index) #!+sb-doc "Return the element of SEQUENCE specified by INDEX." (etypecase sequence (list (do ((count index (1- count)) - (list sequence (cdr list))) - ((= count 0) - (if (endp list) - (signal-index-too-large-error sequence index) - (car list))) + (list sequence (cdr list))) + ((= count 0) + (if (endp list) + (signal-index-too-large-error sequence index) + (car list))) (declare (type (integer 0) count)))) (vector (when (>= index (length sequence)) @@ -247,12 +247,12 @@ (etypecase sequence (list (do ((count index (1- count)) - (seq sequence)) - ((= count 0) (rplaca seq newval) newval) + (seq sequence)) + ((= count 0) (rplaca seq newval) newval) (declare (fixnum count)) (if (atom (cdr seq)) - (signal-index-too-large-error sequence index) - (setq seq (cdr seq))))) + (signal-index-too-large-error sequence index) + (setq seq (cdr seq))))) (vector (when (>= index (length sequence)) (signal-index-too-large-error sequence index)) @@ -270,67 +270,67 @@ to INITIAL-ELEMENT." (declare (fixnum length)) (let* ((adjusted-type - (typecase type - (atom (cond - ((eq type 'string) '(vector character)) - ((eq type 'simple-string) '(simple-array character (*))) - (t type))) - (cons (cond - ((eq (car type) 'string) `(vector character ,@(cdr type))) - ((eq (car type) 'simple-string) - `(simple-array character ,(if (cdr type) - (cdr type) - '(*)))) - (t type))) - (t type))) - (type (specifier-type adjusted-type))) + (typecase type + (atom (cond + ((eq type 'string) '(vector character)) + ((eq type 'simple-string) '(simple-array character (*))) + (t type))) + (cons (cond + ((eq (car type) 'string) `(vector character ,@(cdr type))) + ((eq (car type) 'simple-string) + `(simple-array character ,(if (cdr type) + (cdr type) + '(*)))) + (t type))) + (t type))) + (type (specifier-type adjusted-type))) (cond ((csubtypep type (specifier-type 'list)) - (cond - ((type= type (specifier-type 'list)) - (make-list length :initial-element initial-element)) - ((eq type *empty-type*) - (bad-sequence-type-error nil)) - ((type= type (specifier-type 'null)) - (if (= length 0) - 'nil - (sequence-type-length-mismatch-error type length))) - ((cons-type-p type) - (multiple-value-bind (min exactp) - (sb!kernel::cons-type-length-info type) - (if exactp - (unless (= length min) - (sequence-type-length-mismatch-error type length)) - (unless (>= length min) - (sequence-type-length-mismatch-error type length))) - (make-list length :initial-element initial-element))) - ;; We'll get here for e.g. (OR NULL (CONS INTEGER *)), - ;; which may seem strange and non-ideal, but then I'd say - ;; it was stranger to feed that type in to MAKE-SEQUENCE. - (t (sequence-type-too-hairy (type-specifier type))))) - ((csubtypep type (specifier-type 'vector)) - (cond - (;; is it immediately obvious what the result type is? - (typep type 'array-type) - (progn - (aver (= (length (array-type-dimensions type)) 1)) - (let* ((etype (type-specifier - (array-type-specialized-element-type type))) - (etype (if (eq etype '*) t etype)) - (type-length (car (array-type-dimensions type)))) - (unless (or (eq type-length '*) - (= type-length length)) - (sequence-type-length-mismatch-error type length)) - ;; FIXME: These calls to MAKE-ARRAY can't be - ;; open-coded, as the :ELEMENT-TYPE argument isn't - ;; constant. Probably we ought to write a - ;; DEFTRANSFORM for MAKE-SEQUENCE. -- CSR, - ;; 2002-07-22 - (if iep - (make-array length :element-type etype - :initial-element initial-element) - (make-array length :element-type etype))))) - (t (sequence-type-too-hairy (type-specifier type))))) - (t (bad-sequence-type-error (type-specifier type)))))) + (cond + ((type= type (specifier-type 'list)) + (make-list length :initial-element initial-element)) + ((eq type *empty-type*) + (bad-sequence-type-error nil)) + ((type= type (specifier-type 'null)) + (if (= length 0) + 'nil + (sequence-type-length-mismatch-error type length))) + ((cons-type-p type) + (multiple-value-bind (min exactp) + (sb!kernel::cons-type-length-info type) + (if exactp + (unless (= length min) + (sequence-type-length-mismatch-error type length)) + (unless (>= length min) + (sequence-type-length-mismatch-error type length))) + (make-list length :initial-element initial-element))) + ;; We'll get here for e.g. (OR NULL (CONS INTEGER *)), + ;; which may seem strange and non-ideal, but then I'd say + ;; it was stranger to feed that type in to MAKE-SEQUENCE. + (t (sequence-type-too-hairy (type-specifier type))))) + ((csubtypep type (specifier-type 'vector)) + (cond + (;; is it immediately obvious what the result type is? + (typep type 'array-type) + (progn + (aver (= (length (array-type-dimensions type)) 1)) + (let* ((etype (type-specifier + (array-type-specialized-element-type type))) + (etype (if (eq etype '*) t etype)) + (type-length (car (array-type-dimensions type)))) + (unless (or (eq type-length '*) + (= type-length length)) + (sequence-type-length-mismatch-error type length)) + ;; FIXME: These calls to MAKE-ARRAY can't be + ;; open-coded, as the :ELEMENT-TYPE argument isn't + ;; constant. Probably we ought to write a + ;; DEFTRANSFORM for MAKE-SEQUENCE. -- CSR, + ;; 2002-07-22 + (if iep + (make-array length :element-type etype + :initial-element initial-element) + (make-array length :element-type etype))))) + (t (sequence-type-too-hairy (type-specifier type))))) + (t (bad-sequence-type-error (type-specifier type)))))) ;;;; SUBSEQ ;;;; @@ -352,7 +352,7 @@ ((= old-index end) copy) (declare (fixnum old-index new-index)) (setf (aref copy new-index) - (aref sequence old-index)))) + (aref sequence old-index)))) (defun list-subseq* (sequence start &optional end) (declare (type list sequence)) @@ -366,9 +366,9 @@ (nil) (cond ((null list) (if (or (and end (> end index)) - (< index start)) - (signal-bounding-indices-bad-error sequence start end) - (return (nreverse result)))) + (< index start)) + (signal-bounding-indices-bad-error sequence start end) + (return (nreverse result)))) ((< index start) nil) ((and end (= index end)) (return (nreverse result))) (t (push (car list) result))))) @@ -378,8 +378,8 @@ "Return a copy of a subsequence of SEQUENCE starting with element number START and continuing to the end of SEQUENCE or the optional END." (seq-dispatch sequence - (list-subseq* sequence start end) - (vector-subseq* sequence start end))) + (list-subseq* sequence start end) + (vector-subseq* sequence start end))) ;;;; COPY-SEQ @@ -389,28 +389,28 @@ `(let ((length (length (the vector ,sequence)))) (declare (fixnum length)) (do ((index 0 (1+ index)) - (copy (make-sequence-like ,sequence length))) - ((= index length) copy) + (copy (make-sequence-like ,sequence length))) + ((= index length) copy) (declare (fixnum index)) (setf (aref copy index) (aref ,sequence index))))) (sb!xc:defmacro list-copy-seq (list) `(if (atom ,list) '() (let ((result (cons (car ,list) '()) )) - (do ((x (cdr ,list) (cdr x)) - (splice result - (cdr (rplacd splice (cons (car x) '() ))) )) - ((atom x) (unless (null x) - (rplacd splice x)) - result))))) + (do ((x (cdr ,list) (cdr x)) + (splice result + (cdr (rplacd splice (cons (car x) '() ))) )) + ((atom x) (unless (null x) + (rplacd splice x)) + result))))) ) ; EVAL-WHEN (defun copy-seq (sequence) #!+sb-doc "Return a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ." (seq-dispatch sequence - (list-copy-seq* sequence) - (vector-copy-seq* sequence))) + (list-copy-seq* sequence) + (vector-copy-seq* sequence))) ;;; internal frobs @@ -433,9 +433,9 @@ (sb!xc:defmacro list-fill (sequence item start end) `(do ((current (nthcdr ,start ,sequence) (cdr current)) - (index ,start (1+ index))) + (index ,start (1+ index))) ((or (atom current) (and end (= index (the fixnum ,end)))) - sequence) + sequence) (declare (fixnum index)) (rplaca current ,item))) @@ -457,8 +457,8 @@ (define-sequence-traverser fill (sequence item &key start end) #!+sb-doc "Replace the specified elements of SEQUENCE with ITEM." (seq-dispatch sequence - (list-fill* sequence item start end) - (vector-fill* sequence item start end))) + (list-fill* sequence item start end) + (vector-fill* sequence item start end))) ;;;; REPLACE @@ -469,75 +469,75 @@ (sb!xc:defmacro mumble-replace-from-mumble () `(if (and (eq target-sequence source-sequence) (> target-start source-start)) (let ((nelts (min (- target-end target-start) - (- source-end source-start)))) - (do ((target-index (+ (the fixnum target-start) (the fixnum nelts) -1) - (1- target-index)) - (source-index (+ (the fixnum source-start) (the fixnum nelts) -1) - (1- source-index))) - ((= target-index (the fixnum (1- target-start))) target-sequence) - (declare (fixnum target-index source-index)) - ;; disable bounds checking - (declare (optimize (safety 0))) - (setf (aref target-sequence target-index) - (aref source-sequence source-index)))) + (- source-end source-start)))) + (do ((target-index (+ (the fixnum target-start) (the fixnum nelts) -1) + (1- target-index)) + (source-index (+ (the fixnum source-start) (the fixnum nelts) -1) + (1- source-index))) + ((= target-index (the fixnum (1- target-start))) target-sequence) + (declare (fixnum target-index source-index)) + ;; disable bounds checking + (declare (optimize (safety 0))) + (setf (aref target-sequence target-index) + (aref source-sequence source-index)))) (do ((target-index target-start (1+ target-index)) - (source-index source-start (1+ source-index))) - ((or (= target-index (the fixnum target-end)) - (= source-index (the fixnum source-end))) - target-sequence) - (declare (fixnum target-index source-index)) - ;; disable bounds checking - (declare (optimize (safety 0))) - (setf (aref target-sequence target-index) - (aref source-sequence source-index))))) + (source-index source-start (1+ source-index))) + ((or (= target-index (the fixnum target-end)) + (= source-index (the fixnum source-end))) + target-sequence) + (declare (fixnum target-index source-index)) + ;; disable bounds checking + (declare (optimize (safety 0))) + (setf (aref target-sequence target-index) + (aref source-sequence source-index))))) (sb!xc:defmacro list-replace-from-list () `(if (and (eq target-sequence source-sequence) (> target-start source-start)) (let ((new-elts (subseq source-sequence source-start - (+ (the fixnum source-start) - (the fixnum - (min (- (the fixnum target-end) - (the fixnum target-start)) - (- (the fixnum source-end) - (the fixnum source-start)))))))) - (do ((n new-elts (cdr n)) - (o (nthcdr target-start target-sequence) (cdr o))) - ((null n) target-sequence) - (rplaca o (car n)))) + (+ (the fixnum source-start) + (the fixnum + (min (- (the fixnum target-end) + (the fixnum target-start)) + (- (the fixnum source-end) + (the fixnum source-start)))))))) + (do ((n new-elts (cdr n)) + (o (nthcdr target-start target-sequence) (cdr o))) + ((null n) target-sequence) + (rplaca o (car n)))) (do ((target-index target-start (1+ target-index)) - (source-index source-start (1+ source-index)) - (target-sequence-ref (nthcdr target-start target-sequence) - (cdr target-sequence-ref)) - (source-sequence-ref (nthcdr source-start source-sequence) - (cdr source-sequence-ref))) - ((or (= target-index (the fixnum target-end)) - (= source-index (the fixnum source-end)) - (null target-sequence-ref) (null source-sequence-ref)) - target-sequence) - (declare (fixnum target-index source-index)) - (rplaca target-sequence-ref (car source-sequence-ref))))) + (source-index source-start (1+ source-index)) + (target-sequence-ref (nthcdr target-start target-sequence) + (cdr target-sequence-ref)) + (source-sequence-ref (nthcdr source-start source-sequence) + (cdr source-sequence-ref))) + ((or (= target-index (the fixnum target-end)) + (= source-index (the fixnum source-end)) + (null target-sequence-ref) (null source-sequence-ref)) + target-sequence) + (declare (fixnum target-index source-index)) + (rplaca target-sequence-ref (car source-sequence-ref))))) (sb!xc:defmacro list-replace-from-mumble () `(do ((target-index target-start (1+ target-index)) - (source-index source-start (1+ source-index)) - (target-sequence-ref (nthcdr target-start target-sequence) - (cdr target-sequence-ref))) + (source-index source-start (1+ source-index)) + (target-sequence-ref (nthcdr target-start target-sequence) + (cdr target-sequence-ref))) ((or (= target-index (the fixnum target-end)) - (= source-index (the fixnum source-end)) - (null target-sequence-ref)) - target-sequence) + (= source-index (the fixnum source-end)) + (null target-sequence-ref)) + target-sequence) (declare (fixnum source-index target-index)) (rplaca target-sequence-ref (aref source-sequence source-index)))) (sb!xc:defmacro mumble-replace-from-list () `(do ((target-index target-start (1+ target-index)) - (source-index source-start (1+ source-index)) - (source-sequence (nthcdr source-start source-sequence) - (cdr source-sequence))) + (source-index source-start (1+ source-index)) + (source-sequence (nthcdr source-start source-sequence) + (cdr source-sequence))) ((or (= target-index (the fixnum target-end)) - (= source-index (the fixnum source-end)) - (null source-sequence)) - target-sequence) + (= source-index (the fixnum source-end)) + (null source-sequence)) + target-sequence) (declare (fixnum target-index source-index)) (setf (aref target-sequence target-index) (car source-sequence)))) @@ -548,26 +548,26 @@ ;;;; at this level. (defun list-replace-from-list* (target-sequence source-sequence target-start - target-end source-start source-end) + target-end source-start source-end) (when (null target-end) (setq target-end (length target-sequence))) (when (null source-end) (setq source-end (length source-sequence))) (list-replace-from-list)) (defun list-replace-from-vector* (target-sequence source-sequence target-start - target-end source-start source-end) + target-end source-start source-end) (when (null target-end) (setq target-end (length target-sequence))) (when (null source-end) (setq source-end (length source-sequence))) (list-replace-from-mumble)) (defun vector-replace-from-list* (target-sequence source-sequence target-start - target-end source-start source-end) + target-end source-start source-end) (when (null target-end) (setq target-end (length target-sequence))) (when (null source-end) (setq source-end (length source-sequence))) (mumble-replace-from-list)) (defun vector-replace-from-vector* (target-sequence source-sequence - target-start target-end source-start - source-end) + target-start target-end source-start + source-end) (when (null target-end) (setq target-end (length target-sequence))) (when (null source-end) (setq source-end (length source-sequence))) (mumble-replace-from-mumble)) @@ -587,22 +587,22 @@ "The target sequence is destructively modified by copying successive elements into it from the source sequence." (let* (;; KLUDGE: absent either rewriting FOO-REPLACE-FROM-BAR, or - ;; excessively polluting DEFINE-SEQUENCE-TRAVERSER, we rebind - ;; these things here so that legacy code gets the names it's - ;; expecting. We could use &AUX instead :-/. - (target-sequence sequence1) - (source-sequence sequence2) - (target-start start1) - (source-start start2) - (target-end (or end1 length1)) - (source-end (or end2 length2))) + ;; excessively polluting DEFINE-SEQUENCE-TRAVERSER, we rebind + ;; these things here so that legacy code gets the names it's + ;; expecting. We could use &AUX instead :-/. + (target-sequence sequence1) + (source-sequence sequence2) + (target-start start1) + (source-start start2) + (target-end (or end1 length1)) + (source-end (or end2 length2))) (seq-dispatch target-sequence - (seq-dispatch source-sequence - (list-replace-from-list) - (list-replace-from-mumble)) - (seq-dispatch source-sequence - (mumble-replace-from-list) - (mumble-replace-from-mumble))))) + (seq-dispatch source-sequence + (list-replace-from-list) + (list-replace-from-mumble)) + (seq-dispatch source-sequence + (mumble-replace-from-list) + (mumble-replace-from-mumble))))) ;;;; REVERSE @@ -612,12 +612,12 @@ `(let ((length (length ,sequence))) (declare (fixnum length)) (do ((forward-index 0 (1+ forward-index)) - (backward-index (1- length) (1- backward-index)) - (new-sequence (make-sequence-like sequence length))) - ((= forward-index length) new-sequence) + (backward-index (1- length) (1- backward-index)) + (new-sequence (make-sequence-like sequence length))) + ((= forward-index length) new-sequence) (declare (fixnum forward-index backward-index)) (setf (aref new-sequence forward-index) - (aref ,sequence backward-index))))) + (aref ,sequence backward-index))))) (sb!xc:defmacro list-reverse-macro (sequence) `(do ((new-list ())) @@ -630,8 +630,8 @@ #!+sb-doc "Return a new sequence containing the same elements but in reverse order." (seq-dispatch sequence - (list-reverse* sequence) - (vector-reverse* sequence))) + (list-reverse* sequence) + (vector-reverse* sequence))) ;;; internal frobs @@ -658,8 +658,8 @@ (sb!xc:defmacro list-nreverse-macro (list) `(do ((1st (cdr ,list) (if (endp 1st) 1st (cdr 1st))) - (2nd ,list 1st) - (3rd '() 2nd)) + (2nd ,list 1st) + (3rd '() 2nd)) ((atom 2nd) 3rd) (rplacd 2nd 3rd))) @@ -676,8 +676,8 @@ "Return a sequence of the same elements in reverse order; the argument is destroyed." (seq-dispatch sequence - (list-nreverse* sequence) - (vector-nreverse* sequence))) + (list-nreverse* sequence) + (vector-nreverse* sequence))) ;;;; CONCATENATE @@ -686,48 +686,48 @@ (sb!xc:defmacro concatenate-to-list (sequences) `(let ((result (list nil))) (do ((sequences ,sequences (cdr sequences)) - (splice result)) - ((null sequences) (cdr result)) + (splice result)) + ((null sequences) (cdr result)) (let ((sequence (car sequences))) - ;; FIXME: It appears to me that this and CONCATENATE-TO-MUMBLE - ;; could benefit from a DO-SEQUENCE macro. - (seq-dispatch sequence - (do ((sequence sequence (cdr sequence))) - ((atom sequence)) - (setq splice - (cdr (rplacd splice (list (car sequence)))))) - (do ((index 0 (1+ index)) - (length (length sequence))) - ((= index length)) - (declare (fixnum index length)) - (setq splice - (cdr (rplacd splice - (list (aref sequence index))))))))))) + ;; FIXME: It appears to me that this and CONCATENATE-TO-MUMBLE + ;; could benefit from a DO-SEQUENCE macro. + (seq-dispatch sequence + (do ((sequence sequence (cdr sequence))) + ((atom sequence)) + (setq splice + (cdr (rplacd splice (list (car sequence)))))) + (do ((index 0 (1+ index)) + (length (length sequence))) + ((= index length)) + (declare (fixnum index length)) + (setq splice + (cdr (rplacd splice + (list (aref sequence index))))))))))) (sb!xc:defmacro concatenate-to-mumble (output-type-spec sequences) `(do ((seqs ,sequences (cdr seqs)) - (total-length 0) - (lengths ())) + (total-length 0) + (lengths ())) ((null seqs) - (do ((sequences ,sequences (cdr sequences)) - (lengths lengths (cdr lengths)) - (index 0) - (result (make-sequence ,output-type-spec total-length))) - ((= index total-length) result) - (declare (fixnum index)) - (let ((sequence (car sequences))) - (seq-dispatch sequence - (do ((sequence sequence (cdr sequence))) - ((atom sequence)) - (setf (aref result index) (car sequence)) - (setq index (1+ index))) - (do ((jndex 0 (1+ jndex)) - (this-length (car lengths))) - ((= jndex this-length)) - (declare (fixnum jndex this-length)) - (setf (aref result index) - (aref sequence jndex)) - (setq index (1+ index))))))) + (do ((sequences ,sequences (cdr sequences)) + (lengths lengths (cdr lengths)) + (index 0) + (result (make-sequence ,output-type-spec total-length))) + ((= index total-length) result) + (declare (fixnum index)) + (let ((sequence (car sequences))) + (seq-dispatch sequence + (do ((sequence sequence (cdr sequence))) + ((atom sequence)) + (setf (aref result index) (car sequence)) + (setq index (1+ index))) + (do ((jndex 0 (1+ jndex)) + (this-length (car lengths))) + ((= jndex this-length)) + (declare (fixnum jndex this-length)) + (setf (aref result index) + (aref sequence jndex)) + (setq index (1+ index))))))) (let ((length (length (car seqs)))) (declare (fixnum length)) (setq lengths (nconc lengths (list length))) @@ -745,28 +745,28 @@ ((csubtypep type (specifier-type 'list)) (cond ((type= type (specifier-type 'list)) - (apply #'concat-to-list* sequences)) + (apply #'concat-to-list* sequences)) ((eq type *empty-type*) - (bad-sequence-type-error nil)) + (bad-sequence-type-error nil)) ((type= type (specifier-type 'null)) - (if (every (lambda (x) (or (null x) - (and (vectorp x) (= (length x) 0)))) - sequences) - 'nil - (sequence-type-length-mismatch-error - type - ;; FIXME: circular list issues. - (reduce #'+ sequences :key #'length)))) + (if (every (lambda (x) (or (null x) + (and (vectorp x) (= (length x) 0)))) + sequences) + 'nil + (sequence-type-length-mismatch-error + type + ;; FIXME: circular list issues. + (reduce #'+ sequences :key #'length)))) ((cons-type-p type) - (multiple-value-bind (min exactp) - (sb!kernel::cons-type-length-info type) - (let ((length (reduce #'+ sequences :key #'length))) - (if exactp - (unless (= length min) - (sequence-type-length-mismatch-error type length)) - (unless (>= length min) - (sequence-type-length-mismatch-error type length))) - (apply #'concat-to-list* sequences)))) + (multiple-value-bind (min exactp) + (sb!kernel::cons-type-length-info type) + (let ((length (reduce #'+ sequences :key #'length))) + (if exactp + (unless (= length min) + (sequence-type-length-mismatch-error type length)) + (unless (>= length min) + (sequence-type-length-mismatch-error type length))) + (apply #'concat-to-list* sequences)))) (t (sequence-type-too-hairy (type-specifier type))))) ((csubtypep type (specifier-type 'vector)) (apply #'concat-to-simple* output-type-spec sequences)) @@ -789,34 +789,34 @@ ;;; helper functions to handle arity-1 subcases of MAP (declaim (ftype (function (function sequence) list) %map-list-arity-1)) (declaim (ftype (function (function sequence) simple-vector) - %map-simple-vector-arity-1)) + %map-simple-vector-arity-1)) (macrolet ((dosequence ((i sequence) &body body) - (once-only ((sequence sequence)) - `(etypecase ,sequence - (list (dolist (,i ,sequence) ,@body)) - (simple-vector (dovector (,i sequence) ,@body)) - (vector (dovector (,i sequence) ,@body)))))) + (once-only ((sequence sequence)) + `(etypecase ,sequence + (list (dolist (,i ,sequence) ,@body)) + (simple-vector (dovector (,i sequence) ,@body)) + (vector (dovector (,i sequence) ,@body)))))) (defun %map-to-list-arity-1 (fun sequence) (let ((reversed-result nil) - (really-fun (%coerce-callable-to-fun fun))) + (really-fun (%coerce-callable-to-fun fun))) (dosequence (element sequence) - (push (funcall really-fun element) - reversed-result)) + (push (funcall really-fun element) + reversed-result)) (nreverse reversed-result))) (defun %map-to-simple-vector-arity-1 (fun sequence) (let ((result (make-array (length sequence))) - (index 0) - (really-fun (%coerce-callable-to-fun fun))) + (index 0) + (really-fun (%coerce-callable-to-fun fun))) (declare (type index index)) (dosequence (element sequence) (setf (aref result index) - (funcall really-fun element)) - (incf index)) + (funcall really-fun element)) + (incf index)) result)) (defun %map-for-effect-arity-1 (fun sequence) (let ((really-fun (%coerce-callable-to-fun fun))) (dosequence (element sequence) - (funcall really-fun element))) + (funcall really-fun element))) nil)) ;;; helper functions to handle arity-N subcases of MAP @@ -830,89 +830,89 @@ ;;; a closure (LAMBDA (&REST REST) ) ;;; with the REST list allocated with DYNAMIC-EXTENT. -- WHN 20000920 (macrolet (;; Execute BODY in a context where the machinery for - ;; UPDATED-MAP-APPLY-ARGS has been set up. - (with-map-state (sequences &body body) + ;; UPDATED-MAP-APPLY-ARGS has been set up. + (with-map-state (sequences &body body) `(let* ((%sequences ,sequences) - (%iters (mapcar (lambda (sequence) - (etypecase sequence - (list sequence) - (vector 0))) - %sequences)) - (%apply-args (make-list (length %sequences)))) - (declare (type list %sequences %iters %apply-args)) - ,@body)) - ;; Return a list of args to pass to APPLY for the next - ;; function call in the mapping, or NIL if no more function - ;; calls should be made (because we've reached the end of a - ;; sequence arg). - (updated-map-apply-args () - '(do ((in-sequences %sequences (cdr in-sequences)) - (in-iters %iters (cdr in-iters)) - (in-apply-args %apply-args (cdr in-apply-args))) - ((null in-sequences) - %apply-args) - (declare (type list in-sequences in-iters in-apply-args)) - (let ((i (car in-iters))) - (declare (type (or list index) i)) - (if (listp i) - (if (null i) ; if end of this sequence - (return nil) - (setf (car in-apply-args) (car i) - (car in-iters) (cdr i))) - (let ((v (the vector (car in-sequences)))) - (if (>= i (length v)) ; if end of this sequence - (return nil) - (setf (car in-apply-args) (aref v i) - (car in-iters) (1+ i))))))))) + (%iters (mapcar (lambda (sequence) + (etypecase sequence + (list sequence) + (vector 0))) + %sequences)) + (%apply-args (make-list (length %sequences)))) + (declare (type list %sequences %iters %apply-args)) + ,@body)) + ;; Return a list of args to pass to APPLY for the next + ;; function call in the mapping, or NIL if no more function + ;; calls should be made (because we've reached the end of a + ;; sequence arg). + (updated-map-apply-args () + '(do ((in-sequences %sequences (cdr in-sequences)) + (in-iters %iters (cdr in-iters)) + (in-apply-args %apply-args (cdr in-apply-args))) + ((null in-sequences) + %apply-args) + (declare (type list in-sequences in-iters in-apply-args)) + (let ((i (car in-iters))) + (declare (type (or list index) i)) + (if (listp i) + (if (null i) ; if end of this sequence + (return nil) + (setf (car in-apply-args) (car i) + (car in-iters) (cdr i))) + (let ((v (the vector (car in-sequences)))) + (if (>= i (length v)) ; if end of this sequence + (return nil) + (setf (car in-apply-args) (aref v i) + (car in-iters) (1+ i))))))))) (defun %map-to-list (func sequences) (declare (type function func)) (declare (type list sequences)) (with-map-state sequences - (loop with updated-map-apply-args - while (setf updated-map-apply-args (updated-map-apply-args)) - collect (apply func updated-map-apply-args)))) + (loop with updated-map-apply-args + while (setf updated-map-apply-args (updated-map-apply-args)) + collect (apply func updated-map-apply-args)))) (defun %map-to-vector (output-type-spec func sequences) (declare (type function func)) (declare (type list sequences)) (let ((min-len (with-map-state sequences - (do ((counter 0 (1+ counter))) - ;; Note: Doing everything in - ;; UPDATED-MAP-APPLY-ARGS here is somewhat - ;; wasteful; we even do some extra consing. - ;; And stepping over every element of - ;; VECTORs, instead of just grabbing their - ;; LENGTH, is also wasteful. But it's easy - ;; and safe. (If you do rewrite it, please - ;; try to make sure that - ;; (MAP NIL #'F SOME-CIRCULAR-LIST #(1)) - ;; does the right thing.) - ((not (updated-map-apply-args)) - counter) - (declare (type index counter)))))) + (do ((counter 0 (1+ counter))) + ;; Note: Doing everything in + ;; UPDATED-MAP-APPLY-ARGS here is somewhat + ;; wasteful; we even do some extra consing. + ;; And stepping over every element of + ;; VECTORs, instead of just grabbing their + ;; LENGTH, is also wasteful. But it's easy + ;; and safe. (If you do rewrite it, please + ;; try to make sure that + ;; (MAP NIL #'F SOME-CIRCULAR-LIST #(1)) + ;; does the right thing.) + ((not (updated-map-apply-args)) + counter) + (declare (type index counter)))))) (declare (type index min-len)) (with-map-state sequences - (let ((result (make-sequence output-type-spec min-len)) - (index 0)) - (declare (type index index)) - (loop with updated-map-apply-args - while (setf updated-map-apply-args (updated-map-apply-args)) - do - (setf (aref result index) - (apply func updated-map-apply-args)) - (incf index)) - result)))) + (let ((result (make-sequence output-type-spec min-len)) + (index 0)) + (declare (type index index)) + (loop with updated-map-apply-args + while (setf updated-map-apply-args (updated-map-apply-args)) + do + (setf (aref result index) + (apply func updated-map-apply-args)) + (incf index)) + result)))) (defun %map-for-effect (func sequences) (declare (type function func)) (declare (type list sequences)) (with-map-state sequences (loop with updated-map-apply-args - while (setf updated-map-apply-args (updated-map-apply-args)) - do - (apply func updated-map-apply-args)) + while (setf updated-map-apply-args (updated-map-apply-args)) + do + (apply func updated-map-apply-args)) nil))) - "FUNCTION must take as many arguments as there are sequences provided. - The result is a sequence of type OUTPUT-TYPE-SPEC such that element I + "FUNCTION must take as many arguments as there are sequences provided. + The result is a sequence of type OUTPUT-TYPE-SPEC such that element I is the result of applying FUNCTION to element I of each of the argument sequences." @@ -921,34 +921,34 @@ ;;; in RESULT-TYPE. (defun %map (result-type function first-sequence &rest more-sequences) (let ((really-fun (%coerce-callable-to-fun function)) - (type (specifier-type result-type))) + (type (specifier-type result-type))) ;; Handle one-argument MAP NIL specially, using ETYPECASE to turn ;; it into something which can be DEFTRANSFORMed away. (It's ;; fairly important to handle this case efficiently, since ;; quantifiers like SOME are transformed into this case, and since ;; there's no consing overhead to dwarf our inefficiency.) (if (and (null more-sequences) - (null result-type)) - (%map-for-effect-arity-1 really-fun first-sequence) - ;; Otherwise, use the industrial-strength full-generality - ;; approach, consing O(N-ARGS) temporary storage (which can have - ;; DYNAMIC-EXTENT), then using O(N-ARGS * RESULT-LENGTH) time. - (let ((sequences (cons first-sequence more-sequences))) - (cond - ((eq type *empty-type*) (%map-for-effect really-fun sequences)) - ((csubtypep type (specifier-type 'list)) - (%map-to-list really-fun sequences)) - ((csubtypep type (specifier-type 'vector)) - (%map-to-vector result-type really-fun sequences)) - (t - (bad-sequence-type-error result-type))))))) + (null result-type)) + (%map-for-effect-arity-1 really-fun first-sequence) + ;; Otherwise, use the industrial-strength full-generality + ;; approach, consing O(N-ARGS) temporary storage (which can have + ;; DYNAMIC-EXTENT), then using O(N-ARGS * RESULT-LENGTH) time. + (let ((sequences (cons first-sequence more-sequences))) + (cond + ((eq type *empty-type*) (%map-for-effect really-fun sequences)) + ((csubtypep type (specifier-type 'list)) + (%map-to-list really-fun sequences)) + ((csubtypep type (specifier-type 'vector)) + (%map-to-vector result-type really-fun sequences)) + (t + (bad-sequence-type-error result-type))))))) (defun map (result-type function first-sequence &rest more-sequences) (apply #'%map - result-type - function - first-sequence - more-sequences)) + result-type + function + first-sequence + more-sequences)) ;;; KLUDGE: MAP has been rewritten substantially since the fork from ;;; CMU CL in order to give reasonable performance, but this @@ -961,23 +961,23 @@ ;;; of (MAP NIL ..). -- WHN 20000920 (defun map-into (result-sequence function &rest sequences) (let* ((fp-result - (and (arrayp result-sequence) - (array-has-fill-pointer-p result-sequence))) - (len (apply #'min - (if fp-result - (array-dimension result-sequence 0) - (length result-sequence)) - (mapcar #'length sequences)))) + (and (arrayp result-sequence) + (array-has-fill-pointer-p result-sequence))) + (len (apply #'min + (if fp-result + (array-dimension result-sequence 0) + (length result-sequence)) + (mapcar #'length sequences)))) (when fp-result (setf (fill-pointer result-sequence) len)) (let ((really-fun (%coerce-callable-to-fun function))) (dotimes (index len) - (setf (elt result-sequence index) - (apply really-fun - (mapcar (lambda (seq) (elt seq index)) - sequences)))))) + (setf (elt result-sequence index) + (apply really-fun + (mapcar (lambda (seq) (elt seq index)) + sequences)))))) result-sequence) ;;;; quantifiers @@ -986,72 +986,72 @@ ;;; arbitrary sequence arguments, both in the full call case and in ;;; the open code case. (macrolet ((defquantifier (name found-test found-result - &key doc (unfound-result (not found-result))) - `(progn - ;; KLUDGE: It would be really nice if we could simply - ;; do something like this - ;; (declaim (inline ,name)) - ;; (defun ,name (pred first-seq &rest more-seqs) - ;; ,doc - ;; (flet ((map-me (&rest rest) - ;; (let ((pred-value (apply pred rest))) - ;; (,found-test pred-value - ;; (return-from ,name - ;; ,found-result))))) - ;; (declare (inline map-me)) - ;; (apply #'map nil #'map-me first-seq more-seqs) - ;; ,unfound-result)) - ;; but Python doesn't seem to be smart enough about - ;; inlining and APPLY to recognize that it can use - ;; the DEFTRANSFORM for MAP in the resulting inline - ;; expansion. I don't have any appetite for deep - ;; compiler hacking right now, so I'll just work - ;; around the apparent problem by using a compiler - ;; macro instead. -- WHN 20000410 - (defun ,name (pred first-seq &rest more-seqs) - #!+sb-doc ,doc - (flet ((map-me (&rest rest) - (let ((pred-value (apply pred rest))) - (,found-test pred-value - (return-from ,name - ,found-result))))) - (declare (inline map-me)) - (apply #'map nil #'map-me first-seq more-seqs) - ,unfound-result)) - ;; KLUDGE: It would be more obviously correct -- but - ;; also significantly messier -- for PRED-VALUE to be - ;; a gensym. However, a private symbol really does - ;; seem to be good enough; and anyway the really - ;; obviously correct solution is to make Python smart - ;; enough that we can use an inline function instead - ;; of a compiler macro (as above). -- WHN 20000410 - ;; - ;; FIXME: The DEFINE-COMPILER-MACRO here can be - ;; important for performance, and it'd be good to have - ;; it be visible throughout the compilation of all the - ;; target SBCL code. That could be done by defining - ;; SB-XC:DEFINE-COMPILER-MACRO and using it here, - ;; moving this DEFQUANTIFIER stuff (and perhaps other - ;; inline definitions in seq.lisp as well) into a new - ;; seq.lisp, and moving remaining target-only stuff - ;; from the old seq.lisp into target-seq.lisp. - (define-compiler-macro ,name (pred first-seq &rest more-seqs) - (let ((elements (make-gensym-list (1+ (length more-seqs)))) - (blockname (gensym "BLOCK"))) - (once-only ((pred pred)) - `(block ,blockname - (map nil - (lambda (,@elements) - (let ((pred-value (funcall ,pred ,@elements))) - (,',found-test pred-value - (return-from ,blockname - ,',found-result)))) - ,first-seq - ,@more-seqs) - ,',unfound-result))))))) + &key doc (unfound-result (not found-result))) + `(progn + ;; KLUDGE: It would be really nice if we could simply + ;; do something like this + ;; (declaim (inline ,name)) + ;; (defun ,name (pred first-seq &rest more-seqs) + ;; ,doc + ;; (flet ((map-me (&rest rest) + ;; (let ((pred-value (apply pred rest))) + ;; (,found-test pred-value + ;; (return-from ,name + ;; ,found-result))))) + ;; (declare (inline map-me)) + ;; (apply #'map nil #'map-me first-seq more-seqs) + ;; ,unfound-result)) + ;; but Python doesn't seem to be smart enough about + ;; inlining and APPLY to recognize that it can use + ;; the DEFTRANSFORM for MAP in the resulting inline + ;; expansion. I don't have any appetite for deep + ;; compiler hacking right now, so I'll just work + ;; around the apparent problem by using a compiler + ;; macro instead. -- WHN 20000410 + (defun ,name (pred first-seq &rest more-seqs) + #!+sb-doc ,doc + (flet ((map-me (&rest rest) + (let ((pred-value (apply pred rest))) + (,found-test pred-value + (return-from ,name + ,found-result))))) + (declare (inline map-me)) + (apply #'map nil #'map-me first-seq more-seqs) + ,unfound-result)) + ;; KLUDGE: It would be more obviously correct -- but + ;; also significantly messier -- for PRED-VALUE to be + ;; a gensym. However, a private symbol really does + ;; seem to be good enough; and anyway the really + ;; obviously correct solution is to make Python smart + ;; enough that we can use an inline function instead + ;; of a compiler macro (as above). -- WHN 20000410 + ;; + ;; FIXME: The DEFINE-COMPILER-MACRO here can be + ;; important for performance, and it'd be good to have + ;; it be visible throughout the compilation of all the + ;; target SBCL code. That could be done by defining + ;; SB-XC:DEFINE-COMPILER-MACRO and using it here, + ;; moving this DEFQUANTIFIER stuff (and perhaps other + ;; inline definitions in seq.lisp as well) into a new + ;; seq.lisp, and moving remaining target-only stuff + ;; from the old seq.lisp into target-seq.lisp. + (define-compiler-macro ,name (pred first-seq &rest more-seqs) + (let ((elements (make-gensym-list (1+ (length more-seqs)))) + (blockname (gensym "BLOCK"))) + (once-only ((pred pred)) + `(block ,blockname + (map nil + (lambda (,@elements) + (let ((pred-value (funcall ,pred ,@elements))) + (,',found-test pred-value + (return-from ,blockname + ,',found-result)))) + ,first-seq + ,@more-seqs) + ,',unfound-result))))))) (defquantifier some when pred-value :unfound-result nil :doc - "Apply PREDICATE to the 0-indexed elements of the sequences, then - possibly to those with index 1, and so on. Return the first + "Apply PREDICATE to the 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return the first non-NIL value encountered, or NIL if the end of any sequence is reached.") (defquantifier every unless nil :doc "Apply PREDICATE to the 0-indexed elements of the sequences, then @@ -1059,7 +1059,7 @@ as any invocation of PREDICATE returns NIL, or T if every invocation is non-NIL.") (defquantifier notany when nil :doc - "Apply PREDICATE to the 0-indexed elements of the sequences, then + "Apply PREDICATE to the 0-indexed elements of the sequences, then possibly to those with index 1, and so on. Return NIL as soon as any invocation of PREDICATE returns a non-NIL value, or T if the end of any sequence is reached.") @@ -1074,65 +1074,65 @@ (eval-when (:compile-toplevel :execute) (sb!xc:defmacro mumble-reduce (function - sequence - key - start - end - initial-value - ref) + sequence + key + start + end + initial-value + ref) `(do ((index ,start (1+ index)) - (value ,initial-value)) + (value ,initial-value)) ((>= index ,end) value) (setq value (funcall ,function value - (apply-key ,key (,ref ,sequence index)))))) + (apply-key ,key (,ref ,sequence index)))))) (sb!xc:defmacro mumble-reduce-from-end (function - sequence - key - start - end - initial-value - ref) + sequence + key + start + end + initial-value + ref) `(do ((index (1- ,end) (1- index)) - (value ,initial-value) - (terminus (1- ,start))) + (value ,initial-value) + (terminus (1- ,start))) ((<= index terminus) value) (setq value (funcall ,function - (apply-key ,key (,ref ,sequence index)) - value)))) + (apply-key ,key (,ref ,sequence index)) + value)))) (sb!xc:defmacro list-reduce (function - sequence - key - start - end - initial-value - ivp) + sequence + key + start + end + initial-value + ivp) `(let ((sequence (nthcdr ,start ,sequence))) (do ((count (if ,ivp ,start (1+ ,start)) - (1+ count)) - (sequence (if ,ivp sequence (cdr sequence)) - (cdr sequence)) - (value (if ,ivp ,initial-value (apply-key ,key (car sequence))) - (funcall ,function value (apply-key ,key (car sequence))))) - ((>= count ,end) value)))) + (1+ count)) + (sequence (if ,ivp sequence (cdr sequence)) + (cdr sequence)) + (value (if ,ivp ,initial-value (apply-key ,key (car sequence))) + (funcall ,function value (apply-key ,key (car sequence))))) + ((>= count ,end) value)))) (sb!xc:defmacro list-reduce-from-end (function - sequence - key - start - end - initial-value - ivp) + sequence + key + start + end + initial-value + ivp) `(let ((sequence (nthcdr (- (length ,sequence) ,end) - (reverse ,sequence)))) + (reverse ,sequence)))) (do ((count (if ,ivp ,start (1+ ,start)) - (1+ count)) - (sequence (if ,ivp sequence (cdr sequence)) - (cdr sequence)) - (value (if ,ivp ,initial-value (apply-key ,key (car sequence))) - (funcall ,function (apply-key ,key (car sequence)) value))) - ((>= count ,end) value)))) + (1+ count)) + (sequence (if ,ivp sequence (cdr sequence)) + (cdr sequence)) + (value (if ,ivp ,initial-value (apply-key ,key (car sequence))) + (funcall ,function (apply-key ,key (car sequence)) value))) + ((>= count ,end) value)))) ) ; EVAL-WHEN @@ -1140,28 +1140,28 @@ (function sequence &key key from-end start end (initial-value nil ivp)) (declare (type index start)) (let ((start start) - (end (or end length))) + (end (or end length))) (declare (type index start end)) (cond ((= end start) - (if ivp initial-value (funcall function))) - ((listp sequence) - (if from-end - (list-reduce-from-end function sequence key start end - initial-value ivp) - (list-reduce function sequence key start end - initial-value ivp))) - (from-end - (when (not ivp) - (setq end (1- (the fixnum end))) - (setq initial-value (apply-key key (aref sequence end)))) - (mumble-reduce-from-end function sequence key start end - initial-value aref)) - (t - (when (not ivp) - (setq initial-value (apply-key key (aref sequence start))) - (setq start (1+ start))) - (mumble-reduce function sequence key start end - initial-value aref))))) + (if ivp initial-value (funcall function))) + ((listp sequence) + (if from-end + (list-reduce-from-end function sequence key start end + initial-value ivp) + (list-reduce function sequence key start end + initial-value ivp))) + (from-end + (when (not ivp) + (setq end (1- (the fixnum end))) + (setq initial-value (apply-key key (aref sequence end)))) + (mumble-reduce-from-end function sequence key start end + initial-value aref)) + (t + (when (not ivp) + (setq initial-value (apply-key key (aref sequence start))) + (setq start (1+ start))) + (mumble-reduce function sequence key start end + initial-value aref))))) ;;;; DELETE @@ -1169,15 +1169,15 @@ (sb!xc:defmacro mumble-delete (pred) `(do ((index start (1+ index)) - (jndex start) - (number-zapped 0)) + (jndex start) + (number-zapped 0)) ((or (= index (the fixnum end)) (= number-zapped count)) - (do ((index index (1+ index)) ; Copy the rest of the vector. - (jndex jndex (1+ jndex))) - ((= index (the fixnum length)) - (shrink-vector sequence jndex)) - (declare (fixnum index jndex)) - (setf (aref sequence jndex) (aref sequence index)))) + (do ((index index (1+ index)) ; Copy the rest of the vector. + (jndex jndex (1+ jndex))) + ((= index (the fixnum length)) + (shrink-vector sequence jndex)) + (declare (fixnum index jndex)) + (setf (aref sequence jndex) (aref sequence index)))) (declare (fixnum index jndex number-zapped)) (setf (aref sequence jndex) (aref sequence index)) (if ,pred @@ -1186,25 +1186,25 @@ (sb!xc:defmacro mumble-delete-from-end (pred) `(do ((index (1- (the fixnum end)) (1- index)) ; Find the losers. - (number-zapped 0) - (losers ()) - this-element - (terminus (1- start))) + (number-zapped 0) + (losers ()) + this-element + (terminus (1- start))) ((or (= index terminus) (= number-zapped count)) - (do ((losers losers) ; Delete the losers. - (index start (1+ index)) - (jndex start)) - ((or (null losers) (= index (the fixnum end))) - (do ((index index (1+ index)) ; Copy the rest of the vector. - (jndex jndex (1+ jndex))) - ((= index (the fixnum length)) - (shrink-vector sequence jndex)) - (declare (fixnum index jndex)) - (setf (aref sequence jndex) (aref sequence index)))) - (declare (fixnum index jndex)) - (setf (aref sequence jndex) (aref sequence index)) - (if (= index (the fixnum (car losers))) - (pop losers) + (do ((losers losers) ; Delete the losers. + (index start (1+ index)) + (jndex start)) + ((or (null losers) (= index (the fixnum end))) + (do ((index index (1+ index)) ; Copy the rest of the vector. + (jndex jndex (1+ jndex))) + ((= index (the fixnum length)) + (shrink-vector sequence jndex)) + (declare (fixnum index jndex)) + (setf (aref sequence jndex) (aref sequence index)))) + (declare (fixnum index jndex)) + (setf (aref sequence jndex) (aref sequence index)) + (if (= index (the fixnum (car losers))) + (pop losers) (incf jndex)))) (declare (fixnum index number-zapped terminus)) (setq this-element (aref sequence index)) @@ -1215,58 +1215,58 @@ (sb!xc:defmacro normal-mumble-delete () `(mumble-delete (if test-not - (not (funcall test-not item (apply-key key (aref sequence index)))) - (funcall test item (apply-key key (aref sequence index)))))) + (not (funcall test-not item (apply-key key (aref sequence index)))) + (funcall test item (apply-key key (aref sequence index)))))) (sb!xc:defmacro normal-mumble-delete-from-end () `(mumble-delete-from-end (if test-not - (not (funcall test-not item (apply-key key this-element))) - (funcall test item (apply-key key this-element))))) + (not (funcall test-not item (apply-key key this-element))) + (funcall test item (apply-key key this-element))))) (sb!xc:defmacro list-delete (pred) `(let ((handle (cons nil sequence))) (do ((current (nthcdr start sequence) (cdr current)) - (previous (nthcdr start handle)) - (index start (1+ index)) - (number-zapped 0)) - ((or (= index (the fixnum end)) (= number-zapped count)) - (cdr handle)) + (previous (nthcdr start handle)) + (index start (1+ index)) + (number-zapped 0)) + ((or (= index (the fixnum end)) (= number-zapped count)) + (cdr handle)) (declare (fixnum index number-zapped)) (cond (,pred - (rplacd previous (cdr current)) + (rplacd previous (cdr current)) (incf number-zapped)) - (t - (setq previous (cdr previous))))))) + (t + (setq previous (cdr previous))))))) (sb!xc:defmacro list-delete-from-end (pred) `(let* ((reverse (nreverse (the list sequence))) - (handle (cons nil reverse))) + (handle (cons nil reverse))) (do ((current (nthcdr (- (the fixnum length) (the fixnum end)) reverse) - (cdr current)) - (previous (nthcdr (- (the fixnum length) (the fixnum end)) handle)) - (index start (1+ index)) - (number-zapped 0)) - ((or (= index (the fixnum end)) (= number-zapped count)) - (nreverse (cdr handle))) + (cdr current)) + (previous (nthcdr (- (the fixnum length) (the fixnum end)) handle)) + (index start (1+ index)) + (number-zapped 0)) + ((or (= index (the fixnum end)) (= number-zapped count)) + (nreverse (cdr handle))) (declare (fixnum index number-zapped)) (cond (,pred - (rplacd previous (cdr current)) + (rplacd previous (cdr current)) (incf number-zapped)) - (t - (setq previous (cdr previous))))))) + (t + (setq previous (cdr previous))))))) (sb!xc:defmacro normal-list-delete () '(list-delete (if test-not - (not (funcall test-not item (apply-key key (car current)))) - (funcall test item (apply-key key (car current)))))) + (not (funcall test-not item (apply-key key (car current)))) + (funcall test item (apply-key key (car current)))))) (sb!xc:defmacro normal-list-delete-from-end () '(list-delete-from-end (if test-not - (not (funcall test-not item (apply-key key (car current)))) - (funcall test item (apply-key key (car current)))))) + (not (funcall test-not item (apply-key key (car current)))) + (funcall test item (apply-key key (car current)))))) ) ; EVAL-WHEN @@ -1280,12 +1280,12 @@ (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence - (if from-end - (normal-list-delete-from-end) - (normal-list-delete)) - (if from-end - (normal-mumble-delete-from-end) - (normal-mumble-delete))))) + (if from-end + (normal-list-delete-from-end) + (normal-list-delete)) + (if from-end + (normal-mumble-delete-from-end) + (normal-mumble-delete))))) (eval-when (:compile-toplevel :execute) @@ -1316,12 +1316,12 @@ (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence - (if from-end - (if-list-delete-from-end) - (if-list-delete)) - (if from-end - (if-mumble-delete-from-end) - (if-mumble-delete))))) + (if from-end + (if-list-delete-from-end) + (if-list-delete)) + (if from-end + (if-mumble-delete-from-end) + (if-mumble-delete))))) (eval-when (:compile-toplevel :execute) @@ -1352,12 +1352,12 @@ (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence - (if from-end - (if-not-list-delete-from-end) - (if-not-list-delete)) - (if from-end - (if-not-mumble-delete-from-end) - (if-not-mumble-delete))))) + (if from-end + (if-not-list-delete-from-end) + (if-not-list-delete)) + (if from-end + (if-not-mumble-delete-from-end) + (if-not-mumble-delete))))) ;;;; REMOVE @@ -1367,27 +1367,27 @@ ;;; satisfies the predicate. (sb!xc:defmacro mumble-remove-macro (bump left begin finish right pred) `(do ((index ,begin (,bump index)) - (result - (do ((index ,left (,bump index)) - (result (make-sequence-like sequence length))) - ((= index (the fixnum ,begin)) result) - (declare (fixnum index)) - (setf (aref result index) (aref sequence index)))) - (new-index ,begin) - (number-zapped 0) - (this-element)) + (result + (do ((index ,left (,bump index)) + (result (make-sequence-like sequence length))) + ((= index (the fixnum ,begin)) result) + (declare (fixnum index)) + (setf (aref result index) (aref sequence index)))) + (new-index ,begin) + (number-zapped 0) + (this-element)) ((or (= index (the fixnum ,finish)) - (= number-zapped count)) - (do ((index index (,bump index)) - (new-index new-index (,bump new-index))) - ((= index (the fixnum ,right)) (shrink-vector result new-index)) - (declare (fixnum index new-index)) - (setf (aref result new-index) (aref sequence index)))) + (= number-zapped count)) + (do ((index index (,bump index)) + (new-index new-index (,bump new-index))) + ((= index (the fixnum ,right)) (shrink-vector result new-index)) + (declare (fixnum index new-index)) + (setf (aref result new-index) (aref sequence index)))) (declare (fixnum index new-index number-zapped)) (setq this-element (aref sequence index)) (cond (,pred (incf number-zapped)) - (t (setf (aref result new-index) this-element) - (setq new-index (,bump new-index)))))) + (t (setf (aref result new-index) this-element) + (setq new-index (,bump new-index)))))) (sb!xc:defmacro mumble-remove (pred) `(mumble-remove-macro 1+ 0 start end length ,pred)) @@ -1399,14 +1399,14 @@ (sb!xc:defmacro normal-mumble-remove () `(mumble-remove (if test-not - (not (funcall test-not item (apply-key key this-element))) - (funcall test item (apply-key key this-element))))) + (not (funcall test-not item (apply-key key this-element))) + (funcall test item (apply-key key this-element))))) (sb!xc:defmacro normal-mumble-remove-from-end () `(mumble-remove-from-end (if test-not - (not (funcall test-not item (apply-key key this-element))) - (funcall test item (apply-key key this-element))))) + (not (funcall test-not item (apply-key key this-element))) + (funcall test item (apply-key key this-element))))) (sb!xc:defmacro if-mumble-remove () `(mumble-remove (funcall predicate (apply-key key this-element)))) @@ -1425,33 +1425,33 @@ ;;; the predicate. (sb!xc:defmacro list-remove-macro (pred reverse?) `(let* ((sequence ,(if reverse? - '(reverse (the list sequence)) - 'sequence)) - (%start ,(if reverse? '(- length end) 'start)) - (%end ,(if reverse? '(- length start) 'end)) - (splice (list nil)) - (results (do ((index 0 (1+ index)) - (before-start splice)) - ((= index (the fixnum %start)) before-start) - (declare (fixnum index)) - (setq splice - (cdr (rplacd splice (list (pop sequence)))))))) + '(reverse (the list sequence)) + 'sequence)) + (%start ,(if reverse? '(- length end) 'start)) + (%end ,(if reverse? '(- length start) 'end)) + (splice (list nil)) + (results (do ((index 0 (1+ index)) + (before-start splice)) + ((= index (the fixnum %start)) before-start) + (declare (fixnum index)) + (setq splice + (cdr (rplacd splice (list (pop sequence)))))))) (do ((index %start (1+ index)) - (this-element) - (number-zapped 0)) - ((or (= index (the fixnum %end)) (= number-zapped count)) - (do ((index index (1+ index))) - ((null sequence) - ,(if reverse? - '(nreverse (the list (cdr results))) - '(cdr results))) - (declare (fixnum index)) - (setq splice (cdr (rplacd splice (list (pop sequence))))))) + (this-element) + (number-zapped 0)) + ((or (= index (the fixnum %end)) (= number-zapped count)) + (do ((index index (1+ index))) + ((null sequence) + ,(if reverse? + '(nreverse (the list (cdr results))) + '(cdr results))) + (declare (fixnum index)) + (setq splice (cdr (rplacd splice (list (pop sequence))))))) (declare (fixnum index number-zapped)) (setq this-element (pop sequence)) (if ,pred - (setq number-zapped (1+ number-zapped)) - (setq splice (cdr (rplacd splice (list this-element)))))))) + (setq number-zapped (1+ number-zapped)) + (setq splice (cdr (rplacd splice (list this-element)))))))) (sb!xc:defmacro list-remove (pred) `(list-remove-macro ,pred nil)) @@ -1462,14 +1462,14 @@ (sb!xc:defmacro normal-list-remove () `(list-remove (if test-not - (not (funcall test-not item (apply-key key this-element))) - (funcall test item (apply-key key this-element))))) + (not (funcall test-not item (apply-key key this-element))) + (funcall test item (apply-key key this-element))))) (sb!xc:defmacro normal-list-remove-from-end () `(list-remove-from-end (if test-not - (not (funcall test-not item (apply-key key this-element))) - (funcall test item (apply-key key this-element))))) + (not (funcall test-not item (apply-key key this-element))) + (funcall test item (apply-key key this-element))))) (sb!xc:defmacro if-list-remove () `(list-remove @@ -1499,12 +1499,12 @@ (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence - (if from-end - (normal-list-remove-from-end) - (normal-list-remove)) - (if from-end - (normal-mumble-remove-from-end) - (normal-mumble-remove))))) + (if from-end + (normal-list-remove-from-end) + (normal-list-remove)) + (if from-end + (normal-mumble-remove-from-end) + (normal-mumble-remove))))) (define-sequence-traverser remove-if (predicate sequence &key from-end start end count key) @@ -1514,12 +1514,12 @@ (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence - (if from-end - (if-list-remove-from-end) - (if-list-remove)) - (if from-end - (if-mumble-remove-from-end) - (if-mumble-remove))))) + (if from-end + (if-list-remove-from-end) + (if-list-remove)) + (if from-end + (if-mumble-remove-from-end) + (if-mumble-remove))))) (define-sequence-traverser remove-if-not (predicate sequence &key from-end start end count key) @@ -1529,12 +1529,12 @@ (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence - (if from-end - (if-not-list-remove-from-end) - (if-not-list-remove)) - (if from-end - (if-not-mumble-remove-from-end) - (if-not-mumble-remove))))) + (if from-end + (if-not-list-remove-from-end) + (if-not-list-remove)) + (if from-end + (if-not-mumble-remove-from-end) + (if-not-mumble-remove))))) ;;;; REMOVE-DUPLICATES @@ -1547,62 +1547,62 @@ (defun list-remove-duplicates* (list test test-not start end key from-end) (declare (fixnum start)) (let* ((result (list ())) ; Put a marker on the beginning to splice with. - (splice result) - (current list)) + (splice result) + (current list)) (do ((index 0 (1+ index))) - ((= index start)) + ((= index start)) (declare (fixnum index)) (setq splice (cdr (rplacd splice (list (car current))))) (setq current (cdr current))) (do ((index start (1+ index))) - ((or (and end (= index (the fixnum end))) - (atom current))) + ((or (and end (= index (the fixnum end))) + (atom current))) (declare (fixnum index)) (if (or (and from-end - (not (if test-not - (member (apply-key key (car current)) - (nthcdr (1+ start) result) - :test-not test-not - :key key) - (member (apply-key key (car current)) - (nthcdr (1+ start) result) - :test test - :key key)))) - (and (not from-end) - (not (do ((it (apply-key key (car current))) - (l (cdr current) (cdr l)) - (i (1+ index) (1+ i))) - ((or (atom l) (and end (= i (the fixnum end)))) - ()) - (declare (fixnum i)) - (if (if test-not - (not (funcall test-not - it - (apply-key key (car l)))) - (funcall test it (apply-key key (car l)))) - (return t)))))) - (setq splice (cdr (rplacd splice (list (car current)))))) + (not (if test-not + (member (apply-key key (car current)) + (nthcdr (1+ start) result) + :test-not test-not + :key key) + (member (apply-key key (car current)) + (nthcdr (1+ start) result) + :test test + :key key)))) + (and (not from-end) + (not (do ((it (apply-key key (car current))) + (l (cdr current) (cdr l)) + (i (1+ index) (1+ i))) + ((or (atom l) (and end (= i (the fixnum end)))) + ()) + (declare (fixnum i)) + (if (if test-not + (not (funcall test-not + it + (apply-key key (car l)))) + (funcall test it (apply-key key (car l)))) + (return t)))))) + (setq splice (cdr (rplacd splice (list (car current)))))) (setq current (cdr current))) (do () - ((atom current)) + ((atom current)) (setq splice (cdr (rplacd splice (list (car current))))) (setq current (cdr current))) (cdr result))) (defun vector-remove-duplicates* (vector test test-not start end key from-end - &optional (length (length vector))) + &optional (length (length vector))) (declare (vector vector) (fixnum start length)) (when (null end) (setf end (length vector))) (let ((result (make-sequence-like vector length)) - (index 0) - (jndex start)) + (index 0) + (jndex start)) (declare (fixnum index jndex)) (do () - ((= index start)) + ((= index start)) (setf (aref result index) (aref vector index)) (setq index (1+ index))) (do ((elt)) - ((= index end)) + ((= index end)) (setq elt (aref vector index)) ;; FIXME: Relying on POSITION allowing both :TEST and :TEST-NOT ;; arguments simultaneously is a little fragile, since ANSI says @@ -1611,18 +1611,18 @@ ;; rewrite this to avoid passing both (as ;; LIST-REMOVE-DUPLICATES* was rewritten ca. sbcl-0.7.12.18). (unless (or (and from-end - (position (apply-key key elt) result - :start start :end jndex - :test test :test-not test-not :key key)) - (and (not from-end) - (position (apply-key key elt) vector - :start (1+ index) :end end - :test test :test-not test-not :key key))) - (setf (aref result jndex) elt) - (setq jndex (1+ jndex))) + (position (apply-key key elt) result + :start start :end jndex + :test test :test-not test-not :key key)) + (and (not from-end) + (position (apply-key key elt) vector + :start (1+ index) :end end + :test test :test-not test-not :key key))) + (setf (aref result jndex) elt) + (setq jndex (1+ jndex))) (setq index (1+ index))) (do () - ((= index length)) + ((= index length)) (setf (aref result jndex) (aref vector index)) (setq index (1+ index)) (setq jndex (1+ jndex))) @@ -1639,11 +1639,11 @@ The :TEST-NOT argument is deprecated." (declare (fixnum start)) (seq-dispatch sequence - (if sequence - (list-remove-duplicates* sequence test test-not - start end key from-end)) - (vector-remove-duplicates* sequence test test-not - start end key from-end))) + (if sequence + (list-remove-duplicates* sequence test test-not + start end key from-end)) + (vector-remove-duplicates* sequence test test-not + start end key from-end))) ;;;; DELETE-DUPLICATES @@ -1651,50 +1651,50 @@ (declare (fixnum start)) (let ((handle (cons nil list))) (do ((current (nthcdr start list) (cdr current)) - (previous (nthcdr start handle)) - (index start (1+ index))) - ((or (and end (= index (the fixnum end))) (null current)) - (cdr handle)) + (previous (nthcdr start handle)) + (index start (1+ index))) + ((or (and end (= index (the fixnum end))) (null current)) + (cdr handle)) (declare (fixnum index)) (if (do ((x (if from-end - (nthcdr (1+ start) handle) - (cdr current)) - (cdr x)) - (i (1+ index) (1+ i))) - ((or (null x) - (and (not from-end) end (= i (the fixnum end))) - (eq x current)) - nil) - (declare (fixnum i)) - (if (if test-not - (not (funcall test-not - (apply-key key (car current)) - (apply-key key (car x)))) - (funcall test - (apply-key key (car current)) - (apply-key key (car x)))) - (return t))) - (rplacd previous (cdr current)) - (setq previous (cdr previous)))))) + (nthcdr (1+ start) handle) + (cdr current)) + (cdr x)) + (i (1+ index) (1+ i))) + ((or (null x) + (and (not from-end) end (= i (the fixnum end))) + (eq x current)) + nil) + (declare (fixnum i)) + (if (if test-not + (not (funcall test-not + (apply-key key (car current)) + (apply-key key (car x)))) + (funcall test + (apply-key key (car current)) + (apply-key key (car x)))) + (return t))) + (rplacd previous (cdr current)) + (setq previous (cdr previous)))))) (defun vector-delete-duplicates* (vector test test-not key from-end start end - &optional (length (length vector))) + &optional (length (length vector))) (declare (vector vector) (fixnum start length)) (when (null end) (setf end (length vector))) (do ((index start (1+ index)) (jndex start)) ((= index end) - (do ((index index (1+ index)) ; copy the rest of the vector - (jndex jndex (1+ jndex))) - ((= index length) - (shrink-vector vector jndex) - vector) - (setf (aref vector jndex) (aref vector index)))) + (do ((index index (1+ index)) ; copy the rest of the vector + (jndex jndex (1+ jndex))) + ((= index length) + (shrink-vector vector jndex) + vector) + (setf (aref vector jndex) (aref vector index)))) (declare (fixnum index jndex)) (setf (aref vector jndex) (aref vector index)) (unless (position (apply-key key (aref vector index)) vector :key key - :start (if from-end start (1+ index)) :test test - :end (if from-end jndex end) :test-not test-not) + :start (if from-end start (1+ index)) :test test + :end (if from-end jndex end) :test-not test-not) (setq jndex (1+ jndex))))) (define-sequence-traverser delete-duplicates @@ -1707,7 +1707,7 @@ The :TEST-NOT argument is deprecated." (seq-dispatch sequence (if sequence - (list-delete-duplicates* sequence test test-not key from-end start end)) + (list-delete-duplicates* sequence test test-not key from-end start end)) (vector-delete-duplicates* sequence test test-not key from-end start end))) ;;;; SUBSTITUTE @@ -1715,36 +1715,36 @@ (defun list-substitute* (pred new list start end count key test test-not old) (declare (fixnum start end count)) (let* ((result (list nil)) - elt - (splice result) - (list list)) ; Get a local list for a stepper. + elt + (splice result) + (list list)) ; Get a local list for a stepper. (do ((index 0 (1+ index))) - ((= index start)) + ((= index start)) (declare (fixnum index)) (setq splice (cdr (rplacd splice (list (car list))))) (setq list (cdr list))) (do ((index start (1+ index))) - ((or (= index end) (null list) (= count 0))) + ((or (= index end) (null list) (= count 0))) (declare (fixnum index)) (setq elt (car list)) (setq splice - (cdr (rplacd splice - (list - (cond - ((case pred - (normal - (if test-not - (not - (funcall test-not old (apply-key key elt))) - (funcall test old (apply-key key elt)))) - (if (funcall test (apply-key key elt))) - (if-not (not (funcall test (apply-key key elt))))) - (decf count) - new) - (t elt)))))) + (cdr (rplacd splice + (list + (cond + ((case pred + (normal + (if test-not + (not + (funcall test-not old (apply-key key elt))) + (funcall test old (apply-key key elt)))) + (if (funcall test (apply-key key elt))) + (if-not (not (funcall test (apply-key key elt))))) + (decf count) + new) + (t elt)))))) (setq list (cdr list))) (do () - ((null list)) + ((null list)) (setq splice (cdr (rplacd splice (list (car list))))) (setq list (cdr list))) (cdr result))) @@ -1752,32 +1752,32 @@ ;;; Replace old with new in sequence moving from left to right by incrementer ;;; on each pass through the loop. Called by all three substitute functions. (defun vector-substitute* (pred new sequence incrementer left right length - start end count key test test-not old) + start end count key test test-not old) (declare (fixnum start count end incrementer right)) (let ((result (make-sequence-like sequence length)) - (index left)) + (index left)) (declare (fixnum index)) (do () - ((= index start)) + ((= index start)) (setf (aref result index) (aref sequence index)) (setq index (+ index incrementer))) (do ((elt)) - ((or (= index end) (= count 0))) + ((or (= index end) (= count 0))) (setq elt (aref sequence index)) (setf (aref result index) - (cond ((case pred - (normal - (if test-not - (not (funcall test-not old (apply-key key elt))) - (funcall test old (apply-key key elt)))) - (if (funcall test (apply-key key elt))) - (if-not (not (funcall test (apply-key key elt))))) - (setq count (1- count)) - new) - (t elt))) + (cond ((case pred + (normal + (if test-not + (not (funcall test-not old (apply-key key elt))) + (funcall test old (apply-key key elt)))) + (if (funcall test (apply-key key elt))) + (if-not (not (funcall test (apply-key key elt))))) + (setq count (1- count)) + new) + (t elt))) (setq index (+ index incrementer))) (do () - ((= index right)) + ((= index right)) (setf (aref result index) (aref sequence index)) (setq index (+ index incrementer))) result)) @@ -1787,24 +1787,24 @@ (sb!xc:defmacro subst-dispatch (pred) `(if (listp sequence) (if from-end - (nreverse (list-substitute* ,pred - new - (reverse sequence) - (- (the fixnum length) - (the fixnum end)) - (- (the fixnum length) - (the fixnum start)) - count key test test-not old)) - (list-substitute* ,pred - new sequence start end count key test test-not - old)) + (nreverse (list-substitute* ,pred + new + (reverse sequence) + (- (the fixnum length) + (the fixnum end)) + (- (the fixnum length) + (the fixnum start)) + count key test test-not old)) + (list-substitute* ,pred + new sequence start end count key test test-not + old)) (if from-end - (vector-substitute* ,pred new sequence -1 (1- (the fixnum length)) - -1 length (1- (the fixnum end)) - (1- (the fixnum start)) - count key test test-not old) - (vector-substitute* ,pred new sequence 1 0 length length - start end count key test test-not old)))) + (vector-substitute* ,pred new sequence -1 (1- (the fixnum length)) + -1 length (1- (the fixnum end)) + (1- (the fixnum start)) + count key test test-not old) + (vector-substitute* ,pred new sequence 1 0 length length + start end count key test test-not old)))) ) ; EVAL-WHEN @@ -1829,8 +1829,8 @@ (declare (fixnum start)) (let ((end (or end length)) (test predicate) - (test-not nil) - old) + (test-not nil) + old) (declare (type index length end)) (subst-dispatch 'if))) @@ -1842,8 +1842,8 @@ (declare (fixnum start)) (let ((end (or end length)) (test predicate) - (test-not nil) - old) + (test-not nil) + old) (declare (type index length end)) (subst-dispatch 'if-not))) @@ -1859,19 +1859,19 @@ (declare (fixnum start)) (let ((end (or end length))) (if (listp sequence) - (if from-end - (let ((length (length sequence))) - (nreverse (nlist-substitute* - new old (nreverse (the list sequence)) - test test-not (- length end) (- length start) - count key))) - (nlist-substitute* new old sequence - test test-not start end count key)) - (if from-end - (nvector-substitute* new old sequence -1 - test test-not (1- end) (1- start) count key) - (nvector-substitute* new old sequence 1 - test test-not start end count key))))) + (if from-end + (let ((length (length sequence))) + (nreverse (nlist-substitute* + new old (nreverse (the list sequence)) + test test-not (- length end) (- length start) + count key))) + (nlist-substitute* new old sequence + test test-not start end count key)) + (if from-end + (nvector-substitute* new old sequence -1 + test test-not (1- end) (1- start) count key) + (nvector-substitute* new old sequence 1 + test test-not start end count key))))) (defun nlist-substitute* (new old sequence test test-not start end count key) (declare (fixnum start count end)) @@ -1880,22 +1880,22 @@ ((or (= index end) (null list) (= count 0)) sequence) (declare (fixnum index)) (when (if test-not - (not (funcall test-not old (apply-key key (car list)))) - (funcall test old (apply-key key (car list)))) + (not (funcall test-not old (apply-key key (car list)))) + (funcall test old (apply-key key (car list)))) (rplaca list new) (setq count (1- count))))) (defun nvector-substitute* (new old sequence incrementer - test test-not start end count key) + test test-not start end count key) (declare (fixnum start incrementer count end)) (do ((index start (+ index incrementer))) ((or (= index end) (= count 0)) sequence) (declare (fixnum index)) (when (if test-not - (not (funcall test-not - old - (apply-key key (aref sequence index)))) - (funcall test old (apply-key key (aref sequence index)))) + (not (funcall test-not + old + (apply-key key (aref sequence index)))) + (funcall test old (apply-key key (aref sequence index)))) (setf (aref sequence index) new) (setq count (1- count))))) @@ -1905,24 +1905,24 @@ (new predicate sequence &key from-end start end count key) #!+sb-doc "Return a sequence of the same kind as SEQUENCE with the same elements - except that all elements satisfying PREDICATE are replaced with NEW. + except that all elements satisfying PREDICATE are replaced with NEW. SEQUENCE may be destructively modified." (declare (fixnum start)) (let ((end (or end length))) (declare (fixnum end)) (if (listp sequence) - (if from-end - (let ((length (length sequence))) - (nreverse (nlist-substitute-if* - new predicate (nreverse (the list sequence)) - (- length end) (- length start) count key))) - (nlist-substitute-if* new predicate sequence - start end count key)) - (if from-end - (nvector-substitute-if* new predicate sequence -1 - (1- end) (1- start) count key) - (nvector-substitute-if* new predicate sequence 1 - start end count key))))) + (if from-end + (let ((length (length sequence))) + (nreverse (nlist-substitute-if* + new predicate (nreverse (the list sequence)) + (- length end) (- length start) count key))) + (nlist-substitute-if* new predicate sequence + start end count key)) + (if from-end + (nvector-substitute-if* new predicate sequence -1 + (1- end) (1- start) count key) + (nvector-substitute-if* new predicate sequence 1 + start end count key))))) (defun nlist-substitute-if* (new test sequence start end count key) (declare (fixnum end)) @@ -1934,7 +1934,7 @@ (setq count (1- count))))) (defun nvector-substitute-if* (new test sequence incrementer - start end count key) + start end count key) (do ((index start (+ index incrementer))) ((or (= index end) (= count 0)) sequence) (when (funcall test (apply-key key (aref sequence index))) @@ -1951,18 +1951,18 @@ (let ((end (or end length))) (declare (fixnum end)) (if (listp sequence) - (if from-end - (let ((length (length sequence))) - (nreverse (nlist-substitute-if-not* - new predicate (nreverse (the list sequence)) - (- length end) (- length start) count key))) - (nlist-substitute-if-not* new predicate sequence - start end count key)) - (if from-end - (nvector-substitute-if-not* new predicate sequence -1 - (1- end) (1- start) count key) - (nvector-substitute-if-not* new predicate sequence 1 - start end count key))))) + (if from-end + (let ((length (length sequence))) + (nreverse (nlist-substitute-if-not* + new predicate (nreverse (the list sequence)) + (- length end) (- length start) count key))) + (nlist-substitute-if-not* new predicate sequence + start end count key)) + (if from-end + (nvector-substitute-if-not* new predicate sequence -1 + (1- end) (1- start) count key) + (nvector-substitute-if-not* new predicate sequence 1 + start end count key))))) (defun nlist-substitute-if-not* (new test sequence start end count key) (declare (fixnum end)) @@ -1974,7 +1974,7 @@ (decf count)))) (defun nvector-substitute-if-not* (new test sequence incrementer - start end count key) + start end count key) (do ((index start (+ index incrementer))) ((or (= index end) (= count 0)) sequence) (when (not (funcall test (apply-key key (aref sequence index)))) @@ -1990,49 +1990,49 @@ ;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF (macrolet (;; shared logic for defining %FIND-POSITION and - ;; %FIND-POSITION-IF in terms of various inlineable cases - ;; of the expression defined in FROB and VECTOR*-FROB - (frobs () - `(etypecase sequence-arg - (list (frob sequence-arg from-end)) - (vector - (with-array-data ((sequence sequence-arg :offset-var offset) - (start start) - (end (%check-vector-sequence-bounds - sequence-arg start end))) - (multiple-value-bind (f p) - (macrolet ((frob2 () '(if from-end - (frob sequence t) - (frob sequence nil)))) - (typecase sequence - (simple-vector (frob2)) - (simple-base-string (frob2)) - (t (vector*-frob sequence)))) - (declare (type (or index null) p)) - (values f (and p (the index (- p offset)))))))))) + ;; %FIND-POSITION-IF in terms of various inlineable cases + ;; of the expression defined in FROB and VECTOR*-FROB + (frobs () + `(etypecase sequence-arg + (list (frob sequence-arg from-end)) + (vector + (with-array-data ((sequence sequence-arg :offset-var offset) + (start start) + (end (%check-vector-sequence-bounds + sequence-arg start end))) + (multiple-value-bind (f p) + (macrolet ((frob2 () '(if from-end + (frob sequence t) + (frob sequence nil)))) + (typecase sequence + (simple-vector (frob2)) + (simple-base-string (frob2)) + (t (vector*-frob sequence)))) + (declare (type (or index null) p)) + (values f (and p (the index (- p offset)))))))))) (defun %find-position (item sequence-arg from-end start end key test) (macrolet ((frob (sequence from-end) - `(%find-position item ,sequence - ,from-end start end key test)) - (vector*-frob (sequence) - `(%find-position-vector-macro item ,sequence - from-end start end key test))) + `(%find-position item ,sequence + ,from-end start end key test)) + (vector*-frob (sequence) + `(%find-position-vector-macro item ,sequence + from-end start end key test))) (frobs))) (defun %find-position-if (predicate sequence-arg from-end start end key) (macrolet ((frob (sequence from-end) - `(%find-position-if predicate ,sequence - ,from-end start end key)) - (vector*-frob (sequence) - `(%find-position-if-vector-macro predicate ,sequence - from-end start end key))) + `(%find-position-if predicate ,sequence + ,from-end start end key)) + (vector*-frob (sequence) + `(%find-position-if-vector-macro predicate ,sequence + from-end start end key))) (frobs))) (defun %find-position-if-not (predicate sequence-arg from-end start end key) (macrolet ((frob (sequence from-end) - `(%find-position-if-not predicate ,sequence - ,from-end start end key)) - (vector*-frob (sequence) - `(%find-position-if-not-vector-macro predicate ,sequence - from-end start end key))) + `(%find-position-if-not predicate ,sequence + ,from-end start end key)) + (vector*-frob (sequence) + `(%find-position-if-not-vector-macro predicate ,sequence + from-end start end key))) (frobs)))) ;;; the user interface to FIND and POSITION: just interpreter stubs, @@ -2040,26 +2040,26 @@ (defun find (item sequence &key from-end (start 0) end key test test-not) ;; FIXME: this can't be the way to go, surely? (find item sequence :from-end from-end :start start :end end :key key - :test test :test-not test-not)) + :test test :test-not test-not)) (defun position (item sequence &key from-end (start 0) end key test test-not) (position item sequence :from-end from-end :start start :end end :key key - :test test :test-not test-not)) + :test test :test-not test-not)) ;;; the user interface to FIND-IF and POSITION-IF, entirely analogous ;;; to the interface to FIND and POSITION (defun find-if (predicate sequence &key from-end (start 0) end key) (find-if predicate sequence :from-end from-end :start start - :end end :key key)) + :end end :key key)) (defun position-if (predicate sequence &key from-end (start 0) end key) (position-if predicate sequence :from-end from-end :start start - :end end :key key)) + :end end :key key)) (defun find-if-not (predicate sequence &key from-end (start 0) end key) (find-if-not predicate sequence :from-end from-end :start start - :end end :key key)) + :end end :key key)) (defun position-if-not (predicate sequence &key from-end (start 0) end key) (position-if-not predicate sequence :from-end from-end :start start - :end end :key key)) + :end end :key key)) ;;;; COUNT-IF, COUNT-IF-NOT, and COUNT @@ -2067,28 +2067,28 @@ (sb!xc:defmacro vector-count-if (notp from-end-p predicate sequence) (let ((next-index (if from-end-p '(1- index) '(1+ index))) - (pred `(funcall ,predicate (apply-key key (aref ,sequence index))))) + (pred `(funcall ,predicate (apply-key key (aref ,sequence index))))) `(let ((%start ,(if from-end-p '(1- end) 'start)) - (%end ,(if from-end-p '(1- start) 'end))) + (%end ,(if from-end-p '(1- start) 'end))) (do ((index %start ,next-index) - (count 0)) - ((= index (the fixnum %end)) count) - (declare (fixnum index count)) - (,(if notp 'unless 'when) ,pred - (setq count (1+ count))))))) + (count 0)) + ((= index (the fixnum %end)) count) + (declare (fixnum index count)) + (,(if notp 'unless 'when) ,pred + (setq count (1+ count))))))) (sb!xc:defmacro list-count-if (notp from-end-p predicate sequence) (let ((pred `(funcall ,predicate (apply-key key (pop sequence))))) `(let ((%start ,(if from-end-p '(- length end) 'start)) - (%end ,(if from-end-p '(- length start) 'end)) - (sequence ,(if from-end-p '(reverse sequence) 'sequence))) + (%end ,(if from-end-p '(- length start) 'end)) + (sequence ,(if from-end-p '(reverse sequence) 'sequence))) (do ((sequence (nthcdr %start ,sequence)) - (index %start (1+ index)) - (count 0)) - ((or (= index (the fixnum %end)) (null sequence)) count) - (declare (fixnum index count)) - (,(if notp 'unless 'when) ,pred - (setq count (1+ count))))))) + (index %start (1+ index)) + (count 0)) + ((or (= index (the fixnum %end)) (null sequence)) count) + (declare (fixnum index count)) + (,(if notp 'unless 'when) ,pred + (setq count (1+ count))))))) ) ; EVAL-WHEN @@ -2098,15 +2098,15 @@ "Return the number of elements in SEQUENCE satisfying PRED(el)." (declare (fixnum start)) (let ((end (or end length)) - (pred (%coerce-callable-to-fun pred))) + (pred (%coerce-callable-to-fun pred))) (declare (type index end)) (seq-dispatch sequence - (if from-end - (list-count-if nil t pred sequence) - (list-count-if nil nil pred sequence)) - (if from-end - (vector-count-if nil t pred sequence) - (vector-count-if nil nil pred sequence))))) + (if from-end + (list-count-if nil t pred sequence) + (list-count-if nil nil pred sequence)) + (if from-end + (vector-count-if nil t pred sequence) + (vector-count-if nil nil pred sequence))))) (define-sequence-traverser count-if-not (pred sequence &key from-end start end key) @@ -2114,19 +2114,19 @@ "Return the number of elements in SEQUENCE not satisfying TEST(el)." (declare (fixnum start)) (let ((end (or end length)) - (pred (%coerce-callable-to-fun pred))) + (pred (%coerce-callable-to-fun pred))) (declare (type index end)) (seq-dispatch sequence - (if from-end - (list-count-if t t pred sequence) - (list-count-if t nil pred sequence)) - (if from-end - (vector-count-if t t pred sequence) - (vector-count-if t nil pred sequence))))) + (if from-end + (list-count-if t t pred sequence) + (list-count-if t nil pred sequence)) + (if from-end + (vector-count-if t t pred sequence) + (vector-count-if t nil pred sequence))))) (define-sequence-traverser count (item sequence &key from-end start end - key (test #'eql test-p) (test-not nil test-not-p)) + key (test #'eql test-p) (test-not nil test-not-p)) #!+sb-doc "Return the number of elements in SEQUENCE satisfying a test with ITEM, which defaults to EQL." @@ -2138,17 +2138,17 @@ (let ((end (or end length))) (declare (type index end)) (let ((%test (if test-not-p - (lambda (x) - (not (funcall test-not item x))) - (lambda (x) - (funcall test item x))))) + (lambda (x) + (not (funcall test-not item x))) + (lambda (x) + (funcall test item x))))) (seq-dispatch sequence - (if from-end - (list-count-if nil t %test sequence) - (list-count-if nil nil %test sequence)) - (if from-end - (vector-count-if nil t %test sequence) - (vector-count-if nil nil %test sequence)))))) + (if from-end + (list-count-if nil t %test sequence) + (list-count-if nil nil %test sequence)) + (if from-end + (vector-count-if nil t %test sequence) + (vector-count-if nil nil %test sequence)))))) @@ -2158,19 +2158,19 @@ (sb!xc:defmacro match-vars (&rest body) `(let ((inc (if from-end -1 1)) - (start1 (if from-end (1- (the fixnum end1)) start1)) - (start2 (if from-end (1- (the fixnum end2)) start2)) - (end1 (if from-end (1- (the fixnum start1)) end1)) - (end2 (if from-end (1- (the fixnum start2)) end2))) + (start1 (if from-end (1- (the fixnum end1)) start1)) + (start2 (if from-end (1- (the fixnum end2)) start2)) + (end1 (if from-end (1- (the fixnum start1)) end1)) + (end2 (if from-end (1- (the fixnum start2)) end2))) (declare (fixnum inc start1 start2 end1 end2)) ,@body)) (sb!xc:defmacro matchify-list ((sequence start length end) &body body) (declare (ignore end)) ;; ### Should END be used below? `(let ((,sequence (if from-end - (nthcdr (- (the fixnum ,length) (the fixnum ,start) 1) - (reverse (the list ,sequence))) - (nthcdr ,start ,sequence)))) + (nthcdr (- (the fixnum ,length) (the fixnum ,start) 1) + (reverse (the list ,sequence))) + (nthcdr ,start ,sequence)))) (declare (type list ,sequence)) ,@body)) @@ -2180,46 +2180,46 @@ (sb!xc:defmacro if-mismatch (elt1 elt2) `(cond ((= (the fixnum index1) (the fixnum end1)) - (return (if (= (the fixnum index2) (the fixnum end2)) - nil - (if from-end - (1+ (the fixnum index1)) - (the fixnum index1))))) - ((= (the fixnum index2) (the fixnum end2)) - (return (if from-end (1+ (the fixnum index1)) index1))) - (test-not - (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2)) - (return (if from-end (1+ (the fixnum index1)) index1)))) - (t (if (not (funcall test (apply-key key ,elt1) - (apply-key key ,elt2))) - (return (if from-end (1+ (the fixnum index1)) index1)))))) + (return (if (= (the fixnum index2) (the fixnum end2)) + nil + (if from-end + (1+ (the fixnum index1)) + (the fixnum index1))))) + ((= (the fixnum index2) (the fixnum end2)) + (return (if from-end (1+ (the fixnum index1)) index1))) + (test-not + (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2)) + (return (if from-end (1+ (the fixnum index1)) index1)))) + (t (if (not (funcall test (apply-key key ,elt1) + (apply-key key ,elt2))) + (return (if from-end (1+ (the fixnum index1)) index1)))))) (sb!xc:defmacro mumble-mumble-mismatch () `(do ((index1 start1 (+ index1 (the fixnum inc))) - (index2 start2 (+ index2 (the fixnum inc)))) + (index2 start2 (+ index2 (the fixnum inc)))) (()) (declare (fixnum index1 index2)) (if-mismatch (aref sequence1 index1) (aref sequence2 index2)))) (sb!xc:defmacro mumble-list-mismatch () `(do ((index1 start1 (+ index1 (the fixnum inc))) - (index2 start2 (+ index2 (the fixnum inc)))) + (index2 start2 (+ index2 (the fixnum inc)))) (()) (declare (fixnum index1 index2)) (if-mismatch (aref sequence1 index1) (pop sequence2)))) (sb!xc:defmacro list-mumble-mismatch () `(do ((index1 start1 (+ index1 (the fixnum inc))) - (index2 start2 (+ index2 (the fixnum inc)))) + (index2 start2 (+ index2 (the fixnum inc)))) (()) (declare (fixnum index1 index2)) (if-mismatch (pop sequence1) (aref sequence2 index2)))) (sb!xc:defmacro list-list-mismatch () `(do ((sequence1 sequence1) - (sequence2 sequence2) - (index1 start1 (+ index1 (the fixnum inc))) - (index2 start2 (+ index2 (the fixnum inc)))) + (sequence2 sequence2) + (index1 start1 (+ index1 (the fixnum inc))) + (index2 start2 (+ index2 (the fixnum inc)))) (()) (declare (fixnum index1 index2)) (if-mismatch (pop sequence1) (pop sequence2)))) @@ -2228,8 +2228,8 @@ (define-sequence-traverser mismatch (sequence1 sequence2 - &key from-end test test-not - start1 end1 start2 end2 key) + &key from-end test test-not + start1 end1 start2 end2 key) #!+sb-doc "The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared element-wise. If they are of equal length and match in every element, the @@ -2241,19 +2241,19 @@ position in which the sequences differ is returned." (declare (fixnum start1 start2)) (let* ((end1 (or end1 length1)) - (end2 (or end2 length2))) + (end2 (or end2 length2))) (declare (type index end1 end2)) (match-vars (seq-dispatch sequence1 (matchify-list (sequence1 start1 length1 end1) - (seq-dispatch sequence2 - (matchify-list (sequence2 start2 length2 end2) - (list-list-mismatch)) - (list-mumble-mismatch))) + (seq-dispatch sequence2 + (matchify-list (sequence2 start2 length2 end2) + (list-list-mismatch)) + (list-mumble-mismatch))) (seq-dispatch sequence2 - (matchify-list (sequence2 start2 length2 end2) - (mumble-list-mismatch)) - (mumble-mumble-mismatch)))))) + (matchify-list (sequence2 start2 length2 end2) + (mumble-list-mismatch)) + (mumble-mumble-mismatch)))))) ;;; search comparison functions @@ -2263,49 +2263,49 @@ (sb!xc:defmacro compare-elements (elt1 elt2) `(if test-not (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2)) - (return nil) - t) + (return nil) + t) (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2))) - (return nil) - t))) + (return nil) + t))) (sb!xc:defmacro search-compare-list-list (main sub) `(do ((main ,main (cdr main)) - (jndex start1 (1+ jndex)) - (sub (nthcdr start1 ,sub) (cdr sub))) + (jndex start1 (1+ jndex)) + (sub (nthcdr start1 ,sub) (cdr sub))) ((or (endp main) (endp sub) (<= end1 jndex)) - t) + t) (declare (type (integer 0) jndex)) (compare-elements (car sub) (car main)))) (sb!xc:defmacro search-compare-list-vector (main sub) `(do ((main ,main (cdr main)) - (index start1 (1+ index))) + (index start1 (1+ index))) ((or (endp main) (= index end1)) t) (compare-elements (aref ,sub index) (car main)))) (sb!xc:defmacro search-compare-vector-list (main sub index) `(do ((sub (nthcdr start1 ,sub) (cdr sub)) - (jndex start1 (1+ jndex)) - (index ,index (1+ index))) + (jndex start1 (1+ jndex)) + (index ,index (1+ index))) ((or (<= end1 jndex) (endp sub)) t) (declare (type (integer 0) jndex)) (compare-elements (car sub) (aref ,main index)))) (sb!xc:defmacro search-compare-vector-vector (main sub index) `(do ((index ,index (1+ index)) - (sub-index start1 (1+ sub-index))) + (sub-index start1 (1+ sub-index))) ((= sub-index end1) t) (compare-elements (aref ,sub sub-index) (aref ,main index)))) (sb!xc:defmacro search-compare (main-type main sub index) (if (eq main-type 'list) `(seq-dispatch ,sub - (search-compare-list-list ,main ,sub) - (search-compare-list-vector ,main ,sub)) + (search-compare-list-list ,main ,sub) + (search-compare-list-vector ,main ,sub)) `(seq-dispatch ,sub - (search-compare-vector-list ,main ,sub ,index) - (search-compare-vector-vector ,main ,sub ,index)))) + (search-compare-vector-list ,main ,sub ,index) + (search-compare-vector-vector ,main ,sub ,index)))) ) ; EVAL-WHEN @@ -2315,36 +2315,36 @@ (sb!xc:defmacro list-search (main sub) `(do ((main (nthcdr start2 ,main) (cdr main)) - (index2 start2 (1+ index2)) - (terminus (- end2 (the (integer 0) (- end1 start1)))) - (last-match ())) + (index2 start2 (1+ index2)) + (terminus (- end2 (the (integer 0) (- end1 start1)))) + (last-match ())) ((> index2 terminus) last-match) (declare (type (integer 0) index2)) (if (search-compare list main ,sub index2) - (if from-end - (setq last-match index2) - (return index2))))) + (if from-end + (setq last-match index2) + (return index2))))) (sb!xc:defmacro vector-search (main sub) `(do ((index2 start2 (1+ index2)) - (terminus (- end2 (the (integer 0) (- end1 start1)))) - (last-match ())) + (terminus (- end2 (the (integer 0) (- end1 start1)))) + (last-match ())) ((> index2 terminus) last-match) (declare (type (integer 0) index2)) (if (search-compare vector ,main ,sub index2) - (if from-end - (setq last-match index2) - (return index2))))) + (if from-end + (setq last-match index2) + (return index2))))) ) ; EVAL-WHEN (define-sequence-traverser search (sequence1 sequence2 - &key from-end test test-not - start1 end1 start2 end2 key) + &key from-end test test-not + start1 end1 start2 end2 key) (declare (fixnum start1 start2)) (let ((end1 (or end1 length1)) - (end2 (or end2 length2))) + (end2 (or end2 length2))) (seq-dispatch sequence2 - (list-search sequence2 sequence1) - (vector-search sequence2 sequence1)))) + (list-search sequence2 sequence1) + (vector-search sequence2 sequence1)))) diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp index 1183d6c..426a48a 100644 --- a/src/code/serve-event.lisp +++ b/src/code/serve-event.lisp @@ -16,16 +16,16 @@ ;(defvar *port-table* (make-hash-table :test 'eql)) (defstruct (object-set - (:constructor make-object-set - (name &optional - (default-handler #'default-default-handler))) - (:print-object - (lambda (s stream) - (format stream "#" (object-set-name s)))) - (:copier nil)) - name ; Name, for descriptive purposes. + (:constructor make-object-set + (name &optional + (default-handler #'default-default-handler))) + (:print-object + (lambda (s stream) + (format stream "#" (object-set-name s)))) + (:copier nil)) + name ; Name, for descriptive purposes. (table (make-hash-table :test 'eq)) ; Message-ID or - ; xevent-type --> handler fun. + ; xevent-type --> handler fun. default-handler) #!+sb-doc @@ -57,24 +57,24 @@ ;;;; file descriptor I/O noise (defstruct (handler - (:constructor make-handler (direction descriptor function)) - (:copier nil)) + (:constructor make-handler (direction descriptor function)) + (:copier nil)) ;; Reading or writing... (direction nil :type (member :input :output)) ;; File descriptor this handler is tied to. (descriptor 0 :type (mod #.sb!unix:fd-setsize)) - active ; T iff this handler is running. + active ; T iff this handler is running. (function nil :type function) ; Function to call. - bogus) ; T if this descriptor is bogus. + bogus) ; T if this descriptor is bogus. (def!method print-object ((handler handler) stream) (print-unreadable-object (handler stream :type t) (format stream - "~A on ~:[~;BOGUS ~]descriptor ~W: ~S" - (handler-direction handler) - (handler-bogus handler) - (handler-descriptor handler) - (handler-function handler)))) + "~A on ~:[~;BOGUS ~]descriptor ~W: ~S" + (handler-direction handler) + (handler-bogus handler) + (handler-descriptor handler) + (handler-function handler)))) (defvar *descriptor-handlers* nil #!+sb-doc @@ -98,8 +98,8 @@ #!+sb-doc "Removes HANDLER from the list of active handlers." (setf *descriptor-handlers* - (delete handler *descriptor-handlers* - :test #'eq))) + (delete handler *descriptor-handlers* + :test #'eq))) ;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em. (defun invalidate-descriptor (fd) @@ -107,8 +107,8 @@ "Remove any handers refering to fd. This should only be used when attempting to recover from a detected inconsistancy." (setf *descriptor-handlers* - (delete fd *descriptor-handlers* - :key #'handler-descriptor))) + (delete fd *descriptor-handlers* + :key #'handler-descriptor))) ;;; Add the handler to *descriptor-handlers* for the duration of BODY. (defmacro with-fd-handler ((fd direction function) &rest body) @@ -119,11 +119,11 @@ (let ((handler (gensym))) `(let (,handler) (unwind-protect - (progn - (setf ,handler (add-fd-handler ,fd ,direction ,function)) - ,@body) - (when ,handler - (remove-fd-handler ,handler)))))) + (progn + (setf ,handler (add-fd-handler ,fd ,direction ,function)) + ,@body) + (when ,handler + (remove-fd-handler ,handler)))))) ;;; First, get a list and mark bad file descriptors. Then signal an error ;;; offering a few restarts. @@ -131,17 +131,17 @@ (let ((bogus-handlers nil)) (dolist (handler *descriptor-handlers*) (unless (or (handler-bogus handler) - (sb!unix:unix-fstat (handler-descriptor handler))) - (setf (handler-bogus handler) t) - (push handler bogus-handlers))) + (sb!unix:unix-fstat (handler-descriptor handler))) + (setf (handler-bogus handler) t) + (push handler bogus-handlers))) (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P." - bogus-handlers (length bogus-handlers)) + bogus-handlers (length bogus-handlers)) (remove-them () :report "Remove bogus handlers." (setf *descriptor-handlers* - (delete-if #'handler-bogus *descriptor-handlers*))) + (delete-if #'handler-bogus *descriptor-handlers*))) (retry-them () :report "Retry bogus handlers." (dolist (handler bogus-handlers) - (setf (handler-bogus handler) nil))) + (setf (handler-bogus handler) nil))) (continue () :report "Go on, leaving handlers marked as bogus.")))) ;;;; SERVE-ALL-EVENTS, SERVE-EVENT, and friends @@ -173,39 +173,39 @@ (multiple-value-bind (to-sec to-usec) (decode-timeout timeout) (declare (type (or index null) to-sec to-usec)) (multiple-value-bind (stop-sec stop-usec) - (if to-sec - (multiple-value-bind (okay start-sec start-usec) - (sb!unix:unix-gettimeofday) - (declare (ignore okay)) - (let ((usec (+ to-usec start-usec)) - (sec (+ to-sec start-sec))) - (declare (type (unsigned-byte 31) usec sec)) - (if (>= usec 1000000) - (values (1+ sec) (- usec 1000000)) - (values sec usec)))) - (values 0 0)) - (declare (type (unsigned-byte 31) stop-sec stop-usec)) - (with-fd-handler (fd direction (lambda (fd) - (declare (ignore fd)) - (setf usable t))) - (loop - (sub-serve-event to-sec to-usec) + (if to-sec + (multiple-value-bind (okay start-sec start-usec) + (sb!unix:unix-gettimeofday) + (declare (ignore okay)) + (let ((usec (+ to-usec start-usec)) + (sec (+ to-sec start-sec))) + (declare (type (unsigned-byte 31) usec sec)) + (if (>= usec 1000000) + (values (1+ sec) (- usec 1000000)) + (values sec usec)))) + (values 0 0)) + (declare (type (unsigned-byte 31) stop-sec stop-usec)) + (with-fd-handler (fd direction (lambda (fd) + (declare (ignore fd)) + (setf usable t))) + (loop + (sub-serve-event to-sec to-usec) - (when usable - (return t)) + (when usable + (return t)) - (when timeout - (multiple-value-bind (okay sec usec) (sb!unix:unix-gettimeofday) - (declare (ignore okay)) - (when (or (> sec stop-sec) - (and (= sec stop-sec) (>= usec stop-usec))) - (return nil)) - (setq to-sec (- stop-sec sec)) - (cond ((> usec stop-usec) - (decf to-sec) - (setq to-usec (- (+ stop-usec 1000000) usec))) - (t - (setq to-usec (- stop-usec usec)))))))))))) + (when timeout + (multiple-value-bind (okay sec usec) (sb!unix:unix-gettimeofday) + (declare (ignore okay)) + (when (or (> sec stop-sec) + (and (= sec stop-sec) (>= usec stop-usec))) + (return nil)) + (setq to-sec (- stop-sec sec)) + (cond ((> usec stop-usec) + (decf to-sec) + (setq to-usec (- (+ stop-usec 1000000) usec))) + (t + (setq to-usec (- stop-usec usec)))))))))))) ;;; Wait for up to timeout seconds for an event to happen. Make sure all ;;; pending events are processed before returning. @@ -244,14 +244,14 @@ (let ((count 0)) (declare (type index count)) (dolist (handler *descriptor-handlers*) - (unless (or (handler-active handler) - (handler-bogus handler)) - (let ((fd (handler-descriptor handler))) - (ecase (handler-direction handler) - (:input (sb!unix:fd-set fd read-fds)) - (:output (sb!unix:fd-set fd write-fds))) - (when (> fd count) - (setf count fd))))) + (unless (or (handler-active handler) + (handler-bogus handler)) + (let ((fd (handler-descriptor handler))) + (ecase (handler-direction handler) + (:input (sb!unix:fd-set fd read-fds)) + (:output (sb!unix:fd-set fd write-fds))) + (when (> fd count) + (setf count fd))))) (1+ count)))) ;;; Call file descriptor handlers according to the readable and writable masks @@ -260,19 +260,19 @@ '(let ((result nil)) (dolist (handler *descriptor-handlers*) (let ((desc (handler-descriptor handler))) - (when (ecase (handler-direction handler) - (:input (sb!unix:fd-isset desc read-fds)) - (:output (sb!unix:fd-isset desc write-fds))) - (unwind-protect - (progn - ;; Doesn't work -- ACK - ;(setf (handler-active handler) t) - (funcall (handler-function handler) desc)) - (setf (handler-active handler) nil)) - (ecase (handler-direction handler) - (:input (sb!unix:fd-clr desc read-fds)) - (:output (sb!unix:fd-clr desc write-fds))) - (setf result t))) + (when (ecase (handler-direction handler) + (:input (sb!unix:fd-isset desc read-fds)) + (:output (sb!unix:fd-isset desc write-fds))) + (unwind-protect + (progn + ;; Doesn't work -- ACK + ;(setf (handler-active handler) t) + (funcall (handler-function handler) desc)) + (setf (handler-active handler) nil)) + (ecase (handler-direction handler) + (:input (sb!unix:fd-clr desc read-fds)) + (:output (sb!unix:fd-clr desc write-fds))) + (setf result t))) result))) ) ; EVAL-WHEN @@ -292,37 +292,37 @@ (let ((call-polling-fn nil)) (when (and *periodic-polling-function* - ;; Enforce a maximum timeout. - (or (null to-sec) - (> to-sec *max-event-to-sec*) - (and (= to-sec *max-event-to-sec*) - (> to-usec *max-event-to-usec*)))) + ;; Enforce a maximum timeout. + (or (null to-sec) + (> to-sec *max-event-to-sec*) + (and (= to-sec *max-event-to-sec*) + (> to-usec *max-event-to-usec*)))) (setf to-sec *max-event-to-sec*) (setf to-usec *max-event-to-usec*) (setf call-polling-fn t)) ;; Next, wait for something to happen. (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set)) - (write-fds (sb!alien:struct sb!unix:fd-set))) + (write-fds (sb!alien:struct sb!unix:fd-set))) (let ((count (calc-masks))) - (multiple-value-bind (value err) - (sb!unix:unix-fast-select count - (sb!alien:addr read-fds) - (sb!alien:addr write-fds) - nil to-sec to-usec) - - ;; Now see what it was (if anything) - (cond (value - (cond ((zerop value) - ;; Timed out. - (when call-polling-fn - (funcall *periodic-polling-function*))) - (t - (call-fd-handler)))) - ((eql err sb!unix:eintr) - ;; We did an interrupt. - t) - (t - ;; One of the file descriptors is bad. - (handler-descriptors-error) - nil))))))) + (multiple-value-bind (value err) + (sb!unix:unix-fast-select count + (sb!alien:addr read-fds) + (sb!alien:addr write-fds) + nil to-sec to-usec) + + ;; Now see what it was (if anything) + (cond (value + (cond ((zerop value) + ;; Timed out. + (when call-polling-fn + (funcall *periodic-polling-function*))) + (t + (call-fd-handler)))) + ((eql err sb!unix:eintr) + ;; We did an interrupt. + t) + (t + ;; One of the file descriptors is bad. + (handler-descriptors-error) + nil))))))) diff --git a/src/code/setf-funs.lisp b/src/code/setf-funs.lisp index 3e18ea6..5899a24 100644 --- a/src/code/setf-funs.lisp +++ b/src/code/setf-funs.lisp @@ -16,18 +16,18 @@ (defun compute-one-setter (name type) (let* ((args (second type)) - (res (type-specifier - (single-value-type - (values-specifier-type (third type))))) - (arglist (make-gensym-list (1+ (length args))))) + (res (type-specifier + (single-value-type + (values-specifier-type (third type))))) + (arglist (make-gensym-list (1+ (length args))))) (cond ((null (intersection args sb!xc:lambda-list-keywords)) `(defun (setf ,name) ,arglist - (declare ,@(mapcar (lambda (arg type) - `(type ,type ,arg)) - arglist - (cons res args))) - (setf (,name ,@(rest arglist)) ,(first arglist)))) + (declare ,@(mapcar (lambda (arg type) + `(type ,type ,arg)) + arglist + (cons res args))) + (setf (,name ,@(rest arglist)) ,(first arglist)))) (t (warn "hairy SETF expander for function ~S" name) nil)))) @@ -37,15 +37,15 @@ (collect ((res)) (dolist (pkg packages) (do-external-symbols (sym pkg) - (when (and (fboundp sym) - (eq (info :function :kind sym) :function) - (or (info :setf :inverse sym) - (info :setf :expander sym)) - (not (member sym ignore))) - (let ((type (type-specifier (info :function :type sym)))) - (aver (consp type)) - #!-sb-fluid (res `(declaim (inline (setf ,sym)))) - (res (compute-one-setter sym type)))))) + (when (and (fboundp sym) + (eq (info :function :kind sym) :function) + (or (info :setf :inverse sym) + (info :setf :expander sym)) + (not (member sym ignore))) + (let ((type (type-specifier (info :function :type sym)))) + (aver (consp type)) + #!-sb-fluid (res `(declaim (inline (setf ,sym)))) + (res (compute-one-setter sym type)))))) `(progn ,@(res)))) ) ; EVAL-WHEN diff --git a/src/code/sharpm.lisp b/src/code/sharpm.lisp index 08665e7..0fa36ce 100644 --- a/src/code/sharpm.lisp +++ b/src/code/sharpm.lisp @@ -21,68 +21,68 @@ (defun sharp-left-paren (stream ignore length) (declare (ignore ignore) (special *backquote-count*)) (let* ((list (read-list stream nil)) - (listlength (handler-case (length list) - (type-error - (error) - (declare (ignore error)) - (%reader-error stream "improper list in #(): ~S" - list))))) + (listlength (handler-case (length list) + (type-error + (error) + (declare (ignore error)) + (%reader-error stream "improper list in #(): ~S" + list))))) (declare (list list) - (fixnum listlength)) + (fixnum listlength)) (cond (*read-suppress* nil) - ((zerop *backquote-count*) - (if length - (cond ((> listlength (the fixnum length)) - (%reader-error - stream - "vector longer than specified length: #~S~S" - length list)) - (t - (fill (the simple-vector - (replace (the simple-vector - (make-array length)) - list)) - (car (last list)) - :start listlength))) - (coerce list 'vector))) - (t (cons *bq-vector-flag* list))))) + ((zerop *backquote-count*) + (if length + (cond ((> listlength (the fixnum length)) + (%reader-error + stream + "vector longer than specified length: #~S~S" + length list)) + (t + (fill (the simple-vector + (replace (the simple-vector + (make-array length)) + list)) + (car (last list)) + :start listlength))) + (coerce list 'vector))) + (t (cons *bq-vector-flag* list))))) (defun sharp-star (stream ignore numarg) (declare (ignore ignore)) (multiple-value-bind (bstring escape-appearedp) (read-extended-token stream) (declare (simple-string bstring)) (cond (*read-suppress* nil) - (escape-appearedp - (%reader-error stream "An escape character appeared after #*")) - ((and numarg (zerop (length bstring)) (not (zerop numarg))) - (%reader-error - stream - "You have to give a little bit for non-zero #* bit-vectors.")) - ((or (null numarg) (>= (the fixnum numarg) (length bstring))) - (let* ((len1 (length bstring)) - (last1 (1- len1)) - (len2 (or numarg len1)) - (bvec (make-array len2 :element-type 'bit - :initial-element 0))) - (declare (fixnum len1 last1 len2)) - (do ((i 0 (1+ i)) - (char ())) - ((= i len2)) - (declare (fixnum i)) - (setq char (elt bstring (if (< i len1) i last1))) - (setf (elt bvec i) - (cond ((char= char #\0) 0) - ((char= char #\1) 1) - (t - (%reader-error - stream - "illegal element given for bit-vector: ~S" - char))))) - bvec)) - (t - (%reader-error stream - "Bit vector is longer than specified length #~A*~A" - numarg bstring))))) + (escape-appearedp + (%reader-error stream "An escape character appeared after #*")) + ((and numarg (zerop (length bstring)) (not (zerop numarg))) + (%reader-error + stream + "You have to give a little bit for non-zero #* bit-vectors.")) + ((or (null numarg) (>= (the fixnum numarg) (length bstring))) + (let* ((len1 (length bstring)) + (last1 (1- len1)) + (len2 (or numarg len1)) + (bvec (make-array len2 :element-type 'bit + :initial-element 0))) + (declare (fixnum len1 last1 len2)) + (do ((i 0 (1+ i)) + (char ())) + ((= i len2)) + (declare (fixnum i)) + (setq char (elt bstring (if (< i len1) i last1))) + (setf (elt bvec i) + (cond ((char= char #\0) 0) + ((char= char #\1) 1) + (t + (%reader-error + stream + "illegal element given for bit-vector: ~S" + char))))) + bvec)) + (t + (%reader-error stream + "Bit vector is longer than specified length #~A*~A" + numarg bstring))))) (defun sharp-A (stream ignore dimensions) (declare (ignore ignore)) @@ -92,23 +92,23 @@ (unless dimensions (%reader-error stream "no dimensions argument to #A")) (collect ((dims)) (let* ((contents (read stream t nil t)) - (seq contents)) + (seq contents)) (dotimes (axis dimensions - (make-array (dims) :initial-contents contents)) - (unless (typep seq 'sequence) - (%reader-error stream - "#~WA axis ~W is not a sequence:~% ~S" - dimensions axis seq)) - (let ((len (length seq))) - (dims len) - (unless (or (= axis (1- dimensions)) - ;; ANSI: "If some dimension of the array whose - ;; representation is being parsed is found to be - ;; 0, all dimensions to the right (i.e., the - ;; higher numbered dimensions) are also - ;; considered to be 0." - (= len 0)) - (setq seq (elt seq 0)))))))) + (make-array (dims) :initial-contents contents)) + (unless (typep seq 'sequence) + (%reader-error stream + "#~WA axis ~W is not a sequence:~% ~S" + dimensions axis seq)) + (let ((len (length seq))) + (dims len) + (unless (or (= axis (1- dimensions)) + ;; ANSI: "If some dimension of the array whose + ;; representation is being parsed is found to be + ;; 0, all dimensions to the right (i.e., the + ;; higher numbered dimensions) are also + ;; considered to be 0." + (= len 0)) + (setq seq (elt seq 0)))))))) ;;;; reading structure instances: the #S readmacro @@ -118,60 +118,60 @@ (read stream t nil t) (return-from sharp-S nil)) (let ((body (if (char= (read-char stream t) #\( ) - (read-list stream nil) - (%reader-error stream "non-list following #S")))) + (read-list stream nil) + (%reader-error stream "non-list following #S")))) (unless (listp body) (%reader-error stream "non-list following #S: ~S" body)) (unless (symbolp (car body)) (%reader-error stream "Structure type is not a symbol: ~S" (car body))) (let ((classoid (find-classoid (car body) nil))) (unless (typep classoid 'structure-classoid) - (%reader-error stream "~S is not a defined structure type." - (car body))) + (%reader-error stream "~S is not a defined structure type." + (car body))) (let ((def-con (dd-default-constructor - (layout-info - (classoid-layout classoid))))) - (unless def-con - (%reader-error - stream "The ~S structure does not have a default constructor." - (car body))) - (when (and (atom (rest body)) - (not (null (rest body)))) - (%reader-error - stream "improper list for #S: ~S." body)) - (apply (fdefinition def-con) - (loop for tail on (rest body) by #'cddr - with slot-name = (and (consp tail) (car tail)) - do (progn - (when (null (cdr tail)) - (%reader-error - stream - "the arglist for the ~S constructor in #S ~ + (layout-info + (classoid-layout classoid))))) + (unless def-con + (%reader-error + stream "The ~S structure does not have a default constructor." + (car body))) + (when (and (atom (rest body)) + (not (null (rest body)))) + (%reader-error + stream "improper list for #S: ~S." body)) + (apply (fdefinition def-con) + (loop for tail on (rest body) by #'cddr + with slot-name = (and (consp tail) (car tail)) + do (progn + (when (null (cdr tail)) + (%reader-error + stream + "the arglist for the ~S constructor in #S ~ has an odd length: ~S." - (car body) (rest body))) - (when (or (atom (cdr tail)) - (and (atom (cddr tail)) - (not (null (cddr tail))))) - (%reader-error - stream - "the arglist for the ~S constructor in #S ~ + (car body) (rest body))) + (when (or (atom (cdr tail)) + (and (atom (cddr tail)) + (not (null (cddr tail))))) + (%reader-error + stream + "the arglist for the ~S constructor in #S ~ is improper: ~S." - (car body) (rest body))) - (when (not (typep (car tail) 'string-designator)) - (%reader-error - stream - "a slot name in #S is not a string ~ + (car body) (rest body))) + (when (not (typep (car tail) 'string-designator)) + (%reader-error + stream + "a slot name in #S is not a string ~ designator: ~S." - slot-name)) - (when (not (keywordp slot-name)) + slot-name)) + (when (not (keywordp slot-name)) (warn 'structure-initarg-not-keyword :format-control "in #S ~S, the use of non-keywords ~ as slot specifiers is deprecated: ~S." :format-arguments (list (car body) slot-name)))) - collect (intern (string (car tail)) *keyword-package*) - collect (cadr tail))))))) + collect (intern (string (car tail)) *keyword-package*) + collect (cadr tail))))))) ;;;; reading numbers: the #B, #C, #O, #R, and #X readmacros @@ -185,8 +185,8 @@ (let ((cnum (read stream t nil t))) (when *read-suppress* (return-from sharp-C nil)) (if (and (listp cnum) (= (length cnum) 2)) - (complex (car cnum) (cadr cnum)) - (%reader-error stream "illegal complex number format: #C~S" cnum)))) + (complex (car cnum) (cadr cnum)) + (%reader-error stream "illegal complex number format: #C~S" cnum)))) (defun sharp-O (stream sub-char numarg) (ignore-numarg sub-char numarg) @@ -194,22 +194,22 @@ (defun sharp-R (stream sub-char radix) (cond (*read-suppress* - (read-extended-token stream) - nil) - ((not radix) - (%reader-error stream "radix missing in #R")) - ((not (<= 2 radix 36)) - (%reader-error stream "illegal radix for #R: ~D." radix)) - (t - (let ((res (let ((*read-base* radix)) - (read stream t nil t)))) - (unless (typep res 'rational) - (%reader-error stream - "#~A (base ~D.) value is not a rational: ~S." - sub-char - radix - res)) - res)))) + (read-extended-token stream) + nil) + ((not radix) + (%reader-error stream "radix missing in #R")) + ((not (<= 2 radix 36)) + (%reader-error stream "illegal radix for #R: ~D." radix)) + (t + (let ((res (let ((*read-base* radix)) + (read stream t nil t)))) + (unless (typep res 'rational) + (%reader-error stream + "#~A (base ~D.) value is not a rational: ~S." + sub-char + radix + res)) + res)))) (defun sharp-X (stream sub-char numarg) (ignore-numarg sub-char numarg) @@ -226,37 +226,37 @@ ;; alist of the things to be replaced assoc'd with the things to replace them. (defun circle-subst (old-new-alist tree) (cond ((not (typep tree - '(or cons (array t) structure-object standard-object))) - (let ((entry (find tree old-new-alist :key #'second))) - (if entry (third entry) tree))) - ((null (gethash tree *sharp-equal-circle-table*)) - (setf (gethash tree *sharp-equal-circle-table*) t) - (cond ((typep tree '(or structure-object standard-object)) - (do ((i 1 (1+ i)) - (end (%instance-length tree))) - ((= i end)) - (let* ((old (%instance-ref tree i)) - (new (circle-subst old-new-alist old))) - (unless (eq old new) - (setf (%instance-ref tree i) new))))) - ((arrayp tree) - (with-array-data ((data tree) (start) (end)) - (declare (fixnum start end)) - (do ((i start (1+ i))) - ((>= i end)) - (let* ((old (aref data i)) - (new (circle-subst old-new-alist old))) - (unless (eq old new) - (setf (aref data i) new)))))) - (t - (let ((a (circle-subst old-new-alist (car tree))) - (d (circle-subst old-new-alist (cdr tree)))) - (unless (eq a (car tree)) - (rplaca tree a)) - (unless (eq d (cdr tree)) - (rplacd tree d))))) - tree) - (t tree))) + '(or cons (array t) structure-object standard-object))) + (let ((entry (find tree old-new-alist :key #'second))) + (if entry (third entry) tree))) + ((null (gethash tree *sharp-equal-circle-table*)) + (setf (gethash tree *sharp-equal-circle-table*) t) + (cond ((typep tree '(or structure-object standard-object)) + (do ((i 1 (1+ i)) + (end (%instance-length tree))) + ((= i end)) + (let* ((old (%instance-ref tree i)) + (new (circle-subst old-new-alist old))) + (unless (eq old new) + (setf (%instance-ref tree i) new))))) + ((arrayp tree) + (with-array-data ((data tree) (start) (end)) + (declare (fixnum start end)) + (do ((i start (1+ i))) + ((>= i end)) + (let* ((old (aref data i)) + (new (circle-subst old-new-alist old))) + (unless (eq old new) + (setf (aref data i) new)))))) + (t + (let ((a (circle-subst old-new-alist (car tree))) + (d (circle-subst old-new-alist (cdr tree)))) + (unless (eq a (car tree)) + (rplaca tree a)) + (unless (eq d (cdr tree)) + (rplacd tree d))))) + tree) + (t tree))) ;;; Sharp-equal works as follows. When a label is assigned (i.e. when ;;; #= is called) we GENSYM a symbol is which is used as an @@ -281,15 +281,15 @@ (unless label (%reader-error stream "missing label for #=" label)) (when (or (assoc label *sharp-sharp-alist*) - (assoc label *sharp-equal-alist*)) + (assoc label *sharp-equal-alist*)) (%reader-error stream "multiply defined label: #~D=" label)) (let* ((tag (gensym)) - (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*)) - (obj (read stream t nil t))) + (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*)) + (obj (read stream t nil t))) (when (eq obj tag) (%reader-error stream - "must tag something more than just #~D#" - label)) + "must tag something more than just #~D#" + label)) (push (list label tag obj) *sharp-equal-alist*) (let ((*sharp-equal-circle-table* (make-hash-table :test 'eq :size 20))) (circle-subst *sharp-equal-alist* obj)))) @@ -302,28 +302,28 @@ (let ((entry (assoc label *sharp-equal-alist*))) (if entry - (third entry) - (let ((pair (assoc label *sharp-sharp-alist*))) - (unless pair - (%reader-error stream "object is not labelled #~S#" label)) - (cdr pair))))) + (third entry) + (let ((pair (assoc label *sharp-sharp-alist*))) + (unless pair + (%reader-error stream "object is not labelled #~S#" label)) + (cdr pair))))) ;;;; conditional compilation: the #+ and #- readmacros (flet ((guts (stream not-p) - (unless (if (handler-case - (let ((*package* *keyword-package*) - (*read-suppress* nil)) - (featurep (read stream t nil t))) - (reader-package-error - (condition) - (declare (ignore condition)) - nil)) - (not not-p) - not-p) - (let ((*read-suppress* t)) - (read stream t nil t))) - (values))) + (unless (if (handler-case + (let ((*package* *keyword-package*) + (*read-suppress* nil)) + (featurep (read stream t nil t))) + (reader-package-error + (condition) + (declare (ignore condition)) + nil)) + (not not-p) + not-p) + (let ((*read-suppress* t)) + (read stream t nil t))) + (values))) (defun sharp-plus (stream sub-char numarg) (ignore-numarg sub-char numarg) @@ -346,50 +346,50 @@ (let ((charstring (read-extended-token-escaped stream))) (declare (simple-string charstring)) (cond (*read-suppress* nil) - ((= (the fixnum (length charstring)) 1) - (char charstring 0)) - ((name-char charstring)) - (t - (%reader-error stream "unrecognized character name: ~S" - charstring))))) + ((= (the fixnum (length charstring)) 1) + (char charstring 0)) + ((name-char charstring)) + (t + (%reader-error stream "unrecognized character name: ~S" + charstring))))) (defun sharp-vertical-bar (stream sub-char numarg) (ignore-numarg sub-char numarg) (handler-bind ((character-decoding-error - #'(lambda (decoding-error) - (declare (ignorable decoding-error)) - (style-warn "Character decoding error in a #|-comment at position ~A reading source file ~A, resyncing." (file-position stream) stream) - (invoke-restart 'attempt-resync)))) + #'(lambda (decoding-error) + (declare (ignorable decoding-error)) + (style-warn "Character decoding error in a #|-comment at position ~A reading source file ~A, resyncing." (file-position stream) stream) + (invoke-restart 'attempt-resync)))) (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) - (prepare-for-fast-read-char stream - (do ((level 1) - (prev (fast-read-char) char) - (char (fast-read-char) (fast-read-char))) - (()) - (cond ((and (char= prev #\|) (char= char #\#)) - (setq level (1- level)) - (when (zerop level) - (done-with-fast-read-char) - (return (values))) - (setq char (fast-read-char))) - ((and (char= prev #\#) (char= char #\|)) - (setq char (fast-read-char)) - (setq level (1+ level)))))) - ;; fundamental-stream - (do ((level 1) - (prev (read-char stream t) char) - (char (read-char stream t) (read-char stream t))) - (()) - (cond ((and (char= prev #\|) (char= char #\#)) - (setq level (1- level)) - (when (zerop level) - (return (values))) - (setq char (read-char stream t))) - ((and (char= prev #\#) (char= char #\|)) - (setq char (read-char stream t)) - (setq level (1+ level))))))))) + (prepare-for-fast-read-char stream + (do ((level 1) + (prev (fast-read-char) char) + (char (fast-read-char) (fast-read-char))) + (()) + (cond ((and (char= prev #\|) (char= char #\#)) + (setq level (1- level)) + (when (zerop level) + (done-with-fast-read-char) + (return (values))) + (setq char (fast-read-char))) + ((and (char= prev #\#) (char= char #\|)) + (setq char (fast-read-char)) + (setq level (1+ level)))))) + ;; fundamental-stream + (do ((level 1) + (prev (read-char stream t) char) + (char (read-char stream t) (read-char stream t))) + (()) + (cond ((and (char= prev #\|) (char= char #\#)) + (setq level (1- level)) + (when (zerop level) + (return (values))) + (setq char (read-char stream t))) + ((and (char= prev #\#) (char= char #\|)) + (setq char (read-char stream t)) + (setq level (1+ level))))))))) ;;;; a grab bag of other sharp readmacros: #', #:, and #. @@ -406,8 +406,8 @@ (*read-suppress* nil) (colon (%reader-error stream - "The symbol following #: contains a package marker: ~S" - token)) + "The symbol following #: contains a package marker: ~S" + token)) (t (make-symbol token))))) @@ -420,7 +420,7 @@ (let ((token (read stream t nil t))) (unless *read-suppress* (unless *read-eval* - (%reader-error stream "can't read #. while *READ-EVAL* is NIL")) + (%reader-error stream "can't read #. while *READ-EVAL* is NIL")) (eval token)))) (defun sharp-illegal (stream sub-char ignore) diff --git a/src/code/show.lisp b/src/code/show.lisp index 4120a0e..f22336b 100644 --- a/src/code/show.lisp +++ b/src/code/show.lisp @@ -45,9 +45,9 @@ ;; with "caught WARNING: defining setf macro for AREF when (SETF ;; AREF) was previously treated as a function" during compilation of ;; defsetfs.lisp - ;; + ;; ;; #-sb-xc-host (sb!sys:%primitive print - ;; (concatenate 'simple-string "/can't /SHOW:" string)) + ;; (concatenate 'simple-string "/can't /SHOW:" string)) ;; ;; because the CONCATENATE is transformed to an expression involving ;; (SETF AREF). Not declaring the argument as a SIMPLE-STRING (or @@ -67,30 +67,30 @@ #!+sb-show (defun suppress-/show-p () (cond (;; protection against /SHOW too early in cold init for - ;; (FORMAT *TRACE-OUTPUT* ..) to work, part I: Obviously - ;; we need *TRACE-OUTPUT* bound. - (not (boundp '*trace-output*)) - (cannot-/show "*TRACE-OUTPUT* isn't bound. (Try /SHOW0.)") - t) - (;; protection against /SHOW too early in cold init for - ;; (FORMAT *TRACE-OUTPUT* ..) to work, part II: In a virtuoso - ;; display of name mnemonicity, *READTABLE* is used by the - ;; printer to decide which case convention to use when - ;; writing symbols, so we need it bound. - (not (boundp '*readtable*)) - (cannot-/show "*READTABLE* isn't bound. (Try /SHOW0.)") - t) - (;; more protection against /SHOW too early in cold init, part III - (not (boundp '*/show*)) - (cannot-/show "*/SHOW* isn't bound. (Try initializing it earlier.)") - t) - (;; ordinary, healthy reason to suppress /SHOW, no error - ;; output needed - (not */show*) - t) - (t - ;; Let the /SHOW go on. - nil))) + ;; (FORMAT *TRACE-OUTPUT* ..) to work, part I: Obviously + ;; we need *TRACE-OUTPUT* bound. + (not (boundp '*trace-output*)) + (cannot-/show "*TRACE-OUTPUT* isn't bound. (Try /SHOW0.)") + t) + (;; protection against /SHOW too early in cold init for + ;; (FORMAT *TRACE-OUTPUT* ..) to work, part II: In a virtuoso + ;; display of name mnemonicity, *READTABLE* is used by the + ;; printer to decide which case convention to use when + ;; writing symbols, so we need it bound. + (not (boundp '*readtable*)) + (cannot-/show "*READTABLE* isn't bound. (Try /SHOW0.)") + t) + (;; more protection against /SHOW too early in cold init, part III + (not (boundp '*/show*)) + (cannot-/show "*/SHOW* isn't bound. (Try initializing it earlier.)") + t) + (;; ordinary, healthy reason to suppress /SHOW, no error + ;; output needed + (not */show*) + t) + (t + ;; Let the /SHOW go on. + nil))) ;;; shorthand for a common idiom in output statements used in ;;; debugging: (/SHOW "Case 2:" X Y) becomes a pretty-printed version @@ -99,35 +99,35 @@ #!-sb-show (declare (ignore xlist)) #!+sb-show (flet (;; Is X something we want to just show literally by itself? - ;; (instead of showing it as NAME=VALUE) - (literal-p (x) (or (stringp x) (numberp x)))) + ;; (instead of showing it as NAME=VALUE) + (literal-p (x) (or (stringp x) (numberp x)))) ;; We build a FORMAT statement out of what we find in XLIST. (let ((format-stream (make-string-output-stream)) ; string arg to FORMAT - (format-reverse-rest) ; reversed &REST argument to FORMAT - (first-p t)) ; first pass through loop? + (format-reverse-rest) ; reversed &REST argument to FORMAT + (first-p t)) ; first pass through loop? (write-string "~&~<~;/" format-stream) (dolist (x xlist) - (if first-p - (setq first-p nil) - (write-string #+ansi-cl " ~_" - #-ansi-cl " " ; for CLISP (CLTL1-ish) - format-stream)) - (if (literal-p x) - (princ x format-stream) - (progn (let ((*print-pretty* nil)) - (format format-stream "~S=~~S" x)) - (push x format-reverse-rest)))) + (if first-p + (setq first-p nil) + (write-string #+ansi-cl " ~_" + #-ansi-cl " " ; for CLISP (CLTL1-ish) + format-stream)) + (if (literal-p x) + (princ x format-stream) + (progn (let ((*print-pretty* nil)) + (format format-stream "~S=~~S" x)) + (push x format-reverse-rest)))) (write-string "~;~:>~%" format-stream) (let ((format-string (get-output-stream-string format-stream)) - (format-rest (reverse format-reverse-rest))) - `(locally - (declare (optimize (speed 1) (space 2) (safety 3))) - (unless (suppress-/show-p) - (format *trace-output* - ,format-string - #+ansi-cl (list ,@format-rest) - #-ansi-cl ,@format-rest)) ; for CLISP (CLTL1-ish) - (values)))))) + (format-rest (reverse format-reverse-rest))) + `(locally + (declare (optimize (speed 1) (space 2) (safety 3))) + (unless (suppress-/show-p) + (format *trace-output* + ,format-string + #+ansi-cl (list ,@format-rest) + #-ansi-cl ,@format-rest)) ; for CLISP (CLTL1-ish) + (values)))))) ;;; a disabled-at-compile-time /SHOW, implemented as a macro instead ;;; of a function so that leaving occasionally-useful /SHOWs in place @@ -156,14 +156,14 @@ ;; this code gets compiled before DO-ANONYMOUS is defined. (declare (notinline mapcar)) (let ((s (apply #'concatenate - 'simple-string - (mapcar #'string string-designators)))) + 'simple-string + (mapcar #'string string-designators)))) (declare (ignorable s)) ; (for when #!-SB-SHOW) #+sb-xc-host `(/show ,s) #-sb-xc-host `(progn - #!+sb-show - (sb!sys:%primitive print - ,(concatenate 'simple-string "/" s))))) + #!+sb-show + (sb!sys:%primitive print + ,(concatenate 'simple-string "/" s))))) (defmacro /noshow0 (&rest rest) (declare (ignore rest))) diff --git a/src/code/signal.lisp b/src/code/signal.lisp index b3dd8eb..55eb7ca 100644 --- a/src/code/signal.lisp +++ b/src/code/signal.lisp @@ -70,8 +70,8 @@ (let ((name (gensym))) `(flet ((,name () ,@body)) (if *interrupts-enabled* - (,name) - (let ((*interrupts-enabled* t)) - (when *interrupt-pending* - (receive-pending-interrupt)) - (,name)))))) + (,name) + (let ((*interrupts-enabled* t)) + (when *interrupt-pending* + (receive-pending-interrupt)) + (,name)))))) diff --git a/src/code/sort.lisp b/src/code/sort.lisp index 636c417..1c21986 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -38,10 +38,10 @@ sequence) (t (error 'simple-type-error - :datum sequence - :expected-type 'sequence - :format-control "~S is not a sequence." - :format-arguments (list sequence)))))) + :datum sequence + :expected-type 'sequence + :format-control "~S is not a sequence." + :format-arguments (list sequence)))))) ;;;; stable sorting @@ -74,18 +74,18 @@ (eval-when (:compile-toplevel :execute) (sb!xc:defmacro apply-keyed-pred (one two pred key) `(if ,key - (funcall ,pred (funcall ,key ,one) - (funcall ,key ,two)) - (funcall ,pred ,one ,two))) + (funcall ,pred (funcall ,key ,one) + (funcall ,key ,two)) + (funcall ,pred ,one ,two))) ) ; EVAL-WHEN ;;;; stable sort of lists (defun last-cons-of (list) (loop (let ((rest (rest list))) - (if rest - (setf list rest) - (return list))))) + (if rest + (setf list rest) + (return list))))) ;;; Destructively merge LIST-1 with LIST-2 (given that they're already ;;; sorted w.r.t. PRED-FUN on KEY-FUN, giving output sorted the same @@ -116,12 +116,12 @@ ;; Now maybe we're done. (if (endp ,list-i) (return (values (nreconc - reversed-result-so-far - ,other-list) - (last-cons-of - ,other-list))) + reversed-result-so-far + ,other-list) + (last-cons-of + ,other-list))) (setf ,key-i - (funcall key-fun (car ,list-i))))))) + (funcall key-fun (car ,list-i))))))) ;; Note that by making KEY-2 the first arg to ;; PRED-FUN, we arrange that if PRED-FUN is a function ;; in the #'< style, the outcome is stably sorted. @@ -140,11 +140,11 @@ ;;; remaining elements. (defun stable-sort-list (list pred-fun key-fun) (let ((head (cons :header list)) ; head holds on to everything - (n 1) ; bottom-up size of lists to be merged - unsorted ; unsorted is the remaining list to be - ; broken into n size lists and merged - list-1 ; list-1 is one length n list to be merged - last) ; last points to the last visited cell + (n 1) ; bottom-up size of lists to be merged + unsorted ; unsorted is the remaining list to be + ; broken into n size lists and merged + list-1 ; list-1 is one length n list to be merged + last) ; last points to the last visited cell (declare (type function pred-fun key-fun) (type fixnum n)) (loop @@ -155,34 +155,34 @@ (let ((n-1 (1- n))) (declare (fixnum n-1)) (loop - (setf list-1 unsorted) - (let ((temp (nthcdr n-1 list-1)) - list-2) - (cond (temp - ;; There are enough elements for a second run. - (setf list-2 (cdr temp)) - (setf (cdr temp) nil) - (setf temp (nthcdr n-1 list-2)) - (cond (temp - (setf unsorted (cdr temp)) - (setf (cdr temp) nil)) - ;; The second run goes off the end of the list. - (t (setf unsorted nil))) - (multiple-value-bind (merged-head merged-last) - (merge-lists* list-1 list-2 pred-fun key-fun) - (setf (cdr last) merged-head - last merged-last)) - (if (null unsorted) (return))) - ;; If there is only one run, then tack it on to the end. - (t (setf (cdr last) list-1) - (return))))) + (setf list-1 unsorted) + (let ((temp (nthcdr n-1 list-1)) + list-2) + (cond (temp + ;; There are enough elements for a second run. + (setf list-2 (cdr temp)) + (setf (cdr temp) nil) + (setf temp (nthcdr n-1 list-2)) + (cond (temp + (setf unsorted (cdr temp)) + (setf (cdr temp) nil)) + ;; The second run goes off the end of the list. + (t (setf unsorted nil))) + (multiple-value-bind (merged-head merged-last) + (merge-lists* list-1 list-2 pred-fun key-fun) + (setf (cdr last) merged-head + last merged-last)) + (if (null unsorted) (return))) + ;; If there is only one run, then tack it on to the end. + (t (setf (cdr last) list-1) + (return))))) (setf n (ash n 1)) ; (+ n n) ;; If the inner loop only executed once, then there were only ;; enough elements for two runs given n, so all the elements ;; have been merged into one list. This may waste one outer ;; iteration to realize. (if (eq list-1 (cdr head)) - (return list-1)))))) + (return list-1)))))) ;;;; stable sort of vectors @@ -198,40 +198,40 @@ ;;; and merges them into a target vector starting at index start-1. (sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2 - pred key source-ref - target-ref) + pred key source-ref + target-ref) (let ((i (gensym)) - (j (gensym)) - (target-i (gensym))) + (j (gensym)) + (target-i (gensym))) `(let ((,i ,start-1) - (,j ,end-1) ; start-2 - (,target-i ,start-1)) + (,j ,end-1) ; start-2 + (,target-i ,start-1)) (declare (fixnum ,i ,j ,target-i)) (loop - (cond ((= ,i ,end-1) - (loop (if (= ,j ,end-2) (return)) - (setf (,target-ref ,target ,target-i) - (,source-ref ,source ,j)) - (incf ,target-i) - (incf ,j)) - (return)) - ((= ,j ,end-2) - (loop (if (= ,i ,end-1) (return)) - (setf (,target-ref ,target ,target-i) - (,source-ref ,source ,i)) - (incf ,target-i) - (incf ,i)) - (return)) - ((apply-keyed-pred (,source-ref ,source ,j) - (,source-ref ,source ,i) - ,pred ,key) - (setf (,target-ref ,target ,target-i) - (,source-ref ,source ,j)) - (incf ,j)) - (t (setf (,target-ref ,target ,target-i) - (,source-ref ,source ,i)) - (incf ,i))) - (incf ,target-i))))) + (cond ((= ,i ,end-1) + (loop (if (= ,j ,end-2) (return)) + (setf (,target-ref ,target ,target-i) + (,source-ref ,source ,j)) + (incf ,target-i) + (incf ,j)) + (return)) + ((= ,j ,end-2) + (loop (if (= ,i ,end-1) (return)) + (setf (,target-ref ,target ,target-i) + (,source-ref ,source ,i)) + (incf ,target-i) + (incf ,i)) + (return)) + ((apply-keyed-pred (,source-ref ,source ,j) + (,source-ref ,source ,i) + ,pred ,key) + (setf (,target-ref ,target ,target-i) + (,source-ref ,source ,j)) + (incf ,j)) + (t (setf (,target-ref ,target ,target-i) + (,source-ref ,source ,i)) + (incf ,i))) + (incf ,target-i))))) ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists, ;;; but it uses a temporary vector. DIRECTION determines whether we @@ -239,68 +239,68 @@ ;;; (NIL). (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref) (let ((vector-len (gensym)) (n (gensym)) - (direction (gensym)) (unsorted (gensym)) - (start-1 (gensym)) (end-1 (gensym)) - (end-2 (gensym)) (temp-len (gensym)) - (i (gensym))) + (direction (gensym)) (unsorted (gensym)) + (start-1 (gensym)) (end-1 (gensym)) + (end-2 (gensym)) (temp-len (gensym)) + (i (gensym))) `(let ((,vector-len (length (the vector ,vector))) - (,n 1) ; bottom-up size of contiguous runs to be merged - (,direction t) ; t vector --> temp nil temp --> vector - (,temp-len (length (the simple-vector *merge-sort-temp-vector*))) - (,unsorted 0) ; unsorted..vector-len are the elements that need - ; to be merged for a given n - (,start-1 0)) ; one n-len subsequence to be merged with the next + (,n 1) ; bottom-up size of contiguous runs to be merged + (,direction t) ; t vector --> temp nil temp --> vector + (,temp-len (length (the simple-vector *merge-sort-temp-vector*))) + (,unsorted 0) ; unsorted..vector-len are the elements that need + ; to be merged for a given n + (,start-1 0)) ; one n-len subsequence to be merged with the next (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1)) (if (> ,vector-len ,temp-len) - (setf *merge-sort-temp-vector* - (make-array (max ,vector-len (+ ,temp-len ,temp-len))))) + (setf *merge-sort-temp-vector* + (make-array (max ,vector-len (+ ,temp-len ,temp-len))))) (loop - ;; for each n, we start taking n-runs from the start of the vector - (setf ,unsorted 0) - (loop - (setf ,start-1 ,unsorted) - (let ((,end-1 (+ ,start-1 ,n))) - (declare (fixnum ,end-1)) - (cond ((< ,end-1 ,vector-len) - ;; there are enough elements for a second run - (let ((,end-2 (+ ,end-1 ,n))) - (declare (fixnum ,end-2)) - (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len)) - (setf ,unsorted ,end-2) - (if ,direction - (stable-sort-merge-vectors* - ,vector *merge-sort-temp-vector* - ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref) - (stable-sort-merge-vectors* - *merge-sort-temp-vector* ,vector - ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref)) - (if (= ,unsorted ,vector-len) (return)))) - ;; if there is only one run, copy those elements to the end - (t (if ,direction - (do ((,i ,start-1 (1+ ,i))) - ((= ,i ,vector-len)) - (declare (fixnum ,i)) - (setf (svref *merge-sort-temp-vector* ,i) - (,vector-ref ,vector ,i))) - (do ((,i ,start-1 (1+ ,i))) - ((= ,i ,vector-len)) - (declare (fixnum ,i)) - (setf (,vector-ref ,vector ,i) - (svref *merge-sort-temp-vector* ,i)))) - (return))))) - ;; If the inner loop only executed once, then there were only enough - ;; elements for two subsequences given n, so all the elements have - ;; been merged into one list. Start-1 will have remained 0 upon exit. - (when (zerop ,start-1) - (if ,direction - ;; if we just merged into the temporary, copy it all back - ;; to the given vector. - (dotimes (,i ,vector-len) - (setf (,vector-ref ,vector ,i) - (svref *merge-sort-temp-vector* ,i)))) - (return ,vector)) - (setf ,n (ash ,n 1)) ; (* 2 n) - (setf ,direction (not ,direction)))))) + ;; for each n, we start taking n-runs from the start of the vector + (setf ,unsorted 0) + (loop + (setf ,start-1 ,unsorted) + (let ((,end-1 (+ ,start-1 ,n))) + (declare (fixnum ,end-1)) + (cond ((< ,end-1 ,vector-len) + ;; there are enough elements for a second run + (let ((,end-2 (+ ,end-1 ,n))) + (declare (fixnum ,end-2)) + (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len)) + (setf ,unsorted ,end-2) + (if ,direction + (stable-sort-merge-vectors* + ,vector *merge-sort-temp-vector* + ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref) + (stable-sort-merge-vectors* + *merge-sort-temp-vector* ,vector + ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref)) + (if (= ,unsorted ,vector-len) (return)))) + ;; if there is only one run, copy those elements to the end + (t (if ,direction + (do ((,i ,start-1 (1+ ,i))) + ((= ,i ,vector-len)) + (declare (fixnum ,i)) + (setf (svref *merge-sort-temp-vector* ,i) + (,vector-ref ,vector ,i))) + (do ((,i ,start-1 (1+ ,i))) + ((= ,i ,vector-len)) + (declare (fixnum ,i)) + (setf (,vector-ref ,vector ,i) + (svref *merge-sort-temp-vector* ,i)))) + (return))))) + ;; If the inner loop only executed once, then there were only enough + ;; elements for two subsequences given n, so all the elements have + ;; been merged into one list. Start-1 will have remained 0 upon exit. + (when (zerop ,start-1) + (if ,direction + ;; if we just merged into the temporary, copy it all back + ;; to the given vector. + (dotimes (,i ,vector-len) + (setf (,vector-ref ,vector ,i) + (svref *merge-sort-temp-vector* ,i)))) + (return ,vector)) + (setf ,n (ash ,n 1)) ; (* 2 n) + (setf ,direction (not ,direction)))))) ) ; EVAL-when @@ -330,38 +330,38 @@ ;;; are chosen only if they are strictly less than elements of ;;; VECTOR-1, (PRED ELT-2 ELT-1), as specified in the manual. (sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2 - result-vector pred key access) + result-vector pred key access) (let ((result-i (gensym)) - (i (gensym)) - (j (gensym))) + (i (gensym)) + (j (gensym))) `(let* ((,result-i 0) - (,i 0) - (,j 0)) + (,i 0) + (,j 0)) (declare (fixnum ,result-i ,i ,j)) (loop - (cond ((= ,i ,length-1) - (loop (if (= ,j ,length-2) (return)) - (setf (,access ,result-vector ,result-i) - (,access ,vector-2 ,j)) - (incf ,result-i) - (incf ,j)) - (return ,result-vector)) - ((= ,j ,length-2) - (loop (if (= ,i ,length-1) (return)) - (setf (,access ,result-vector ,result-i) - (,access ,vector-1 ,i)) - (incf ,result-i) - (incf ,i)) - (return ,result-vector)) - ((apply-keyed-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i) - ,pred ,key) - (setf (,access ,result-vector ,result-i) - (,access ,vector-2 ,j)) - (incf ,j)) - (t (setf (,access ,result-vector ,result-i) - (,access ,vector-1 ,i)) - (incf ,i))) - (incf ,result-i))))) + (cond ((= ,i ,length-1) + (loop (if (= ,j ,length-2) (return)) + (setf (,access ,result-vector ,result-i) + (,access ,vector-2 ,j)) + (incf ,result-i) + (incf ,j)) + (return ,result-vector)) + ((= ,j ,length-2) + (loop (if (= ,i ,length-1) (return)) + (setf (,access ,result-vector ,result-i) + (,access ,vector-1 ,i)) + (incf ,result-i) + (incf ,i)) + (return ,result-vector)) + ((apply-keyed-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i) + ,pred ,key) + (setf (,access ,result-vector ,result-i) + (,access ,vector-2 ,j)) + (incf ,j)) + (t (setf (,access ,result-vector ,result-i) + (,access ,vector-1 ,i)) + (incf ,i))) + (incf ,result-i))))) ) ; EVAL-WHEN @@ -385,48 +385,48 @@ ;; reimplementing everything, we can't do the same for the LIST ;; case, so do relevant length checking here: (let ((s1 (coerce sequence1 'list)) - (s2 (coerce sequence2 'list)) - (pred-fun (%coerce-callable-to-fun predicate)) - (key-fun (if key - (%coerce-callable-to-fun key) - #'identity))) - (when (type= type (specifier-type 'list)) - (return-from merge (values (merge-lists* s1 s2 pred-fun key-fun)))) - (when (eq type *empty-type*) - (bad-sequence-type-error nil)) - (when (type= type (specifier-type 'null)) - (if (and (null s1) (null s2)) - (return-from merge 'nil) - ;; FIXME: This will break on circular lists (as, - ;; indeed, will the whole MERGE function). - (sequence-type-length-mismatch-error type - (+ (length s1) - (length s2))))) - (if (cons-type-p type) - (multiple-value-bind (min exactp) - (sb!kernel::cons-type-length-info type) - (let ((length (+ (length s1) (length s2)))) - (if exactp - (unless (= length min) - (sequence-type-length-mismatch-error type length)) - (unless (>= length min) - (sequence-type-length-mismatch-error type length))) - (values (merge-lists* s1 s2 pred-fun key-fun)))) - (sequence-type-too-hairy result-type)))) + (s2 (coerce sequence2 'list)) + (pred-fun (%coerce-callable-to-fun predicate)) + (key-fun (if key + (%coerce-callable-to-fun key) + #'identity))) + (when (type= type (specifier-type 'list)) + (return-from merge (values (merge-lists* s1 s2 pred-fun key-fun)))) + (when (eq type *empty-type*) + (bad-sequence-type-error nil)) + (when (type= type (specifier-type 'null)) + (if (and (null s1) (null s2)) + (return-from merge 'nil) + ;; FIXME: This will break on circular lists (as, + ;; indeed, will the whole MERGE function). + (sequence-type-length-mismatch-error type + (+ (length s1) + (length s2))))) + (if (cons-type-p type) + (multiple-value-bind (min exactp) + (sb!kernel::cons-type-length-info type) + (let ((length (+ (length s1) (length s2)))) + (if exactp + (unless (= length min) + (sequence-type-length-mismatch-error type length)) + (unless (>= length min) + (sequence-type-length-mismatch-error type length))) + (values (merge-lists* s1 s2 pred-fun key-fun)))) + (sequence-type-too-hairy result-type)))) ((csubtypep type (specifier-type 'vector)) (let* ((vector-1 (coerce sequence1 'vector)) - (vector-2 (coerce sequence2 'vector)) - (length-1 (length vector-1)) - (length-2 (length vector-2)) - (result (make-sequence result-type - (+ length-1 length-2)))) - (declare (vector vector-1 vector-2) - (fixnum length-1 length-2)) - (if (and (simple-vector-p result) - (simple-vector-p vector-1) - (simple-vector-p vector-2)) - (merge-vectors vector-1 length-1 vector-2 length-2 - result predicate key svref) - (merge-vectors vector-1 length-1 vector-2 length-2 - result predicate key aref)))) + (vector-2 (coerce sequence2 'vector)) + (length-1 (length vector-1)) + (length-2 (length vector-2)) + (result (make-sequence result-type + (+ length-1 length-2)))) + (declare (vector vector-1 vector-2) + (fixnum length-1 length-2)) + (if (and (simple-vector-p result) + (simple-vector-p vector-1) + (simple-vector-p vector-2)) + (merge-vectors vector-1 length-1 vector-2 length-2 + result predicate key svref) + (merge-vectors vector-1 length-1 vector-2 length-2 + result predicate key aref)))) (t (bad-sequence-type-error result-type))))) diff --git a/src/code/sparc-vm.lisp b/src/code/sparc-vm.lisp index 16c1e81..55c655c 100644 --- a/src/code/sparc-vm.lisp +++ b/src/code/sparc-vm.lisp @@ -29,16 +29,16 @@ (error "Unaligned instruction? offset=#x~X." offset)) (sb!sys:without-gcing (let ((sap (truly-the system-area-pointer - (%primitive sb!kernel::code-instructions code)))) + (%primitive sb!kernel::code-instructions code)))) (ecase kind (:call - (error "Can't deal with CALL fixups, yet.")) + (error "Can't deal with CALL fixups, yet.")) (:sethi - (setf (ldb (byte 22 0) (sap-ref-32 sap offset)) - (ldb (byte 22 10) fixup))) + (setf (ldb (byte 22 0) (sap-ref-32 sap offset)) + (ldb (byte 22 10) fixup))) (:add - (setf (ldb (byte 10 0) (sap-ref-32 sap offset)) - (ldb (byte 10 0) fixup))))))) + (setf (ldb (byte 10 0) (sap-ref-32 sap offset)) + (ldb (byte 10 0) fixup))))))) ;;;; "Sigcontext" access functions, cut & pasted from alpha-vm.lisp. @@ -108,7 +108,7 @@ ;;; Given a (POSIX) signal context, extract the internal error ;;; arguments from the instruction stream. This is e.g. -;;; 4 23 254 240 2 0 0 0 +;;; 4 23 254 240 2 0 0 0 ;;; | ~~~~~~~~~~~~~~~~~~~~~~~~~ ;;; length data (everything is an octet) ;;; (pc) @@ -116,66 +116,66 @@ (declare (type (alien (* os-context-t)) context)) (sb!int::/show0 "entering INTERNAL-ERROR-ARGS") (let* ((pc (context-pc context)) - (bad-inst (sap-ref-32 pc 0)) - (op (ldb (byte 2 30) bad-inst)) - (op2 (ldb (byte 3 22) bad-inst)) - (op3 (ldb (byte 6 19) bad-inst))) + (bad-inst (sap-ref-32 pc 0)) + (op (ldb (byte 2 30) bad-inst)) + (op2 (ldb (byte 3 22) bad-inst)) + (op3 (ldb (byte 6 19) bad-inst))) (declare (type system-area-pointer pc)) (cond ((and (= op #b00) (= op2 #b000)) - (args-for-unimp-inst context)) - ((and (= op #b10) (= (ldb (byte 4 2) op3) #b1000)) - (args-for-tagged-add-inst context bad-inst)) - ((and (= op #b10) (= op3 #b111010)) - (args-for-tcc-inst bad-inst)) - (t - (values #.(error-number-or-lose 'unknown-error) nil))))) + (args-for-unimp-inst context)) + ((and (= op #b10) (= (ldb (byte 4 2) op3) #b1000)) + (args-for-tagged-add-inst context bad-inst)) + ((and (= op #b10) (= op3 #b111010)) + (args-for-tcc-inst bad-inst)) + (t + (values #.(error-number-or-lose 'unknown-error) nil))))) (defun args-for-unimp-inst (context) (declare (type (alien (* os-context-t)) context)) (let* ((pc (context-pc context)) - (length (sap-ref-8 pc 4)) - (vector (make-array length :element-type '(unsigned-byte 8)))) + (length (sap-ref-8 pc 4)) + (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (type system-area-pointer pc) - (type (unsigned-byte 8) length) - (type (simple-array (unsigned-byte 8) (*)) vector)) + (type (unsigned-byte 8) length) + (type (simple-array (unsigned-byte 8) (*)) vector)) (copy-ub8-from-system-area pc 5 vector 0 length) (let* ((index 0) - (error-number (sb!c:read-var-integer vector index))) + (error-number (sb!c:read-var-integer vector index))) (collect ((sc-offsets)) - (loop - (when (>= index length) - (return)) - (sc-offsets (sb!c:read-var-integer vector index))) - (values error-number (sc-offsets)))))) + (loop + (when (>= index length) + (return)) + (sc-offsets (sb!c:read-var-integer vector index))) + (values error-number (sc-offsets)))))) (defun args-for-tagged-add-inst (context bad-inst) (declare (type (alien (* os-context-t)) context)) (let* ((rs1 (ldb (byte 5 14) bad-inst)) - (op1 (sb!kernel:make-lisp-obj (context-register context rs1)))) + (op1 (sb!kernel:make-lisp-obj (context-register context rs1)))) (if (fixnump op1) - (if (zerop (ldb (byte 1 13) bad-inst)) - (let* ((rs2 (ldb (byte 5 0) bad-inst)) - (op2 (sb!kernel:make-lisp-obj (context-register context rs2)))) - (if (fixnump op2) - (values #.(error-number-or-lose 'unknown-error) nil) - (values #.(error-number-or-lose 'object-not-fixnum-error) - (list (sb!c::make-sc-offset - descriptor-reg-sc-number - rs2))))) - (values #.(error-number-or-lose 'unknown-error) nil)) - (values #.(error-number-or-lose 'object-not-fixnum-error) - (list (sb!c::make-sc-offset descriptor-reg-sc-number - rs1)))))) + (if (zerop (ldb (byte 1 13) bad-inst)) + (let* ((rs2 (ldb (byte 5 0) bad-inst)) + (op2 (sb!kernel:make-lisp-obj (context-register context rs2)))) + (if (fixnump op2) + (values #.(error-number-or-lose 'unknown-error) nil) + (values #.(error-number-or-lose 'object-not-fixnum-error) + (list (sb!c::make-sc-offset + descriptor-reg-sc-number + rs2))))) + (values #.(error-number-or-lose 'unknown-error) nil)) + (values #.(error-number-or-lose 'object-not-fixnum-error) + (list (sb!c::make-sc-offset descriptor-reg-sc-number + rs1)))))) (defun args-for-tcc-inst (bad-inst) (let* ((trap-number (ldb (byte 8 0) bad-inst)) - (reg (ldb (byte 5 8) bad-inst))) + (reg (ldb (byte 5 8) bad-inst))) (values (case trap-number - (#.object-not-list-trap - #.(error-number-or-lose 'object-not-list-error)) - (#.object-not-instance-trap - #.(error-number-or-lose 'object-not-instance-error)) - (t - #.(error-number-or-lose 'unknown-error))) - (list (sb!c::make-sc-offset descriptor-reg-sc-number reg))))) + (#.object-not-list-trap + #.(error-number-or-lose 'object-not-list-error)) + (#.object-not-instance-trap + #.(error-number-or-lose 'object-not-instance-error)) + (t + #.(error-number-or-lose 'unknown-error))) + (list (sb!c::make-sc-offset descriptor-reg-sc-number reg))))) diff --git a/src/code/specializable-array.lisp b/src/code/specializable-array.lisp index aac63c4..d0d349f 100644 --- a/src/code/specializable-array.lisp +++ b/src/code/specializable-array.lisp @@ -37,21 +37,21 @@ ;;; running under the cross-compilation host ANSI Common Lisp. #+sb-xc-host (defun make-specializable-array (dimensions - &rest rest - &key (element-type t) - &allow-other-keys) + &rest rest + &key (element-type t) + &allow-other-keys) (apply #'make-array - dimensions - (if (eq element-type t) - rest - (do ((reversed-modified-rest nil)) - ((null rest) (nreverse reversed-modified-rest)) - (let ((first (pop rest)) - (second (pop rest))) - (when (eq first :element-type) - (setf second t)) - (push first reversed-modified-rest) - (push second reversed-modified-rest)))))) + dimensions + (if (eq element-type t) + rest + (do ((reversed-modified-rest nil)) + ((null rest) (nreverse reversed-modified-rest)) + (let ((first (pop rest)) + (second (pop rest))) + (when (eq first :element-type) + (setf second t)) + (push first reversed-modified-rest) + (push second reversed-modified-rest)))))) #-sb-xc-host (declaim #!-sb-fluid (inline make-specializable-array)) #-sb-xc-host diff --git a/src/code/step.lisp b/src/code/step.lisp index 4516e79..db86838 100644 --- a/src/code/step.lisp +++ b/src/code/step.lisp @@ -29,13 +29,13 @@ stepper's prompt: (defmethod single-step ((condition step-variable-condition)) (format *debug-io* "; ~A => ~S~%" - (step-condition-form condition) - (step-condition-result condition))) + (step-condition-form condition) + (step-condition-result condition))) (defmethod single-step ((condition step-values-condition)) (let ((values (step-condition-result condition))) (format *debug-io* "; ~A => ~:[#~;~{~S~^, ~}~]~%" - (step-condition-form condition) + (step-condition-form condition) values values))) (defmethod single-step ((condition step-form-condition)) @@ -65,7 +65,7 @@ with the STEP-CONDITION as argument.") (defun invoke-stepper (condition) (when (and *stepping* *stepper-hook*) (let ((hook *stepper-hook*) - (*stepper-hook* nil)) + (*stepper-hook* nil)) (funcall hook condition)))) (defmacro step (form) @@ -75,7 +75,7 @@ outside the lexical scope of the form can be stepped into only if the functions in question have been compiled with sufficient DEBUG policy to be at least partially steppable." `(let ((*stepping* t) - (*step* t)) + (*step* t)) (declare (optimize (sb-c:insert-step-conditions 0))) (format t "Single stepping. Type ? for help.~%") (locally (declare (optimize (sb-c:insert-step-conditions 3))) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index d658516..1f43db7 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -26,31 +26,31 @@ (defun ill-in (stream &rest ignore) (declare (ignore ignore)) (error 'simple-type-error - :datum stream - :expected-type '(satisfies input-stream-p) - :format-control "~S is not a character input stream." - :format-arguments (list stream))) + :datum stream + :expected-type '(satisfies input-stream-p) + :format-control "~S is not a character input stream." + :format-arguments (list stream))) (defun ill-out (stream &rest ignore) (declare (ignore ignore)) (error 'simple-type-error - :datum stream - :expected-type '(satisfies output-stream-p) - :format-control "~S is not a character output stream." - :format-arguments (list stream))) + :datum stream + :expected-type '(satisfies output-stream-p) + :format-control "~S is not a character output stream." + :format-arguments (list stream))) (defun ill-bin (stream &rest ignore) (declare (ignore ignore)) (error 'simple-type-error - :datum stream - :expected-type '(satisfies input-stream-p) - :format-control "~S is not a binary input stream." - :format-arguments (list stream))) + :datum stream + :expected-type '(satisfies input-stream-p) + :format-control "~S is not a binary input stream." + :format-arguments (list stream))) (defun ill-bout (stream &rest ignore) (declare (ignore ignore)) (error 'simple-type-error - :datum stream - :expected-type '(satisfies output-stream-p) - :format-control "~S is not a binary output stream." - :format-arguments (list stream))) + :datum stream + :expected-type '(satisfies output-stream-p) + :format-control "~S is not a binary output stream." + :format-arguments (list stream))) (defun closed-flame (stream &rest ignore) (declare (ignore ignore)) (error "~S is closed." stream)) @@ -65,7 +65,7 @@ (when (synonym-stream-p stream) (setf stream - (symbol-value (synonym-stream-symbol stream)))) + (symbol-value (synonym-stream-symbol stream)))) (and (not (eq (ansi-stream-in stream) #'closed-flame)) ;;; KLUDGE: It's probably not good to have EQ tests on function @@ -73,7 +73,7 @@ ;;; Is there a better way? (Perhaps just VALID-FOR-INPUT and ;;; VALID-FOR-OUTPUT flags? -- WHN 19990902 (or (not (eq (ansi-stream-in stream) #'ill-in)) - (not (eq (ansi-stream-bin stream) #'ill-bin))))) + (not (eq (ansi-stream-bin stream) #'ill-bin))))) (defun input-stream-p (stream) (declare (type stream stream)) @@ -86,11 +86,11 @@ (when (synonym-stream-p stream) (setf stream (symbol-value - (synonym-stream-symbol stream)))) + (synonym-stream-symbol stream)))) (and (not (eq (ansi-stream-in stream) #'closed-flame)) (or (not (eq (ansi-stream-out stream) #'ill-out)) - (not (eq (ansi-stream-bout stream) #'ill-bout))))) + (not (eq (ansi-stream-bout stream) #'ill-bout))))) (defun output-stream-p (stream) (declare (type stream stream)) @@ -180,23 +180,23 @@ "Test for the ANSI concept \"stream associated with a file\"." (or (typep x 'file-stream) (and (synonym-stream-p x) - (stream-associated-with-file-p (symbol-value - (synonym-stream-symbol x)))))) + (stream-associated-with-file-p (symbol-value + (synonym-stream-symbol x)))))) (defun stream-must-be-associated-with-file (stream) (declare (type stream stream)) (unless (stream-associated-with-file-p stream) (error 'simple-type-error - ;; KLUDGE: The ANSI spec for FILE-LENGTH specifically says - ;; this should be TYPE-ERROR. But what then can we use for - ;; EXPECTED-TYPE? This SATISFIES type (with a nonstandard - ;; private predicate function..) is ugly and confusing, but - ;; I can't see any other way. -- WHN 2001-04-14 - :datum stream - :expected-type '(satisfies stream-associated-with-file-p) - :format-control - "~@" - :format-arguments (list stream)))) + ;; KLUDGE: The ANSI spec for FILE-LENGTH specifically says + ;; this should be TYPE-ERROR. But what then can we use for + ;; EXPECTED-TYPE? This SATISFIES type (with a nonstandard + ;; private predicate function..) is ugly and confusing, but + ;; I can't see any other way. -- WHN 2001-04-14 + :datum stream + :expected-type '(satisfies stream-associated-with-file-p) + :format-control + "~@" + :format-arguments (list stream)))) ;;; like FILE-POSITION, only using :FILE-LENGTH (defun file-length (stream) @@ -204,13 +204,13 @@ ;; cause cross-compiler hangup. ;; ;; (declare (type (or file-stream synonym-stream) stream)) - ;; + ;; ;; The description for FILE-LENGTH says that an error must be raised ;; for streams not associated with files (which broadcast streams ;; aren't according to the glossary). However, the behaviour of ;; FILE-LENGTH for broadcast streams is explicitly described in the ;; BROADCAST-STREAM entry. - (unless (typep stream 'broadcast-stream) + (unless (typep stream 'broadcast-stream) (stream-must-be-associated-with-file stream)) (funcall (ansi-stream-misc stream) stream :file-length)) @@ -223,44 +223,44 @@ (defun ansi-stream-read-line (stream eof-error-p eof-value recursive-p) (declare (ignore recursive-p)) (prepare-for-fast-read-char stream - (let ((res (make-string 80)) - (len 80) - (index 0)) - (loop - (let ((ch (fast-read-char nil nil))) - (cond (ch - (when (char= ch #\newline) - (done-with-fast-read-char) - (return (values (shrink-vector res index) nil))) - (when (= index len) - (setq len (* len 2)) - (let ((new (make-string len))) - (replace new res) - (setq res new))) - (setf (schar res index) ch) - (incf index)) - ((zerop index) - (done-with-fast-read-char) - (return (values (eof-or-lose stream - eof-error-p - eof-value) - t))) - ;; Since FAST-READ-CHAR already hit the eof char, we - ;; shouldn't do another READ-CHAR. - (t - (done-with-fast-read-char) - (return (values (shrink-vector res index) t))))))))) + (let ((res (make-string 80)) + (len 80) + (index 0)) + (loop + (let ((ch (fast-read-char nil nil))) + (cond (ch + (when (char= ch #\newline) + (done-with-fast-read-char) + (return (values (shrink-vector res index) nil))) + (when (= index len) + (setq len (* len 2)) + (let ((new (make-string len))) + (replace new res) + (setq res new))) + (setf (schar res index) ch) + (incf index)) + ((zerop index) + (done-with-fast-read-char) + (return (values (eof-or-lose stream + eof-error-p + eof-value) + t))) + ;; Since FAST-READ-CHAR already hit the eof char, we + ;; shouldn't do another READ-CHAR. + (t + (done-with-fast-read-char) + (return (values (shrink-vector res index) t))))))))) (defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value - recursive-p) + recursive-p) (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) - (ansi-stream-read-line stream eof-error-p eof-value recursive-p) - ;; must be Gray streams FUNDAMENTAL-STREAM - (multiple-value-bind (string eof) (stream-read-line stream) - (if (and eof (zerop (length string))) - (values (eof-or-lose stream eof-error-p eof-value) t) - (values string eof)))))) + (ansi-stream-read-line stream eof-error-p eof-value recursive-p) + ;; must be Gray streams FUNDAMENTAL-STREAM + (multiple-value-bind (string eof) (stream-read-line stream) + (if (and eof (zerop (length string))) + (values (eof-or-lose stream eof-error-p eof-value) t) + (values string eof)))))) ;;; We proclaim them INLINE here, then proclaim them NOTINLINE later on, ;;; so, except in this file, they are not inline by default, but they can be. @@ -275,17 +275,17 @@ (done-with-fast-read-char)))) (defun read-char (&optional (stream *standard-input*) - (eof-error-p t) - eof-value - recursive-p) + (eof-error-p t) + eof-value + recursive-p) (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) - (ansi-stream-read-char stream eof-error-p eof-value recursive-p) - ;; must be Gray streams FUNDAMENTAL-STREAM - (let ((char (stream-read-char stream))) - (if (eq char :eof) - (eof-or-lose stream eof-error-p eof-value) - char))))) + (ansi-stream-read-char stream eof-error-p eof-value recursive-p) + ;; must be Gray streams FUNDAMENTAL-STREAM + (let ((char (stream-read-char stream))) + (if (eq char :eof) + (eof-or-lose stream eof-error-p eof-value) + char))))) #!-sb-fluid (declaim (inline ansi-stream-unread-char)) (defun ansi-stream-unread-char (character stream) @@ -303,9 +303,9 @@ (defun unread-char (character &optional (stream *standard-input*)) (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) - (ansi-stream-unread-char character stream) - ;; must be Gray streams FUNDAMENTAL-STREAM - (stream-unread-char stream character))) + (ansi-stream-unread-char character stream) + ;; must be Gray streams FUNDAMENTAL-STREAM + (stream-unread-char stream character))) nil) #!-sb-fluid (declaim (inline ansi-stream-listen)) @@ -314,16 +314,16 @@ +ansi-stream-in-buffer-length+) ;; Handle :EOF return from misc methods specially (let ((result (funcall (ansi-stream-misc stream) stream :listen))) - (if (eq result :eof) - nil - result)))) + (if (eq result :eof) + nil + result)))) (defun listen (&optional (stream *standard-input*)) (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) - (ansi-stream-listen stream) - ;; Fall through to Gray streams FUNDAMENTAL-STREAM case. - (stream-listen stream)))) + (ansi-stream-listen stream) + ;; Fall through to Gray streams FUNDAMENTAL-STREAM case. + (stream-listen stream)))) #!-sb-fluid (declaim (inline ansi-stream-read-char-no-hang)) (defun ansi-stream-read-char-no-hang (stream eof-error-p eof-value recursive-p) @@ -333,18 +333,18 @@ nil)) (defun read-char-no-hang (&optional (stream *standard-input*) - (eof-error-p t) - eof-value - recursive-p) + (eof-error-p t) + eof-value + recursive-p) (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) - (ansi-stream-read-char-no-hang stream eof-error-p eof-value + (ansi-stream-read-char-no-hang stream eof-error-p eof-value recursive-p) - ;; must be Gray streams FUNDAMENTAL-STREAM - (let ((char (stream-read-char-no-hang stream))) - (if (eq char :eof) - (eof-or-lose stream eof-error-p eof-value) - char))))) + ;; must be Gray streams FUNDAMENTAL-STREAM + (let ((char (stream-read-char-no-hang stream))) + (if (eq char :eof) + (eof-or-lose stream eof-error-p eof-value) + char))))) #!-sb-fluid (declaim (inline ansi-stream-clear-input)) (defun ansi-stream-clear-input (stream) @@ -373,12 +373,12 @@ (defun read-byte (stream &optional (eof-error-p t) eof-value) (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) - (ansi-stream-read-byte stream eof-error-p eof-value nil) - ;; must be Gray streams FUNDAMENTAL-STREAM - (let ((char (stream-read-byte stream))) - (if (eq char :eof) - (eof-or-lose stream eof-error-p eof-value) - char))))) + (ansi-stream-read-byte stream eof-error-p eof-value nil) + ;; must be Gray streams FUNDAMENTAL-STREAM + (let ((char (stream-read-byte stream))) + (if (eq char :eof) + (eof-or-lose stream eof-error-p eof-value) + char))))) ;;; Read NUMBYTES bytes into BUFFER beginning at START, and return the ;;; number of bytes read. @@ -392,21 +392,21 @@ ;;; method (perhaps N-BIN-ASAP?) or something. (defun read-n-bytes (stream buffer start numbytes &optional (eof-error-p t)) (declare (type ansi-stream stream) - (type index numbytes start) - (type (or (simple-array * (*)) system-area-pointer) buffer)) + (type index numbytes start) + (type (or (simple-array * (*)) system-area-pointer) buffer)) (let* ((stream (in-synonym-of stream ansi-stream)) - (in-buffer (ansi-stream-in-buffer stream)) - (index (ansi-stream-in-index stream)) - (num-buffered (- +ansi-stream-in-buffer-length+ index))) + (in-buffer (ansi-stream-in-buffer stream)) + (index (ansi-stream-in-index stream)) + (num-buffered (- +ansi-stream-in-buffer-length+ index))) (declare (fixnum index num-buffered)) (cond ((not in-buffer) (funcall (ansi-stream-n-bin stream) - stream - buffer - start - numbytes - eof-error-p)) + stream + buffer + start + numbytes + eof-error-p)) ((<= numbytes num-buffered) #+nil (let ((copy-function (typecase buffer @@ -414,25 +414,25 @@ (system-area-pointer #'copy-ub8-to-system-area)))) (funcall copy-function in-buffer index buffer start numbytes)) (%byte-blt in-buffer index - buffer start (+ start numbytes)) + buffer start (+ start numbytes)) (setf (ansi-stream-in-index stream) (+ index numbytes)) numbytes) (t (let ((end (+ start num-buffered))) - #+nil + #+nil (let ((copy-function (typecase buffer ((simple-array * (*)) #'ub8-bash-copy) (system-area-pointer #'copy-ub8-to-system-area)))) (funcall copy-function in-buffer index buffer start num-buffered)) (%byte-blt in-buffer index buffer start end) - (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) - (+ (funcall (ansi-stream-n-bin stream) - stream - buffer - end - (- numbytes num-buffered) - eof-error-p) - num-buffered)))))) + (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) + (+ (funcall (ansi-stream-n-bin stream) + stream + buffer + end + (- numbytes num-buffered) + eof-error-p) + num-buffered)))))) ;;; the amount of space we leave at the start of the in-buffer for ;;; unreading @@ -479,27 +479,27 @@ ;;; leave room for unreading. (defun fast-read-byte-refill (stream eof-error-p eof-value) (let* ((ibuf (ansi-stream-in-buffer stream)) - (count (funcall (ansi-stream-n-bin stream) stream - ibuf 0 +ansi-stream-in-buffer-length+ - nil)) - (start (- +ansi-stream-in-buffer-length+ count))) + (count (funcall (ansi-stream-n-bin stream) stream + ibuf 0 +ansi-stream-in-buffer-length+ + nil)) + (start (- +ansi-stream-in-buffer-length+ count))) (declare (type index start count)) (cond ((zerop count) - (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) - (funcall (ansi-stream-bin stream) stream eof-error-p eof-value)) - (t - (unless (zerop start) + (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) + (funcall (ansi-stream-bin stream) stream eof-error-p eof-value)) + (t + (unless (zerop start) (ub8-bash-copy ibuf 0 - ibuf start + ibuf start count)) - (setf (ansi-stream-in-index stream) (1+ start)) - (aref ibuf start))))) + (setf (ansi-stream-in-index stream) (1+ start)) + (aref ibuf start))))) ;;; output functions (defun write-char (character &optional (stream *standard-output*)) (with-out-stream stream (ansi-stream-out character) - (stream-write-char character)) + (stream-write-char character)) character) (defun terpri (&optional (stream *standard-output*)) @@ -515,12 +515,12 @@ (defun fresh-line (&optional (stream *standard-output*)) (let ((stream (out-synonym-of stream))) (if (ansi-stream-p stream) - (ansi-stream-fresh-line stream) - ;; must be Gray streams FUNDAMENTAL-STREAM - (stream-fresh-line stream)))) + (ansi-stream-fresh-line stream) + ;; must be Gray streams FUNDAMENTAL-STREAM + (stream-fresh-line stream)))) (defun write-string (string &optional (stream *standard-output*) - &key (start 0) end) + &key (start 0) end) (declare (type string string)) ;; Note that even though you might expect, based on the behavior of ;; things like AREF, that the correct upper bound here is @@ -530,7 +530,7 @@ ;; (LENGTH STRING) is the required upper bound. A foolish ;; consistency is the hobgoblin of lesser languages.. (%write-string string stream start (%check-vector-sequence-bounds - string start end)) + string start end)) string) #!-sb-fluid (declaim (inline ansi-stream-write-string)) @@ -563,13 +563,13 @@ (write-string string stream :start start :end end)) (defun write-line (string &optional (stream *standard-output*) - &key (start 0) end) + &key (start 0) end) (declare (type string string)) ;; FIXME: Why is there this difference between the treatments of the ;; STREAM argument in WRITE-STRING and WRITE-LINE? (let ((defaulted-stream (out-synonym-of stream))) (%write-string string defaulted-stream start (%check-vector-sequence-bounds - string start end)) + string start end)) (write-char #\newline defaulted-stream)) string) @@ -578,26 +578,26 @@ (defun line-length (&optional (stream *standard-output*)) (with-out-stream stream (ansi-stream-misc :line-length) - (stream-line-length))) + (stream-line-length))) (defun finish-output (&optional (stream *standard-output*)) (with-out-stream stream (ansi-stream-misc :finish-output) - (stream-finish-output)) + (stream-finish-output)) nil) (defun force-output (&optional (stream *standard-output*)) (with-out-stream stream (ansi-stream-misc :force-output) - (stream-force-output)) + (stream-force-output)) nil) (defun clear-output (&optional (stream *standard-output*)) (with-out-stream stream (ansi-stream-misc :clear-output) - (stream-force-output)) + (stream-force-output)) nil) (defun write-byte (integer stream) (with-out-stream stream (ansi-stream-bout integer) - (stream-write-byte integer)) + (stream-write-byte integer)) integer) @@ -617,7 +617,7 @@ ;; Return T if input available, :EOF for end-of-file, otherwise NIL. (let ((char (read-char-no-hang stream nil :eof))) (when (characterp char) - (unread-char char stream)) + (unread-char char stream)) char)) (:unread (unread-char arg1 stream)) @@ -649,13 +649,13 @@ ;;;; broadcast streams (defstruct (broadcast-stream (:include ansi-stream - (out #'broadcast-out) - (bout #'broadcast-bout) - (sout #'broadcast-sout) - (misc #'broadcast-misc)) - (:constructor %make-broadcast-stream - (&rest streams)) - (:copier nil)) + (out #'broadcast-out) + (bout #'broadcast-bout) + (sout #'broadcast-sout) + (misc #'broadcast-misc)) + (:constructor %make-broadcast-stream + (&rest streams)) + (:copier nil)) ;; a list of all the streams we broadcast to (streams () :type list :read-only t)) @@ -663,14 +663,14 @@ (dolist (stream streams) (unless (output-stream-p stream) (error 'type-error - :datum stream - :expected-type '(satisfies output-stream-p)))) + :datum stream + :expected-type '(satisfies output-stream-p)))) (apply #'%make-broadcast-stream streams)) (macrolet ((out-fun (name fun &rest args) - `(defun ,name (stream ,@args) - (dolist (stream (broadcast-stream-streams stream)) - (,fun ,(car args) stream ,@(cdr args)))))) + `(defun ,name (stream ,@args) + (dolist (stream (broadcast-stream-streams stream)) + (,fun ,(car args) stream ,@(cdr args)))))) (out-fun broadcast-out write-char char) (out-fun broadcast-bout write-byte byte) (out-fun broadcast-sout write-string-no-key string start end)) @@ -692,68 +692,68 @@ ;; -- CSR, 2004-02-04 (:charpos (dolist (stream streams 0) - (let ((charpos (charpos stream))) - (if charpos (return charpos))))) + (let ((charpos (charpos stream))) + (if charpos (return charpos))))) (:line-length (let ((min nil)) - (dolist (stream streams min) - (let ((res (line-length stream))) - (when res (setq min (if min (min res min) res))))))) + (dolist (stream streams min) + (let ((res (line-length stream))) + (when res (setq min (if min (min res min) res))))))) (:element-type #+nil ; old, arguably more logical, version (let (res) - (dolist (stream streams (if (> (length res) 1) `(and ,@res) t)) - (pushnew (stream-element-type stream) res :test #'equal))) + (dolist (stream streams (if (> (length res) 1) `(and ,@res) t)) + (pushnew (stream-element-type stream) res :test #'equal))) ;; ANSI-specified version (under System Class BROADCAST-STREAM) (let ((res t)) - (do ((streams streams (cdr streams))) - ((null streams) res) - (when (null (cdr streams)) - (setq res (stream-element-type (car streams))))))) + (do ((streams streams (cdr streams))) + ((null streams) res) + (when (null (cdr streams)) + (setq res (stream-element-type (car streams))))))) (:external-format (let ((res :default)) - (dolist (stream streams res) - (setq res (stream-external-format stream))))) + (dolist (stream streams res) + (setq res (stream-external-format stream))))) (:file-length (let ((last (last streams))) - (if last - (file-length (car last)) - 0))) + (if last + (file-length (car last)) + 0))) (:file-position (if arg1 - (let ((res (or (eql arg1 :start) (eql arg1 0)))) - (dolist (stream streams res) - (setq res (file-position stream arg1)))) - (let ((res 0)) - (dolist (stream streams res) - (setq res (file-position stream)))))) + (let ((res (or (eql arg1 :start) (eql arg1 0)))) + (dolist (stream streams res) + (setq res (file-position stream arg1)))) + (let ((res 0)) + (dolist (stream streams res) + (setq res (file-position stream)))))) (:file-string-length (let ((res 1)) - (dolist (stream streams res) - (setq res (file-string-length stream arg1))))) + (dolist (stream streams res) + (setq res (file-string-length stream arg1))))) (:close (set-closed-flame stream)) (t (let ((res nil)) - (dolist (stream streams res) - (setq res - (if (ansi-stream-p stream) - (funcall (ansi-stream-misc stream) stream operation - arg1 arg2) - (stream-misc-dispatch stream operation arg1 arg2))))))))) + (dolist (stream streams res) + (setq res + (if (ansi-stream-p stream) + (funcall (ansi-stream-misc stream) stream operation + arg1 arg2) + (stream-misc-dispatch stream operation arg1 arg2))))))))) ;;;; synonym streams (defstruct (synonym-stream (:include ansi-stream - (in #'synonym-in) - (bin #'synonym-bin) - (n-bin #'synonym-n-bin) - (out #'synonym-out) - (bout #'synonym-bout) - (sout #'synonym-sout) - (misc #'synonym-misc)) - (:constructor make-synonym-stream (symbol)) - (:copier nil)) + (in #'synonym-in) + (bin #'synonym-bin) + (n-bin #'synonym-n-bin) + (out #'synonym-out) + (bout #'synonym-bout) + (sout #'synonym-sout) + (misc #'synonym-misc)) + (:constructor make-synonym-stream (symbol)) + (:copier nil)) ;; This is the symbol, the value of which is the stream we are synonym to. (symbol nil :type symbol :read-only t)) (def!method print-object ((x synonym-stream) stream) @@ -763,10 +763,10 @@ ;;; The output simple output methods just call the corresponding ;;; function on the synonymed stream. (macrolet ((out-fun (name fun &rest args) - `(defun ,name (stream ,@args) - (declare (optimize (safety 1))) - (let ((syn (symbol-value (synonym-stream-symbol stream)))) - (,fun ,(car args) syn ,@(cdr args)))))) + `(defun ,name (stream ,@args) + (declare (optimize (safety 1))) + (let ((syn (symbol-value (synonym-stream-symbol stream)))) + (,fun ,(car args) syn ,@(cdr args)))))) (out-fun synonym-out write-char ch) (out-fun synonym-bout write-byte n) (out-fun synonym-sout write-string-no-key string start end)) @@ -775,10 +775,10 @@ ;;; synonymed stream. These functions deal with getting input out of ;;; the In-Buffer if there is any. (macrolet ((in-fun (name fun &rest args) - `(defun ,name (stream ,@args) - (declare (optimize (safety 1))) - (,fun (symbol-value (synonym-stream-symbol stream)) - ,@args)))) + `(defun ,name (stream ,@args) + (declare (optimize (safety 1))) + (,fun (symbol-value (synonym-stream-symbol stream)) + ,@args)))) (in-fun synonym-in read-char eof-error-p eof-value) (in-fun synonym-bin read-byte eof-error-p eof-value) (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-error-p)) @@ -787,32 +787,32 @@ (declare (optimize (safety 1))) (let ((syn (symbol-value (synonym-stream-symbol stream)))) (if (ansi-stream-p syn) - ;; We have to special-case some operations which interact with - ;; the in-buffer of the wrapped stream, since just calling - ;; ANSI-STREAM-MISC on them - (case operation - (:listen (or (/= (the fixnum (ansi-stream-in-index syn)) - +ansi-stream-in-buffer-length+) - (funcall (ansi-stream-misc syn) syn :listen))) + ;; We have to special-case some operations which interact with + ;; the in-buffer of the wrapped stream, since just calling + ;; ANSI-STREAM-MISC on them + (case operation + (:listen (or (/= (the fixnum (ansi-stream-in-index syn)) + +ansi-stream-in-buffer-length+) + (funcall (ansi-stream-misc syn) syn :listen))) (:clear-input (clear-input syn)) (:unread (unread-char arg1 syn)) - (t - (funcall (ansi-stream-misc syn) syn operation arg1 arg2))) - (stream-misc-dispatch syn operation arg1 arg2)))) + (t + (funcall (ansi-stream-misc syn) syn operation arg1 arg2))) + (stream-misc-dispatch syn operation arg1 arg2)))) ;;;; two-way streams (defstruct (two-way-stream - (:include ansi-stream - (in #'two-way-in) - (bin #'two-way-bin) - (n-bin #'two-way-n-bin) - (out #'two-way-out) - (bout #'two-way-bout) - (sout #'two-way-sout) - (misc #'two-way-misc)) - (:constructor %make-two-way-stream (input-stream output-stream)) - (:copier nil)) + (:include ansi-stream + (in #'two-way-in) + (bin #'two-way-bin) + (n-bin #'two-way-n-bin) + (out #'two-way-out) + (bout #'two-way-bout) + (sout #'two-way-sout) + (misc #'two-way-misc)) + (:constructor %make-two-way-stream (input-stream output-stream)) + (:copier nil)) (input-stream (missing-arg) :type stream :read-only t) (output-stream (missing-arg) :type stream :read-only t)) (defprinter (two-way-stream) input-stream output-stream) @@ -826,80 +826,80 @@ ;; the other places that SYNONYM-STREAM-P appears. (unless (output-stream-p output-stream) (error 'type-error - :datum output-stream - :expected-type '(satisfies output-stream-p))) + :datum output-stream + :expected-type '(satisfies output-stream-p))) (unless (input-stream-p input-stream) (error 'type-error - :datum input-stream - :expected-type '(satisfies input-stream-p))) + :datum input-stream + :expected-type '(satisfies input-stream-p))) (funcall #'%make-two-way-stream input-stream output-stream)) (macrolet ((out-fun (name fun &rest args) - `(defun ,name (stream ,@args) - (let ((syn (two-way-stream-output-stream stream))) - (,fun ,(car args) syn ,@(cdr args)))))) + `(defun ,name (stream ,@args) + (let ((syn (two-way-stream-output-stream stream))) + (,fun ,(car args) syn ,@(cdr args)))))) (out-fun two-way-out write-char ch) (out-fun two-way-bout write-byte n) (out-fun two-way-sout write-string-no-key string start end)) (macrolet ((in-fun (name fun &rest args) - `(defun ,name (stream ,@args) - (force-output (two-way-stream-output-stream stream)) - (,fun (two-way-stream-input-stream stream) ,@args)))) + `(defun ,name (stream ,@args) + (force-output (two-way-stream-output-stream stream)) + (,fun (two-way-stream-input-stream stream) ,@args)))) (in-fun two-way-in read-char eof-error-p eof-value) (in-fun two-way-bin read-byte eof-error-p eof-value) (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-error-p)) (defun two-way-misc (stream operation &optional arg1 arg2) (let* ((in (two-way-stream-input-stream stream)) - (out (two-way-stream-output-stream stream)) - (in-ansi-stream-p (ansi-stream-p in)) - (out-ansi-stream-p (ansi-stream-p out))) + (out (two-way-stream-output-stream stream)) + (in-ansi-stream-p (ansi-stream-p in)) + (out-ansi-stream-p (ansi-stream-p out))) (case operation (:listen (if in-ansi-stream-p - (or (/= (the fixnum (ansi-stream-in-index in)) - +ansi-stream-in-buffer-length+) - (funcall (ansi-stream-misc in) in :listen)) - (listen in))) + (or (/= (the fixnum (ansi-stream-in-index in)) + +ansi-stream-in-buffer-length+) + (funcall (ansi-stream-misc in) in :listen)) + (listen in))) ((:finish-output :force-output :clear-output) (if out-ansi-stream-p - (funcall (ansi-stream-misc out) out operation arg1 arg2) - (stream-misc-dispatch out operation arg1 arg2))) + (funcall (ansi-stream-misc out) out operation arg1 arg2) + (stream-misc-dispatch out operation arg1 arg2))) (:clear-input (clear-input in)) (:unread (unread-char arg1 in)) (:element-type (let ((in-type (stream-element-type in)) - (out-type (stream-element-type out))) - (if (equal in-type out-type) - in-type `(and ,in-type ,out-type)))) + (out-type (stream-element-type out))) + (if (equal in-type out-type) + in-type `(and ,in-type ,out-type)))) (:close (set-closed-flame stream)) (t (or (if in-ansi-stream-p - (funcall (ansi-stream-misc in) in operation arg1 arg2) - (stream-misc-dispatch in operation arg1 arg2)) - (if out-ansi-stream-p - (funcall (ansi-stream-misc out) out operation arg1 arg2) - (stream-misc-dispatch out operation arg1 arg2))))))) + (funcall (ansi-stream-misc in) in operation arg1 arg2) + (stream-misc-dispatch in operation arg1 arg2)) + (if out-ansi-stream-p + (funcall (ansi-stream-misc out) out operation arg1 arg2) + (stream-misc-dispatch out operation arg1 arg2))))))) ;;;; concatenated streams (defstruct (concatenated-stream - (:include ansi-stream - (in #'concatenated-in) - (bin #'concatenated-bin) - (n-bin #'concatenated-n-bin) - (misc #'concatenated-misc)) - (:constructor %make-concatenated-stream (&rest streams)) - (:copier nil)) + (:include ansi-stream + (in #'concatenated-in) + (bin #'concatenated-bin) + (n-bin #'concatenated-n-bin) + (misc #'concatenated-misc)) + (:constructor %make-concatenated-stream (&rest streams)) + (:copier nil)) ;; The car of this is the substream we are reading from now. (streams nil :type list)) (def!method print-object ((x concatenated-stream) stream) (print-unreadable-object (x stream :type t :identity t) (format stream - ":STREAMS ~S" - (concatenated-stream-streams x)))) + ":STREAMS ~S" + (concatenated-stream-streams x)))) (defun make-concatenated-stream (&rest streams) #!+sb-doc @@ -908,20 +908,20 @@ (dolist (stream streams) (unless (input-stream-p stream) (error 'type-error - :datum stream - :expected-type '(satisfies input-stream-p)))) + :datum stream + :expected-type '(satisfies input-stream-p)))) (apply #'%make-concatenated-stream streams)) (macrolet ((in-fun (name fun) - `(defun ,name (stream eof-error-p eof-value) - (do ((streams (concatenated-stream-streams stream) - (cdr streams))) - ((null streams) - (eof-or-lose stream eof-error-p eof-value)) - (let* ((stream (car streams)) - (result (,fun stream nil nil))) - (when result (return result))) - (pop (concatenated-stream-streams stream)))))) + `(defun ,name (stream eof-error-p eof-value) + (do ((streams (concatenated-stream-streams stream) + (cdr streams))) + ((null streams) + (eof-or-lose stream eof-error-p eof-value)) + (let* ((stream (car streams)) + (result (,fun stream nil nil))) + (when result (return result))) + (pop (concatenated-stream-streams stream)))))) (in-fun concatenated-in read-char) (in-fun concatenated-bin read-byte)) @@ -931,11 +931,11 @@ (remaining-bytes numbytes)) ((null streams) (if eof-errorp - (error 'end-of-file :stream stream) - (- numbytes remaining-bytes))) + (error 'end-of-file :stream stream) + (- numbytes remaining-bytes))) (let* ((stream (car streams)) (bytes-read (read-n-bytes stream buffer current-start - remaining-bytes nil))) + remaining-bytes nil))) (incf current-start bytes-read) (decf remaining-bytes bytes-read) (when (zerop remaining-bytes) (return numbytes))) @@ -943,57 +943,57 @@ (defun concatenated-misc (stream operation &optional arg1 arg2) (let* ((left (concatenated-stream-streams stream)) - (current (car left))) + (current (car left))) (case operation (:listen (unless left - (return-from concatenated-misc :eof)) + (return-from concatenated-misc :eof)) (loop - (let ((stuff (if (ansi-stream-p current) - (funcall (ansi-stream-misc current) current - :listen) - (stream-misc-dispatch current :listen)))) - (cond ((eq stuff :eof) - ;; Advance STREAMS, and try again. - (pop (concatenated-stream-streams stream)) - (setf current - (car (concatenated-stream-streams stream))) - (unless current - ;; No further streams. EOF. - (return :eof))) - (stuff - ;; Stuff's available. - (return t)) - (t - ;; Nothing is available yet. - (return nil)))))) + (let ((stuff (if (ansi-stream-p current) + (funcall (ansi-stream-misc current) current + :listen) + (stream-misc-dispatch current :listen)))) + (cond ((eq stuff :eof) + ;; Advance STREAMS, and try again. + (pop (concatenated-stream-streams stream)) + (setf current + (car (concatenated-stream-streams stream))) + (unless current + ;; No further streams. EOF. + (return :eof))) + (stuff + ;; Stuff's available. + (return t)) + (t + ;; Nothing is available yet. + (return nil)))))) (:clear-input (when left (clear-input current))) (:unread (when left (unread-char arg1 current))) (:close (set-closed-flame stream)) (t (when left - (if (ansi-stream-p current) - (funcall (ansi-stream-misc current) current operation arg1 arg2) - (stream-misc-dispatch current operation arg1 arg2))))))) + (if (ansi-stream-p current) + (funcall (ansi-stream-misc current) current operation arg1 arg2) + (stream-misc-dispatch current operation arg1 arg2))))))) ;;;; echo streams (defstruct (echo-stream - (:include two-way-stream - (in #'echo-in) - (bin #'echo-bin) - (misc #'echo-misc) - (n-bin #'echo-n-bin)) - (:constructor %make-echo-stream (input-stream output-stream)) - (:copier nil)) + (:include two-way-stream + (in #'echo-in) + (bin #'echo-bin) + (misc #'echo-misc) + (n-bin #'echo-n-bin)) + (:constructor %make-echo-stream (input-stream output-stream)) + (:copier nil)) unread-stuff) (def!method print-object ((x echo-stream) stream) (print-unreadable-object (x stream :type t :identity t) (format stream - ":INPUT-STREAM ~S :OUTPUT-STREAM ~S" - (two-way-stream-input-stream x) - (two-way-stream-output-stream x)))) + ":INPUT-STREAM ~S :OUTPUT-STREAM ~S" + (two-way-stream-input-stream x) + (two-way-stream-output-stream x)))) (defun make-echo-stream (input-stream output-stream) #!+sb-doc @@ -1002,69 +1002,69 @@ the output stream." (unless (output-stream-p output-stream) (error 'type-error - :datum output-stream - :expected-type '(satisfies output-stream-p))) + :datum output-stream + :expected-type '(satisfies output-stream-p))) (unless (input-stream-p input-stream) (error 'type-error - :datum input-stream - :expected-type '(satisfies input-stream-p))) + :datum input-stream + :expected-type '(satisfies input-stream-p))) (funcall #'%make-echo-stream input-stream output-stream)) (macrolet ((in-fun (name in-fun out-fun &rest args) - `(defun ,name (stream ,@args) - (or (pop (echo-stream-unread-stuff stream)) - (let* ((in (echo-stream-input-stream stream)) - (out (echo-stream-output-stream stream)) - (result (if eof-error-p - (,in-fun in ,@args) - (,in-fun in nil in)))) - (cond - ((eql result in) eof-value) - (t (,out-fun result out) result))))))) + `(defun ,name (stream ,@args) + (or (pop (echo-stream-unread-stuff stream)) + (let* ((in (echo-stream-input-stream stream)) + (out (echo-stream-output-stream stream)) + (result (if eof-error-p + (,in-fun in ,@args) + (,in-fun in nil in)))) + (cond + ((eql result in) eof-value) + (t (,out-fun result out) result))))))) (in-fun echo-in read-char write-char eof-error-p eof-value) (in-fun echo-bin read-byte write-byte eof-error-p eof-value)) (defun echo-n-bin (stream buffer start numbytes eof-error-p) (let ((new-start start) - (read 0)) + (read 0)) (loop (let ((thing (pop (echo-stream-unread-stuff stream)))) (cond - (thing - (setf (aref buffer new-start) thing) - (incf new-start) - (incf read) - (when (= read numbytes) - (return-from echo-n-bin numbytes))) - (t (return nil))))) + (thing + (setf (aref buffer new-start) thing) + (incf new-start) + (incf read) + (when (= read numbytes) + (return-from echo-n-bin numbytes))) + (t (return nil))))) (let ((bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer - new-start (- numbytes read) nil))) + new-start (- numbytes read) nil))) (cond - ((not eof-error-p) - (write-sequence buffer (echo-stream-output-stream stream) - :start new-start :end (+ new-start bytes-read)) - (+ bytes-read read)) - ((> numbytes (+ read bytes-read)) - (write-sequence buffer (echo-stream-output-stream stream) - :start new-start :end (+ new-start bytes-read)) - (error 'end-of-file :stream stream)) - (t - (write-sequence buffer (echo-stream-output-stream stream) - :start new-start :end (+ new-start bytes-read)) - (aver (= numbytes (+ new-start bytes-read))) - numbytes))))) + ((not eof-error-p) + (write-sequence buffer (echo-stream-output-stream stream) + :start new-start :end (+ new-start bytes-read)) + (+ bytes-read read)) + ((> numbytes (+ read bytes-read)) + (write-sequence buffer (echo-stream-output-stream stream) + :start new-start :end (+ new-start bytes-read)) + (error 'end-of-file :stream stream)) + (t + (write-sequence buffer (echo-stream-output-stream stream) + :start new-start :end (+ new-start bytes-read)) + (aver (= numbytes (+ new-start bytes-read))) + numbytes))))) ;;;; STRING-INPUT-STREAM stuff (defstruct (string-input-stream - (:include ansi-stream - (in #'string-inch) - (bin #'ill-bin) - (n-bin #'ill-bin) - (misc #'string-in-misc)) - (:constructor internal-make-string-input-stream - (string current end)) - (:copier nil)) + (:include ansi-stream + (in #'string-inch) + (bin #'ill-bin) + (n-bin #'ill-bin) + (misc #'string-in-misc)) + (:constructor internal-make-string-input-stream + (string current end)) + (:copier nil)) (string (missing-arg) :type simple-string) (current (missing-arg) :type index) (end (missing-arg) :type index)) @@ -1072,34 +1072,34 @@ (defun string-inch (stream eof-error-p eof-value) (declare (type string-input-stream stream)) (let ((string (string-input-stream-string stream)) - (index (string-input-stream-current stream))) + (index (string-input-stream-current stream))) (cond ((>= index (the index (string-input-stream-end stream))) - (eof-or-lose stream eof-error-p eof-value)) - (t - (setf (string-input-stream-current stream) (1+ index)) - (char string index))))) + (eof-or-lose stream eof-error-p eof-value)) + (t + (setf (string-input-stream-current stream) (1+ index)) + (char string index))))) (defun string-binch (stream eof-error-p eof-value) (declare (type string-input-stream stream)) (let ((string (string-input-stream-string stream)) - (index (string-input-stream-current stream))) + (index (string-input-stream-current stream))) (cond ((>= index (the index (string-input-stream-end stream))) - (eof-or-lose stream eof-error-p eof-value)) - (t - (setf (string-input-stream-current stream) (1+ index)) - (char-code (char string index)))))) + (eof-or-lose stream eof-error-p eof-value)) + (t + (setf (string-input-stream-current stream) (1+ index)) + (char-code (char string index)))))) (defun string-stream-read-n-bytes (stream buffer start requested eof-error-p) (declare (type string-input-stream stream) - (type index start requested)) + (type index start requested)) (let* ((string (string-input-stream-string stream)) - (index (string-input-stream-current stream)) - (available (- (string-input-stream-end stream) index)) - (copy (min available requested))) + (index (string-input-stream-current stream)) + (available (- (string-input-stream-end stream) index)) + (copy (min available requested))) (declare (type simple-string string)) (when (plusp copy) (setf (string-input-stream-current stream) - (truly-the index (+ index copy))) + (truly-the index (+ index copy))) ;; FIXME: why are we VECTOR-SAP'ing things here? what's the point? ;; and are there SB-UNICODE issues here as well? --njf, 2005-03-24 (sb!sys:without-gcing @@ -1111,24 +1111,24 @@ start copy))) (if (and (> requested copy) eof-error-p) - (error 'end-of-file :stream stream) - copy))) + (error 'end-of-file :stream stream) + copy))) (defun string-in-misc (stream operation &optional arg1 arg2) (declare (type string-input-stream stream) - (ignore arg2)) + (ignore arg2)) (case operation (:file-position (if arg1 - (setf (string-input-stream-current stream) - (case arg1 - (:start 0) - (:end (string-input-stream-end stream)) - ;; We allow moving position beyond EOF. Errors happen - ;; on read, not move -- or the user may extend the - ;; input string. - (t arg1))) - (string-input-stream-current stream))) + (setf (string-input-stream-current stream) + (case arg1 + (:start 0) + (:end (string-input-stream-end stream)) + ;; We allow moving position beyond EOF. Errors happen + ;; on read, not move -- or the user may extend the + ;; input string. + (t arg1))) + (string-input-stream-current stream))) ;; According to ANSI: "Should signal an error of type type-error ;; if stream is not a stream associated with a file." ;; This is checked by FILE-LENGTH, so no need to do it here either. @@ -1136,8 +1136,8 @@ (:unread (decf (string-input-stream-current stream))) (:close (set-closed-flame stream)) (:listen (or (/= (the index (string-input-stream-current stream)) - (the index (string-input-stream-end stream))) - :eof)) + (the index (string-input-stream-end stream))) + :eof)) (:element-type (array-element-type (string-input-stream-string stream))))) (defun make-string-input-stream (string &optional (start 0) end) @@ -1145,10 +1145,10 @@ "Return an input stream which will supply the characters of STRING between START and END in order." (declare (type string string) - (type index start) - (type (or index null) end)) + (type index start) + (type (or index null) end)) (let* ((string (coerce string '(simple-array character (*)))) - (end (%check-vector-sequence-bounds string start end))) + (end (%check-vector-sequence-bounds string start end))) (with-array-data ((string string) (start start) (end end)) (internal-make-string-input-stream string ;; now simple @@ -1158,14 +1158,14 @@ ;;;; STRING-OUTPUT-STREAM stuff (defstruct (string-output-stream - (:include ansi-stream - (out #'string-ouch) - (sout #'string-sout) - (misc #'string-out-misc)) - (:constructor make-string-output-stream - (&key (element-type 'character) - &aux (string (make-string 40)))) - (:copier nil)) + (:include ansi-stream + (out #'string-ouch) + (sout #'string-sout) + (misc #'string-out-misc)) + (:constructor make-string-output-stream + (&key (element-type 'character) + &aux (string (make-string 40)))) + (:copier nil)) ;; The string we throw stuff in. (string (missing-arg) :type (simple-array character (*))) ;; Index of the next location to use. @@ -1186,39 +1186,39 @@ (defun string-ouch (stream character) (let ((current (string-output-stream-index stream)) - (workspace (string-output-stream-string stream))) + (workspace (string-output-stream-string stream))) (declare (type (simple-array character (*)) workspace) - (type fixnum current)) + (type fixnum current)) (if (= current (the fixnum (length workspace))) - (let ((new-workspace (make-string (* current 2)))) - (replace new-workspace workspace) - (setf (aref new-workspace current) character - (string-output-stream-string stream) new-workspace)) - (setf (aref workspace current) character)) + (let ((new-workspace (make-string (* current 2)))) + (replace new-workspace workspace) + (setf (aref new-workspace current) character + (string-output-stream-string stream) new-workspace)) + (setf (aref workspace current) character)) (setf (string-output-stream-index stream) (1+ current)))) (defun string-sout (stream string start end) (declare (type simple-string string) - (type fixnum start end)) + (type fixnum start end)) (let* ((string (if (typep string '(simple-array character (*))) - string - (coerce string '(simple-array character (*))))) - (current (string-output-stream-index stream)) - (length (- end start)) - (dst-end (+ length current)) - (workspace (string-output-stream-string stream))) + string + (coerce string '(simple-array character (*))))) + (current (string-output-stream-index stream)) + (length (- end start)) + (dst-end (+ length current)) + (workspace (string-output-stream-string stream))) (declare (type (simple-array character (*)) workspace string) - (type fixnum current length dst-end)) + (type fixnum current length dst-end)) (if (> dst-end (the fixnum (length workspace))) - (let ((new-workspace (make-string (+ (* current 2) length)))) - (replace new-workspace workspace :end2 current) - (replace new-workspace string - :start1 current :end1 dst-end - :start2 start :end2 end) - (setf (string-output-stream-string stream) new-workspace)) - (replace workspace string - :start1 current :end1 dst-end - :start2 start :end2 end)) + (let ((new-workspace (make-string (+ (* current 2) length)))) + (replace new-workspace workspace :end2 current) + (replace new-workspace string + :start1 current :end1 dst-end + :start2 start :end2 end) + (setf (string-output-stream-string stream) new-workspace)) + (replace workspace string + :start1 current :end1 dst-end + :start2 start :end2 end)) (setf (string-output-stream-index stream) dst-end))) (defun string-out-misc (stream operation &optional arg1 arg2) @@ -1226,36 +1226,36 @@ (case operation (:file-position (if arg1 - (let ((end (string-output-stream-last-index stream))) - (setf (string-output-stream-index-cache stream) end - (string-output-stream-index stream) - (case arg1 - (:start 0) - (:end end) - (t - ;; We allow moving beyond the end of stream, - ;; implicitly extending the output stream. - (let ((buffer (string-output-stream-string stream))) - (when (> arg1 (length buffer)) - (setf (string-output-stream-string stream) - (make-string - arg1 :element-type (array-element-type buffer)) - (subseq (string-output-stream-string stream) - 0 end) - (subseq buffer 0 end)))) - arg1)))) - (string-output-stream-index stream))) + (let ((end (string-output-stream-last-index stream))) + (setf (string-output-stream-index-cache stream) end + (string-output-stream-index stream) + (case arg1 + (:start 0) + (:end end) + (t + ;; We allow moving beyond the end of stream, + ;; implicitly extending the output stream. + (let ((buffer (string-output-stream-string stream))) + (when (> arg1 (length buffer)) + (setf (string-output-stream-string stream) + (make-string + arg1 :element-type (array-element-type buffer)) + (subseq (string-output-stream-string stream) + 0 end) + (subseq buffer 0 end)))) + arg1)))) + (string-output-stream-index stream))) (:close (set-closed-flame stream)) (:charpos (do ((index (1- (the fixnum (string-output-stream-index stream))) - (1- index)) - (count 0 (1+ count)) - (string (string-output-stream-string stream))) - ((< index 0) count) + (1- index)) + (count 0 (1+ count)) + (string (string-output-stream-string stream))) + ((< index 0) count) (declare (type (simple-array character (*)) string) - (type fixnum index count)) + (type fixnum index count)) (if (char= (schar string index) #\newline) - (return count)))) + (return count)))) (:element-type (array-element-type (string-output-stream-string stream))))) ;;; Return a string of all the characters sent to a stream made by @@ -1263,37 +1263,37 @@ (defun get-output-stream-string (stream) (declare (type string-output-stream stream)) (let* ((length (string-output-stream-last-index stream)) - (element-type (string-output-stream-element-type stream)) - (result - (case element-type - ;; overwhelmingly common case: can be inlined - ((character) (make-string length)) - ;; slightly less common cases: inline it anyway - ((base-char standard-char) - (make-string length :element-type 'base-char)) - (t (make-string length :element-type element-type))))) + (element-type (string-output-stream-element-type stream)) + (result + (case element-type + ;; overwhelmingly common case: can be inlined + ((character) (make-string length)) + ;; slightly less common cases: inline it anyway + ((base-char standard-char) + (make-string length :element-type 'base-char)) + (t (make-string length :element-type element-type))))) ;; For the benefit of the REPLACE transform, let's do this, so ;; that the common case isn't ludicrously expensive. - (etypecase result - ((simple-array character (*)) + (etypecase result + ((simple-array character (*)) (replace result (string-output-stream-string stream))) (simple-base-string (replace result (string-output-stream-string stream))) ((simple-array nil (*)) (replace result (string-output-stream-string stream)))) (setf (string-output-stream-index stream) 0 - (string-output-stream-index-cache stream) 0) + (string-output-stream-index-cache stream) 0) result)) ;;; Dump the characters buffer up in IN-STREAM to OUT-STREAM as ;;; GET-OUTPUT-STREAM-STRING would return them. (defun dump-output-stream-string (in-stream out-stream) (%write-string (string-output-stream-string in-stream) - out-stream - 0 - (string-output-stream-last-index in-stream)) + out-stream + 0 + (string-output-stream-last-index in-stream)) (setf (string-output-stream-index in-stream) 0 - (string-output-stream-index-cache in-stream) 0)) + (string-output-stream-index-cache in-stream) 0)) ;;;; fill-pointer streams @@ -1305,69 +1305,69 @@ ;;; ideally without destroying all hope of efficiency. (deftype string-with-fill-pointer () '(and (vector character) - (satisfies array-has-fill-pointer-p))) + (satisfies array-has-fill-pointer-p))) (defstruct (fill-pointer-output-stream - (:include ansi-stream - (out #'fill-pointer-ouch) - (sout #'fill-pointer-sout) - (misc #'fill-pointer-misc)) - (:constructor make-fill-pointer-output-stream (string)) - (:copier nil)) + (:include ansi-stream + (out #'fill-pointer-ouch) + (sout #'fill-pointer-sout) + (misc #'fill-pointer-misc)) + (:constructor make-fill-pointer-output-stream (string)) + (:copier nil)) ;; a string with a fill pointer where we stuff the stuff we write (string (missing-arg) :type string-with-fill-pointer :read-only t)) (defun fill-pointer-ouch (stream character) (let* ((buffer (fill-pointer-output-stream-string stream)) - (current (fill-pointer buffer)) - (current+1 (1+ current))) + (current (fill-pointer buffer)) + (current+1 (1+ current))) (declare (fixnum current)) (with-array-data ((workspace buffer) (start) (end)) (declare (type (simple-array character (*)) workspace)) (let ((offset-current (+ start current))) - (declare (fixnum offset-current)) - (if (= offset-current end) - (let* ((new-length (1+ (* current 2))) - (new-workspace (make-string new-length))) - (declare (type (simple-array character (*)) new-workspace)) + (declare (fixnum offset-current)) + (if (= offset-current end) + (let* ((new-length (1+ (* current 2))) + (new-workspace (make-string new-length))) + (declare (type (simple-array character (*)) new-workspace)) (replace new-workspace workspace :start2 start :end2 offset-current) - (setf workspace new-workspace - offset-current current) - (set-array-header buffer workspace new-length - current+1 0 new-length nil)) - (setf (fill-pointer buffer) current+1)) - (setf (schar workspace offset-current) character))) + (setf workspace new-workspace + offset-current current) + (set-array-header buffer workspace new-length + current+1 0 new-length nil)) + (setf (fill-pointer buffer) current+1)) + (setf (schar workspace offset-current) character))) current+1)) (defun fill-pointer-sout (stream string start end) (declare (simple-string string) (fixnum start end)) (let* ((string (if (typep string '(simple-array character (*))) - string - (coerce string '(simple-array character (*))))) - (buffer (fill-pointer-output-stream-string stream)) - (current (fill-pointer buffer)) - (string-len (- end start)) - (dst-end (+ string-len current))) + string + (coerce string '(simple-array character (*))))) + (buffer (fill-pointer-output-stream-string stream)) + (current (fill-pointer buffer)) + (string-len (- end start)) + (dst-end (+ string-len current))) (declare (fixnum current dst-end string-len)) (with-array-data ((workspace buffer) (dst-start) (dst-length)) (declare (type (simple-array character (*)) workspace)) (let ((offset-dst-end (+ dst-start dst-end)) - (offset-current (+ dst-start current))) - (declare (fixnum offset-dst-end offset-current)) - (if (> offset-dst-end dst-length) - (let* ((new-length (+ (the fixnum (* current 2)) string-len)) - (new-workspace (make-string new-length))) - (declare (type (simple-array character (*)) new-workspace)) + (offset-current (+ dst-start current))) + (declare (fixnum offset-dst-end offset-current)) + (if (> offset-dst-end dst-length) + (let* ((new-length (+ (the fixnum (* current 2)) string-len)) + (new-workspace (make-string new-length))) + (declare (type (simple-array character (*)) new-workspace)) (replace new-workspace workspace :start2 dst-start :end2 offset-current) - (setf workspace new-workspace + (setf workspace new-workspace offset-current current offset-dst-end dst-end) - (set-array-header buffer workspace new-length - dst-end 0 new-length nil)) - (setf (fill-pointer buffer) dst-end)) - (replace workspace string + (set-array-header buffer workspace new-length + dst-end 0 new-length nil)) + (setf (fill-pointer buffer) dst-end)) + (replace workspace string :start1 offset-current :start2 start :end2 end))) dst-end)) @@ -1377,43 +1377,43 @@ (:file-position (let ((buffer (fill-pointer-output-stream-string stream))) (if arg1 - (setf (fill-pointer buffer) - (case arg1 - (:start 0) - ;; Fill-pointer is always at fill-pointer we will - ;; make :END move to the end of the actual string. - (:end (array-total-size buffer)) - ;; We allow moving beyond the end of string if the - ;; string is adjustable. - (t (when (>= arg1 (array-total-size buffer)) - (if (adjustable-array-p buffer) - (adjust-array buffer arg1) - (error "Cannot move FILE-POSITION beyond the end ~ + (setf (fill-pointer buffer) + (case arg1 + (:start 0) + ;; Fill-pointer is always at fill-pointer we will + ;; make :END move to the end of the actual string. + (:end (array-total-size buffer)) + ;; We allow moving beyond the end of string if the + ;; string is adjustable. + (t (when (>= arg1 (array-total-size buffer)) + (if (adjustable-array-p buffer) + (adjust-array buffer arg1) + (error "Cannot move FILE-POSITION beyond the end ~ of WITH-OUTPUT-TO-STRING stream ~ constructed with non-adjustable string."))) - arg1))) - (fill-pointer buffer)))) + arg1))) + (fill-pointer buffer)))) (:charpos (let* ((buffer (fill-pointer-output-stream-string stream)) - (current (fill-pointer buffer))) + (current (fill-pointer buffer))) (with-array-data ((string buffer) (start) (end current)) - (declare (simple-string string) (ignore start)) - (let ((found (position #\newline string :test #'char= - :end end :from-end t))) - (if found - (- end (the fixnum found)) - current))))) + (declare (simple-string string) (ignore start)) + (let ((found (position #\newline string :test #'char= + :end end :from-end t))) + (if found + (- end (the fixnum found)) + current))))) (:element-type (array-element-type - (fill-pointer-output-stream-string stream))))) + (fill-pointer-output-stream-string stream))))) ;;;; indenting streams (defstruct (indenting-stream (:include ansi-stream - (out #'indenting-out) - (sout #'indenting-sout) - (misc #'indenting-misc)) - (:constructor make-indenting-stream (stream)) - (:copier nil)) + (out #'indenting-out) + (sout #'indenting-sout) + (misc #'indenting-misc)) + (:constructor make-indenting-stream (stream)) + (:copier nil)) ;; the stream we're based on stream ;; how much we indent on each line @@ -1428,7 +1428,7 @@ (defmacro indenting-indent (stream sub-stream) ;; KLUDGE: bare magic number 60 `(do ((i 0 (+ i 60)) - (indentation (indenting-stream-indentation ,stream))) + (indentation (indenting-stream-indentation ,stream))) ((>= i indentation)) (%write-string #.(make-string 60 :initial-element #\Space) @@ -1441,7 +1441,7 @@ (let ((sub-stream (indenting-stream-stream stream))) (write-char char sub-stream) (if (char= char #\newline) - (indenting-indent stream sub-stream)))) + (indenting-indent stream sub-stream)))) ;;; INDENTING-SOUT writes a string to an indenting stream. (defun indenting-sout (stream string start end) @@ -1451,12 +1451,12 @@ ((= i end)) (let ((newline (position #\newline string :start i :end end))) (cond (newline - (%write-string string sub-stream i (1+ newline)) - (indenting-indent stream sub-stream) - (setq i (+ newline 1))) - (t - (%write-string string sub-stream i end) - (setq i end)))))) + (%write-string string sub-stream i (1+ newline)) + (indenting-indent stream sub-stream) + (setq i (+ newline 1))) + (t + (%write-string string sub-stream i end) + (setq i end)))))) ;;; INDENTING-MISC just treats just the :LINE-LENGTH message ;;; differently. INDENTING-CHARPOS says the charpos is the charpos of @@ -1464,40 +1464,40 @@ (defun indenting-misc (stream operation &optional arg1 arg2) (let ((sub-stream (indenting-stream-stream stream))) (if (ansi-stream-p sub-stream) - (let ((method (ansi-stream-misc sub-stream))) - (case operation - (:line-length - (let ((line-length (funcall method sub-stream operation))) - (if line-length - (- line-length (indenting-stream-indentation stream))))) - (:charpos - (let ((charpos (funcall method sub-stream operation))) - (if charpos - (- charpos (indenting-stream-indentation stream))))) - (t - (funcall method sub-stream operation arg1 arg2)))) - ;; must be Gray streams FUNDAMENTAL-STREAM - (case operation - (:line-length - (let ((line-length (stream-line-length sub-stream))) - (if line-length - (- line-length (indenting-stream-indentation stream))))) - (:charpos - (let ((charpos (stream-line-column sub-stream))) - (if charpos - (- charpos (indenting-stream-indentation stream))))) - (t - (stream-misc-dispatch sub-stream operation arg1 arg2)))))) + (let ((method (ansi-stream-misc sub-stream))) + (case operation + (:line-length + (let ((line-length (funcall method sub-stream operation))) + (if line-length + (- line-length (indenting-stream-indentation stream))))) + (:charpos + (let ((charpos (funcall method sub-stream operation))) + (if charpos + (- charpos (indenting-stream-indentation stream))))) + (t + (funcall method sub-stream operation arg1 arg2)))) + ;; must be Gray streams FUNDAMENTAL-STREAM + (case operation + (:line-length + (let ((line-length (stream-line-length sub-stream))) + (if line-length + (- line-length (indenting-stream-indentation stream))))) + (:charpos + (let ((charpos (stream-line-column sub-stream))) + (if charpos + (- charpos (indenting-stream-indentation stream))))) + (t + (stream-misc-dispatch sub-stream operation arg1 arg2)))))) (declaim (maybe-inline read-char unread-char read-byte listen)) ;;;; case frobbing streams, used by FORMAT ~(...~) (defstruct (case-frob-stream - (:include ansi-stream - (misc #'case-frob-misc)) - (:constructor %make-case-frob-stream (target out sout)) - (:copier nil)) + (:include ansi-stream + (misc #'case-frob-misc)) + (:constructor %make-case-frob-stream (target out sout)) + (:copier nil)) (target (missing-arg) :type stream)) (defun make-case-frob-stream (target kind) @@ -1511,29 +1511,29 @@ :CAPITALIZE-FIRST - convert the first letter of the first word to upper case and everything else to lower case." (declare (type stream target) - (type (member :upcase :downcase :capitalize :capitalize-first) - kind) - (values stream)) + (type (member :upcase :downcase :capitalize :capitalize-first) + kind) + (values stream)) (if (case-frob-stream-p target) ;; If we are going to be writing to a stream that already does ;; case frobbing, why bother frobbing the case just so it can ;; frob it again? target (multiple-value-bind (out sout) - (ecase kind - (:upcase - (values #'case-frob-upcase-out - #'case-frob-upcase-sout)) - (:downcase - (values #'case-frob-downcase-out - #'case-frob-downcase-sout)) - (:capitalize - (values #'case-frob-capitalize-out - #'case-frob-capitalize-sout)) - (:capitalize-first - (values #'case-frob-capitalize-first-out - #'case-frob-capitalize-first-sout))) - (%make-case-frob-stream target out sout)))) + (ecase kind + (:upcase + (values #'case-frob-upcase-out + #'case-frob-upcase-sout)) + (:downcase + (values #'case-frob-downcase-out + #'case-frob-downcase-sout)) + (:capitalize + (values #'case-frob-capitalize-out + #'case-frob-capitalize-sout)) + (:capitalize-first + (values #'case-frob-capitalize-first-out + #'case-frob-capitalize-first-sout))) + (%make-case-frob-stream target out sout)))) (defun case-frob-misc (stream op &optional arg1 arg2) (declare (type case-frob-stream stream)) @@ -1543,189 +1543,189 @@ (t (let ((target (case-frob-stream-target stream))) (if (ansi-stream-p target) - (funcall (ansi-stream-misc target) target op arg1 arg2) - (stream-misc-dispatch target op arg1 arg2)))))) + (funcall (ansi-stream-misc target) target op arg1 arg2) + (stream-misc-dispatch target op arg1 arg2)))))) (defun case-frob-upcase-out (stream char) (declare (type case-frob-stream stream) - (type character char)) + (type character char)) (let ((target (case-frob-stream-target stream)) - (char (char-upcase char))) + (char (char-upcase char))) (if (ansi-stream-p target) - (funcall (ansi-stream-out target) target char) - (stream-write-char target char)))) + (funcall (ansi-stream-out target) target char) + (stream-write-char target char)))) (defun case-frob-upcase-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-string str) - (type index start) - (type (or index null) end)) + (type simple-string str) + (type index start) + (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) - (len (length str)) - (end (or end len)) - (string (if (and (zerop start) (= len end)) - (string-upcase str) - (nstring-upcase (subseq str start end)))) - (string-len (- end start))) + (len (length str)) + (end (or end len)) + (string (if (and (zerop start) (= len end)) + (string-upcase str) + (nstring-upcase (subseq str start end)))) + (string-len (- end start))) (if (ansi-stream-p target) - (funcall (ansi-stream-sout target) target string 0 string-len) - (stream-write-string target string 0 string-len)))) + (funcall (ansi-stream-sout target) target string 0 string-len) + (stream-write-string target string 0 string-len)))) (defun case-frob-downcase-out (stream char) (declare (type case-frob-stream stream) - (type character char)) + (type character char)) (let ((target (case-frob-stream-target stream)) - (char (char-downcase char))) + (char (char-downcase char))) (if (ansi-stream-p target) - (funcall (ansi-stream-out target) target char) - (stream-write-char target char)))) + (funcall (ansi-stream-out target) target char) + (stream-write-char target char)))) (defun case-frob-downcase-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-string str) - (type index start) - (type (or index null) end)) + (type simple-string str) + (type index start) + (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) - (len (length str)) - (end (or end len)) - (string (if (and (zerop start) (= len end)) - (string-downcase str) - (nstring-downcase (subseq str start end)))) - (string-len (- end start))) + (len (length str)) + (end (or end len)) + (string (if (and (zerop start) (= len end)) + (string-downcase str) + (nstring-downcase (subseq str start end)))) + (string-len (- end start))) (if (ansi-stream-p target) - (funcall (ansi-stream-sout target) target string 0 string-len) - (stream-write-string target string 0 string-len)))) + (funcall (ansi-stream-sout target) target string 0 string-len) + (stream-write-string target string 0 string-len)))) (defun case-frob-capitalize-out (stream char) (declare (type case-frob-stream stream) - (type character char)) + (type character char)) (let ((target (case-frob-stream-target stream))) (cond ((alphanumericp char) - (let ((char (char-upcase char))) - (if (ansi-stream-p target) - (funcall (ansi-stream-out target) target char) - (stream-write-char target char))) - (setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out) - (setf (case-frob-stream-sout stream) - #'case-frob-capitalize-aux-sout)) - (t - (if (ansi-stream-p target) - (funcall (ansi-stream-out target) target char) - (stream-write-char target char)))))) + (let ((char (char-upcase char))) + (if (ansi-stream-p target) + (funcall (ansi-stream-out target) target char) + (stream-write-char target char))) + (setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out) + (setf (case-frob-stream-sout stream) + #'case-frob-capitalize-aux-sout)) + (t + (if (ansi-stream-p target) + (funcall (ansi-stream-out target) target char) + (stream-write-char target char)))))) (defun case-frob-capitalize-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-string str) - (type index start) - (type (or index null) end)) + (type simple-string str) + (type index start) + (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) - (str (subseq str start end)) - (len (length str)) - (inside-word nil)) + (str (subseq str start end)) + (len (length str)) + (inside-word nil)) (dotimes (i len) (let ((char (schar str i))) - (cond ((not (alphanumericp char)) - (setf inside-word nil)) - (inside-word - (setf (schar str i) (char-downcase char))) - (t - (setf inside-word t) - (setf (schar str i) (char-upcase char)))))) + (cond ((not (alphanumericp char)) + (setf inside-word nil)) + (inside-word + (setf (schar str i) (char-downcase char))) + (t + (setf inside-word t) + (setf (schar str i) (char-upcase char)))))) (when inside-word (setf (case-frob-stream-out stream) - #'case-frob-capitalize-aux-out) + #'case-frob-capitalize-aux-out) (setf (case-frob-stream-sout stream) - #'case-frob-capitalize-aux-sout)) + #'case-frob-capitalize-aux-sout)) (if (ansi-stream-p target) - (funcall (ansi-stream-sout target) target str 0 len) - (stream-write-string target str 0 len)))) + (funcall (ansi-stream-sout target) target str 0 len) + (stream-write-string target str 0 len)))) (defun case-frob-capitalize-aux-out (stream char) (declare (type case-frob-stream stream) - (type character char)) + (type character char)) (let ((target (case-frob-stream-target stream))) (cond ((alphanumericp char) - (let ((char (char-downcase char))) - (if (ansi-stream-p target) - (funcall (ansi-stream-out target) target char) - (stream-write-char target char)))) - (t - (if (ansi-stream-p target) - (funcall (ansi-stream-out target) target char) - (stream-write-char target char)) - (setf (case-frob-stream-out stream) - #'case-frob-capitalize-out) - (setf (case-frob-stream-sout stream) - #'case-frob-capitalize-sout))))) + (let ((char (char-downcase char))) + (if (ansi-stream-p target) + (funcall (ansi-stream-out target) target char) + (stream-write-char target char)))) + (t + (if (ansi-stream-p target) + (funcall (ansi-stream-out target) target char) + (stream-write-char target char)) + (setf (case-frob-stream-out stream) + #'case-frob-capitalize-out) + (setf (case-frob-stream-sout stream) + #'case-frob-capitalize-sout))))) (defun case-frob-capitalize-aux-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-string str) - (type index start) - (type (or index null) end)) + (type simple-string str) + (type index start) + (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) - (str (subseq str start end)) - (len (length str)) - (inside-word t)) + (str (subseq str start end)) + (len (length str)) + (inside-word t)) (dotimes (i len) (let ((char (schar str i))) - (cond ((not (alphanumericp char)) - (setf inside-word nil)) - (inside-word - (setf (schar str i) (char-downcase char))) - (t - (setf inside-word t) - (setf (schar str i) (char-upcase char)))))) + (cond ((not (alphanumericp char)) + (setf inside-word nil)) + (inside-word + (setf (schar str i) (char-downcase char))) + (t + (setf inside-word t) + (setf (schar str i) (char-upcase char)))))) (unless inside-word (setf (case-frob-stream-out stream) - #'case-frob-capitalize-out) + #'case-frob-capitalize-out) (setf (case-frob-stream-sout stream) - #'case-frob-capitalize-sout)) + #'case-frob-capitalize-sout)) (if (ansi-stream-p target) - (funcall (ansi-stream-sout target) target str 0 len) - (stream-write-string target str 0 len)))) + (funcall (ansi-stream-sout target) target str 0 len) + (stream-write-string target str 0 len)))) (defun case-frob-capitalize-first-out (stream char) (declare (type case-frob-stream stream) - (type character char)) + (type character char)) (let ((target (case-frob-stream-target stream))) (cond ((alphanumericp char) - (let ((char (char-upcase char))) - (if (ansi-stream-p target) - (funcall (ansi-stream-out target) target char) - (stream-write-char target char))) - (setf (case-frob-stream-out stream) - #'case-frob-downcase-out) - (setf (case-frob-stream-sout stream) - #'case-frob-downcase-sout)) - (t - (if (ansi-stream-p target) - (funcall (ansi-stream-out target) target char) - (stream-write-char target char)))))) + (let ((char (char-upcase char))) + (if (ansi-stream-p target) + (funcall (ansi-stream-out target) target char) + (stream-write-char target char))) + (setf (case-frob-stream-out stream) + #'case-frob-downcase-out) + (setf (case-frob-stream-sout stream) + #'case-frob-downcase-sout)) + (t + (if (ansi-stream-p target) + (funcall (ansi-stream-out target) target char) + (stream-write-char target char)))))) (defun case-frob-capitalize-first-sout (stream str start end) (declare (type case-frob-stream stream) - (type simple-string str) - (type index start) - (type (or index null) end)) + (type simple-string str) + (type index start) + (type (or index null) end)) (let* ((target (case-frob-stream-target stream)) - (str (subseq str start end)) - (len (length str))) + (str (subseq str start end)) + (len (length str))) (dotimes (i len) (let ((char (schar str i))) - (when (alphanumericp char) - (setf (schar str i) (char-upcase char)) - (do ((i (1+ i) (1+ i))) - ((= i len)) - (setf (schar str i) (char-downcase (schar str i)))) - (setf (case-frob-stream-out stream) - #'case-frob-downcase-out) - (setf (case-frob-stream-sout stream) - #'case-frob-downcase-sout) - (return)))) + (when (alphanumericp char) + (setf (schar str i) (char-upcase char)) + (do ((i (1+ i) (1+ i))) + ((= i len)) + (setf (schar str i) (char-downcase (schar str i)))) + (setf (case-frob-stream-out stream) + #'case-frob-downcase-out) + (setf (case-frob-stream-sout stream) + #'case-frob-downcase-sout) + (return)))) (if (ansi-stream-p target) - (funcall (ansi-stream-sout target) target str 0 len) - (stream-write-string target str 0 len)))) + (funcall (ansi-stream-sout target) target str 0 len) + (stream-write-string target str 0 len)))) ;;;; READ-SEQUENCE @@ -1738,10 +1738,10 @@ then the extra elements near the end of sequence are not updated, and the index of the next element is returned." (declare (type sequence seq) - (type stream stream) - (type index start) - (type sequence-end end) - (values index)) + (type stream stream) + (type index start) + (type sequence-end end) + (values index)) (if (ansi-stream-p stream) (ansi-stream-read-sequence seq stream start end) ;; must be Gray streams FUNDAMENTAL-STREAM @@ -1749,50 +1749,50 @@ (defun ansi-stream-read-sequence (seq stream start %end) (declare (type sequence seq) - (type ansi-stream stream) - (type index start) - (type sequence-end %end) - (values index)) + (type ansi-stream stream) + (type index start) + (type sequence-end %end) + (values index)) (let ((end (or %end (length seq)))) (declare (type index end)) (etypecase seq (list (let ((read-function - (if (subtypep (stream-element-type stream) 'character) - #'ansi-stream-read-char - #'ansi-stream-read-byte))) - (do ((rem (nthcdr start seq) (rest rem)) - (i start (1+ i))) - ((or (endp rem) (>= i end)) i) - (declare (type list rem) - (type index i)) - (let ((el (funcall read-function stream nil :eof nil))) - (when (eq el :eof) - (return i)) - (setf (first rem) el))))) + (if (subtypep (stream-element-type stream) 'character) + #'ansi-stream-read-char + #'ansi-stream-read-byte))) + (do ((rem (nthcdr start seq) (rest rem)) + (i start (1+ i))) + ((or (endp rem) (>= i end)) i) + (declare (type list rem) + (type index i)) + (let ((el (funcall read-function stream nil :eof nil))) + (when (eq el :eof) + (return i)) + (setf (first rem) el))))) (vector (with-array-data ((data seq) (offset-start start) (offset-end end)) (typecase data - ((or (simple-array (unsigned-byte 8) (*)) - (simple-array (signed-byte 8) (*))) - (let* ((numbytes (- end start)) - (bytes-read (read-n-bytes stream data offset-start - numbytes nil))) - (if (< bytes-read numbytes) - (+ start bytes-read) - end))) - (t - (let ((read-function - (if (subtypep (stream-element-type stream) 'character) - #'ansi-stream-read-char - #'ansi-stream-read-byte))) - (do ((i offset-start (1+ i))) - ((>= i offset-end) end) - (declare (type index i)) - (let ((el (funcall read-function stream nil :eof nil))) - (when (eq el :eof) - (return (+ start (- i offset-start)))) - (setf (aref data i) el))))))))))) + ((or (simple-array (unsigned-byte 8) (*)) + (simple-array (signed-byte 8) (*))) + (let* ((numbytes (- end start)) + (bytes-read (read-n-bytes stream data offset-start + numbytes nil))) + (if (< bytes-read numbytes) + (+ start bytes-read) + end))) + (t + (let ((read-function + (if (subtypep (stream-element-type stream) 'character) + #'ansi-stream-read-char + #'ansi-stream-read-byte))) + (do ((i offset-start (1+ i))) + ((>= i offset-end) end) + (declare (type index i)) + (let ((el (funcall read-function stream nil :eof nil))) + (when (eq el :eof) + (return (+ start (- i offset-start)))) + (setf (aref data i) el))))))))))) ;;;; WRITE-SEQUENCE @@ -1800,10 +1800,10 @@ #!+sb-doc "Write the elements of SEQ bounded by START and END to STREAM." (declare (type sequence seq) - (type stream stream) - (type index start) - (type sequence-end end) - (values sequence)) + (type stream stream) + (type index start) + (type sequence-end end) + (values sequence)) (if (ansi-stream-p stream) (ansi-stream-write-sequence seq stream start end) ;; must be Gray-streams FUNDAMENTAL-STREAM @@ -1811,46 +1811,46 @@ (defun ansi-stream-write-sequence (seq stream start %end) (declare (type sequence seq) - (type ansi-stream stream) - (type index start) - (type sequence-end %end) - (values sequence)) + (type ansi-stream stream) + (type index start) + (type sequence-end %end) + (values sequence)) (let ((end (or %end (length seq)))) (declare (type index end)) (etypecase seq (list (let ((write-function - (if (subtypep (stream-element-type stream) 'character) - (ansi-stream-out stream) - (ansi-stream-bout stream)))) - (do ((rem (nthcdr start seq) (rest rem)) - (i start (1+ i))) - ((or (endp rem) (>= i end))) - (declare (type list rem) - (type index i)) - (funcall write-function stream (first rem))))) + (if (subtypep (stream-element-type stream) 'character) + (ansi-stream-out stream) + (ansi-stream-bout stream)))) + (do ((rem (nthcdr start seq) (rest rem)) + (i start (1+ i))) + ((or (endp rem) (>= i end))) + (declare (type list rem) + (type index i)) + (funcall write-function stream (first rem))))) (string (%write-string seq stream start end)) (vector (with-array-data ((data seq) (offset-start start) (offset-end end)) - (labels - ((output-seq-in-loop () - (let ((write-function - (if (subtypep (stream-element-type stream) 'character) - (ansi-stream-out stream) - (ansi-stream-bout stream)))) - (do ((i offset-start (1+ i))) - ((>= i offset-end)) - (declare (type index i)) - (funcall write-function stream (aref data i)))))) - (typecase data - ((or (simple-array (unsigned-byte 8) (*)) - (simple-array (signed-byte 8) (*))) - (if (fd-stream-p stream) - (output-raw-bytes stream data offset-start offset-end) - (output-seq-in-loop))) - (t - (output-seq-in-loop)))))))) + (labels + ((output-seq-in-loop () + (let ((write-function + (if (subtypep (stream-element-type stream) 'character) + (ansi-stream-out stream) + (ansi-stream-bout stream)))) + (do ((i offset-start (1+ i))) + ((>= i offset-end)) + (declare (type index i)) + (funcall write-function stream (aref data i)))))) + (typecase data + ((or (simple-array (unsigned-byte 8) (*)) + (simple-array (signed-byte 8) (*))) + (if (fd-stream-p stream) + (output-raw-bytes stream data offset-start offset-end) + (output-seq-in-loop))) + (t + (output-seq-in-loop)))))))) seq) ;;;; etc. diff --git a/src/code/string.lisp b/src/code/string.lisp index b1fe487..da9a068 100644 --- a/src/code/string.lisp +++ b/src/code/string.lisp @@ -16,16 +16,16 @@ string containing that character is returned. If X cannot be coerced into a string, an error occurs." (cond ((stringp x) x) - ((symbolp x) (symbol-name x)) - ((characterp x) - (let ((res (make-string 1))) - (setf (schar res 0) x) res)) - (t - (error 'simple-type-error - :datum x - :expected-type 'string-designator - :format-control "~S cannot be coerced to a string." - :format-arguments (list x))))) + ((symbolp x) (symbol-name x)) + ((characterp x) + (let ((res (make-string 1))) + (setf (schar res 0) x) res)) + (t + (error 'simple-type-error + :datum x + :expected-type 'string-designator + :format-control "~S cannot be coerced to a string." + :format-arguments (list x))))) ;;; %CHECK-VECTOR-SEQUENCE-BOUNDS is used to verify that the START and ;;; END arguments are valid bounding indices. @@ -46,32 +46,32 @@ (sb!xc:defmacro with-one-string ((string start end) &body forms) `(let* ((,string (if (stringp ,string) ,string (string ,string)))) (with-array-data ((,string ,string) - (,start ,start) - (,end - (%check-vector-sequence-bounds ,string ,start ,end))) + (,start ,start) + (,end + (%check-vector-sequence-bounds ,string ,start ,end))) ,@forms))) ;;; WITH-STRING is like WITH-ONE-STRING, but doesn't parse keywords. (sb!xc:defmacro with-string (string &rest forms) `(let ((,string (if (stringp ,string) ,string (string ,string)))) (with-array-data ((,string ,string) - (start) - (end (length (the vector ,string)))) + (start) + (end (length (the vector ,string)))) ,@forms))) ;;; WITH-TWO-STRINGS is used to set up string comparison operations. The ;;; keywords are parsed, and the strings are hacked into SIMPLE-STRINGs. (sb!xc:defmacro with-two-strings (string1 string2 start1 end1 cum-offset-1 - start2 end2 &rest forms) + start2 end2 &rest forms) `(let ((,string1 (if (stringp ,string1) ,string1 (string ,string1))) - (,string2 (if (stringp ,string2) ,string2 (string ,string2)))) + (,string2 (if (stringp ,string2) ,string2 (string ,string2)))) (with-array-data ((,string1 ,string1 :offset-var ,cum-offset-1) - (,start1 ,start1) - (,end1 (%check-vector-sequence-bounds - ,string1 ,start1 ,end1))) + (,start1 ,start1) + (,end1 (%check-vector-sequence-bounds + ,string1 ,start1 ,end1))) (with-array-data ((,string2 ,string2) - (,start2 ,start2) - (,end2 (%check-vector-sequence-bounds - ,string2 ,start2 ,end2))) - ,@forms)))) + (,start2 ,start2) + (,end2 (%check-vector-sequence-bounds + ,string2 ,start2 ,end2))) + ,@forms)))) ) ; EVAL-WHEN (defun char (string index) @@ -104,7 +104,7 @@ (defun string/=* (string1 string2 start1 end1 start2 end2) (with-two-strings string1 string2 start1 end1 offset1 start2 end2 (let ((comparison (%sp-string-compare string1 start1 end1 - string2 start2 end2))) + string2 start2 end2))) (if comparison (- (the fixnum comparison) offset1))))) (eval-when (:compile-toplevel :execute) @@ -115,23 +115,23 @@ (let ((offset1 (gensym))) `(with-two-strings string1 string2 start1 end1 ,offset1 start2 end2 (let ((index (%sp-string-compare string1 start1 end1 - string2 start2 end2))) - (if index - (cond ((= (the fixnum index) (the fixnum end1)) - ,(if lessp - `(- (the fixnum index) ,offset1) - `nil)) - ((= (+ (the fixnum index) (- start2 start1)) - (the fixnum end2)) - ,(if lessp - `nil - `(- (the fixnum index) ,offset1))) - ((,(if lessp 'char< 'char>) - (schar string1 index) - (schar string2 (+ (the fixnum index) (- start2 start1)))) - (- (the fixnum index) ,offset1)) - (t nil)) - ,(if equalp `(- (the fixnum end1) ,offset1) nil)))))) + string2 start2 end2))) + (if index + (cond ((= (the fixnum index) (the fixnum end1)) + ,(if lessp + `(- (the fixnum index) ,offset1) + `nil)) + ((= (+ (the fixnum index) (- start2 start1)) + (the fixnum end2)) + ,(if lessp + `nil + `(- (the fixnum index) ,offset1))) + ((,(if lessp 'char< 'char>) + (schar string1 index) + (schar string2 (+ (the fixnum index) (- start2 start1)))) + (- (the fixnum index) ,offset1)) + (t nil)) + ,(if equalp `(- (the fixnum end1) ,offset1) nil)))))) ) ; EVAL-WHEN (defun string<* (string1 string2 start1 end1 start2 end2) @@ -204,25 +204,25 @@ ;;; STRING-NOT-EQUAL-LOOP is used to generate character comparison loops for ;;; STRING-EQUAL and STRING-NOT-EQUAL. (sb!xc:defmacro string-not-equal-loop (end - end-value - &optional (abort-value nil abortp)) + end-value + &optional (abort-value nil abortp)) (declare (fixnum end)) (let ((end-test (if (= end 1) - `(= index1 (the fixnum end1)) - `(= index2 (the fixnum end2))))) + `(= index1 (the fixnum end1)) + `(= index2 (the fixnum end2))))) `(do ((index1 start1 (1+ index1)) - (index2 start2 (1+ index2))) - (,(if abortp - end-test - `(or ,end-test - (not (char-equal (schar string1 index1) - (schar string2 index2))))) - ,end-value) + (index2 start2 (1+ index2))) + (,(if abortp + end-test + `(or ,end-test + (not (char-equal (schar string1 index1) + (schar string2 index2))))) + ,end-value) (declare (fixnum index1 index2)) ,@(if abortp - `((if (not (char-equal (schar string1 index1) - (schar string2 index2))) - (return ,abort-value))))))) + `((if (not (char-equal (schar string1 index1) + (schar string2 index2))) + (return ,abort-value))))))) ) ; EVAL-WHEN @@ -234,11 +234,11 @@ (declare (fixnum start1 start2)) (with-two-strings string1 string2 start1 end1 nil start2 end2 (let ((slen1 (- (the fixnum end1) start1)) - (slen2 (- (the fixnum end2) start2))) + (slen2 (- (the fixnum end2) start2))) (declare (fixnum slen1 slen2)) (if (= slen1 slen2) - ;;return () immediately if lengths aren't equal. - (string-not-equal-loop 1 t nil))))) + ;;return () immediately if lengths aren't equal. + (string-not-equal-loop 1 t nil))))) (defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2) #!+sb-doc @@ -247,14 +247,14 @@ of the two strings. Otherwise, returns ()." (with-two-strings string1 string2 start1 end1 offset1 start2 end2 (let ((slen1 (- end1 start1)) - (slen2 (- end2 start2))) + (slen2 (- end2 start2))) (declare (fixnum slen1 slen2)) (cond ((= slen1 slen2) - (string-not-equal-loop 1 nil (- index1 offset1))) - ((< slen1 slen2) - (string-not-equal-loop 1 (- index1 offset1))) - (t - (string-not-equal-loop 2 (- index1 offset1))))))) + (string-not-equal-loop 1 nil (- index1 offset1))) + ((< slen1 slen2) + (string-not-equal-loop 1 (- index1 offset1))) + (t + (string-not-equal-loop 2 (- index1 offset1))))))) (eval-when (:compile-toplevel :execute) @@ -264,36 +264,36 @@ (defun string-less-greater-equal-tests (lessp equalp) (if lessp (if equalp - ;; STRING-NOT-GREATERP - (values '<= `(not (char-greaterp char1 char2))) - ;; STRING-LESSP - (values '< `(char-lessp char1 char2))) + ;; STRING-NOT-GREATERP + (values '<= `(not (char-greaterp char1 char2))) + ;; STRING-LESSP + (values '< `(char-lessp char1 char2))) (if equalp - ;; STRING-NOT-LESSP - (values '>= `(not (char-lessp char1 char2))) - ;; STRING-GREATERP - (values '> `(char-greaterp char1 char2))))) + ;; STRING-NOT-LESSP + (values '>= `(not (char-lessp char1 char2))) + ;; STRING-GREATERP + (values '> `(char-greaterp char1 char2))))) (sb!xc:defmacro string-less-greater-equal (lessp equalp) (multiple-value-bind (length-test character-test) (string-less-greater-equal-tests lessp equalp) `(with-two-strings string1 string2 start1 end1 offset1 start2 end2 (let ((slen1 (- (the fixnum end1) start1)) - (slen2 (- (the fixnum end2) start2))) - (declare (fixnum slen1 slen2)) - (do ((index1 start1 (1+ index1)) - (index2 start2 (1+ index2)) - (char1) - (char2)) - ((or (= index1 (the fixnum end1)) (= index2 (the fixnum end2))) - (if (,length-test slen1 slen2) (- index1 offset1))) - (declare (fixnum index1 index2)) - (setq char1 (schar string1 index1)) - (setq char2 (schar string2 index2)) - (if (not (char-equal char1 char2)) - (if ,character-test - (return (- index1 offset1)) - (return ())))))))) + (slen2 (- (the fixnum end2) start2))) + (declare (fixnum slen1 slen2)) + (do ((index1 start1 (1+ index1)) + (index2 start2 (1+ index2)) + (char1) + (char2)) + ((or (= index1 (the fixnum end1)) (= index2 (the fixnum end2))) + (if (,length-test slen1 slen2) (- index1 offset1))) + (declare (fixnum index1 index2)) + (setq char1 (schar string1 index1)) + (setq char2 (schar string2 index2)) + (if (not (char-equal char1 char2)) + (if ,character-test + (return (- index1 offset1)) + (return ())))))))) ) ; EVAL-WHEN @@ -335,7 +335,7 @@ (string-not-lessp* string1 string2 start1 end1 start2 end2)) (defun string-not-greaterp (string1 string2 &key (start1 0) end1 (start2 0) - end2) + end2) #!+sb-doc "Given two strings, if the first string is lexicographically less than or equal to the second string, returns the longest common prefix @@ -343,8 +343,8 @@ (string-not-greaterp* string1 string2 start1 end1 start2 end2)) (defun make-string (count &key - (element-type 'character) - ((:initial-element fill-char))) + (element-type 'character) + ((:initial-element fill-char))) #!+sb-doc "Given a character count and an optional fill character, makes and returns a new string COUNT long filled with the fill character." @@ -354,14 +354,14 @@ (make-string count :element-type element-type))) (flet ((%upcase (string start end) - (declare (string string) (index start) (type sequence-end end)) - (let ((saved-header string)) - (with-one-string (string start end) - (do ((index start (1+ index))) - ((= index (the fixnum end))) - (declare (fixnum index)) - (setf (schar string index) (char-upcase (schar string index))))) - saved-header))) + (declare (string string) (index start) (type sequence-end end)) + (let ((saved-header string)) + (with-one-string (string start end) + (do ((index start (1+ index))) + ((= index (the fixnum end))) + (declare (fixnum index)) + (setf (schar string index) (char-upcase (schar string index))))) + saved-header))) (defun string-upcase (string &key (start 0) end) (%upcase (copy-seq (string string)) start end)) (defun nstring-upcase (string &key (start 0) end) @@ -369,15 +369,15 @@ ) ; FLET (flet ((%downcase (string start end) - (declare (string string) (index start) (type sequence-end end)) - (let ((saved-header string)) - (with-one-string (string start end) - (do ((index start (1+ index))) - ((= index (the fixnum end))) - (declare (fixnum index)) - (setf (schar string index) - (char-downcase (schar string index))))) - saved-header))) + (declare (string string) (index start) (type sequence-end end)) + (let ((saved-header string)) + (with-one-string (string start end) + (do ((index start (1+ index))) + ((= index (the fixnum end))) + (declare (fixnum index)) + (setf (schar string index) + (char-downcase (schar string index))))) + saved-header))) (defun string-downcase (string &key (start 0) end) (%downcase (copy-seq (string string)) start end)) (defun nstring-downcase (string &key (start 0) end) @@ -385,25 +385,25 @@ ) ; FLET (flet ((%capitalize (string start end) - (declare (string string) (index start) (type sequence-end end)) - (let ((saved-header string)) + (declare (string string) (index start) (type sequence-end end)) + (let ((saved-header string)) (with-one-string (string start end) (do ((index start (1+ index)) - (new-word? t) - (char nil)) - ((= index (the fixnum end))) - (declare (fixnum index)) - (setq char (schar string index)) - (cond ((not (alphanumericp char)) - (setq new-word? t)) - (new-word? - ;; CHAR is the first case-modifiable character after - ;; a sequence of non-case-modifiable characters. - (setf (schar string index) (char-upcase char)) - (setq new-word? nil)) - (t - (setf (schar string index) (char-downcase char)))))) - saved-header))) + (new-word? t) + (char nil)) + ((= index (the fixnum end))) + (declare (fixnum index)) + (setq char (schar string index)) + (cond ((not (alphanumericp char)) + (setq new-word? t)) + (new-word? + ;; CHAR is the first case-modifiable character after + ;; a sequence of non-case-modifiable characters. + (setf (schar string index) (char-upcase char)) + (setq new-word? nil)) + (t + (setf (schar string index) (char-downcase char)))))) + saved-header))) (defun string-capitalize (string &key (start 0) end) (%capitalize (copy-seq (string string)) start end)) (defun nstring-capitalize (string &key (start 0) end) @@ -413,33 +413,33 @@ (defun string-left-trim (char-bag string) (with-string string (do ((index start (1+ index))) - ((or (= index (the fixnum end)) - (not (find (schar string index) char-bag :test #'char=))) - (subseq (the simple-string string) index end)) + ((or (= index (the fixnum end)) + (not (find (schar string index) char-bag :test #'char=))) + (subseq (the simple-string string) index end)) (declare (fixnum index))))) (defun string-right-trim (char-bag string) (with-string string (do ((index (1- (the fixnum end)) (1- index))) - ((or (< index start) - (not (find (schar string index) char-bag :test #'char=))) - (subseq (the simple-string string) start (1+ index))) + ((or (< index start) + (not (find (schar string index) char-bag :test #'char=))) + (subseq (the simple-string string) start (1+ index))) (declare (fixnum index))))) (defun string-trim (char-bag string) (with-string string (let* ((left-end (do ((index start (1+ index))) - ((or (= index (the fixnum end)) - (not (find (schar string index) - char-bag - :test #'char=))) - index) - (declare (fixnum index)))) - (right-end (do ((index (1- (the fixnum end)) (1- index))) - ((or (< index left-end) - (not (find (schar string index) - char-bag - :test #'char=))) - (1+ index)) - (declare (fixnum index))))) + ((or (= index (the fixnum end)) + (not (find (schar string index) + char-bag + :test #'char=))) + index) + (declare (fixnum index)))) + (right-end (do ((index (1- (the fixnum end)) (1- index))) + ((or (< index left-end) + (not (find (schar string index) + char-bag + :test #'char=))) + (1+ index)) + (declare (fixnum index))))) (subseq (the simple-string string) left-end right-end)))) diff --git a/src/code/stubs.lisp b/src/code/stubs.lisp index 0a50761..13413d4 100644 --- a/src/code/stubs.lisp +++ b/src/code/stubs.lisp @@ -14,7 +14,7 @@ (in-package "SB!IMPL") (macrolet ((def (name &optional (args '(x))) - `(defun ,name ,args (,name ,@args)))) + `(defun ,name ,args (,name ,@args)))) (def %code-code-size) (def %code-debug-info) (def %code-entry-points) diff --git a/src/code/sunos-os.lisp b/src/code/sunos-os.lisp index 626f606..b16ff01 100644 --- a/src/code/sunos-os.lisp +++ b/src/code/sunos-os.lisp @@ -28,22 +28,22 @@ if not available." (or *software-version* (setf *software-version* - (string-trim '(#\newline) - (with-output-to-string (stream) - (sb!ext:run-program "/bin/uname" `("-r") - :output stream)))))) + (string-trim '(#\newline) + (with-output-to-string (stream) + (sb!ext:run-program "/bin/uname" `("-r") + :output stream)))))) (defun os-cold-init-or-reinit () ; KLUDGE: don't know what to do here (/show "entering sunos-os.lisp OS-COLD-INIT-OR-REINIT") (setf *software-version* nil) (/show "setting *DEFAULT-PATHNAME-DEFAULTS*") (setf *default-pathname-defaults* - ;; (temporary value, so that #'PATHNAME won't blow up when - ;; we call it below:) - (make-trivial-default-pathname) - *default-pathname-defaults* - ;; (final value, constructed using #'PATHNAME:) - (pathname (sb!unix:posix-getcwd/))) + ;; (temporary value, so that #'PATHNAME won't blow up when + ;; we call it below:) + (make-trivial-default-pathname) + *default-pathname-defaults* + ;; (final value, constructed using #'PATHNAME:) + (pathname (sb!unix:posix-getcwd/))) (/show "leaving sunos-os.lisp OS-COLD-INIT-OR-REINIT")) ;;; Return system time, user time and number of page faults. diff --git a/src/code/sxhash.lisp b/src/code/sxhash.lisp index 2afbee6..53431b2 100644 --- a/src/code/sxhash.lisp +++ b/src/code/sxhash.lisp @@ -18,30 +18,30 @@ ;;; order to avoid boxing. (deftransform sxhash ((x) (single-float)) '(let* ((val (+ 0.0f0 x)) - (bits (logand (single-float-bits val) #.(1- (ash 1 32))))) + (bits (logand (single-float-bits val) #.(1- (ash 1 32))))) (logxor 66194023 - (sxhash (the fixnum - (logand most-positive-fixnum - (logxor bits - (ash bits -7)))))))) + (sxhash (the fixnum + (logand most-positive-fixnum + (logxor bits + (ash bits -7)))))))) (deftransform sxhash ((x) (double-float)) '(let* ((val (+ 0.0d0 x)) - (hi (logand (double-float-high-bits val) #.(1- (ash 1 32)))) - (lo (double-float-low-bits val)) - (hilo (logxor hi lo))) + (hi (logand (double-float-high-bits val) #.(1- (ash 1 32)))) + (lo (double-float-low-bits val)) + (hilo (logxor hi lo))) (logxor 475038542 - (sxhash (the fixnum - (logand most-positive-fixnum - (logxor hilo - (ash hilo -7)))))))) + (sxhash (the fixnum + (logand most-positive-fixnum + (logxor hilo + (ash hilo -7)))))))) ;;; SXHASH of FIXNUM values is defined as a DEFTRANSFORM because it's so ;;; simple. (deftransform sxhash ((x) (fixnum)) '(logand most-positive-fixnum - (logxor (ash (logand x (ash most-positive-fixnum -4)) 4) - (logand (ash x -1) most-positive-fixnum) ; to get sign bit into hash - 361475658))) + (logxor (ash (logand x (ash most-positive-fixnum -4)) 4) + (logand (ash x -1) most-positive-fixnum) ; to get sign bit into hash + 361475658))) ;;; SXHASH of SIMPLE-BIT-VECTOR values is defined as a DEFTRANSFORM ;;; because it is endian-dependent. @@ -50,42 +50,42 @@ (declare (type fixnum result)) (let ((length (length x))) (cond - ((= length 0) (mix result (sxhash 0))) - (t - (mixf result (sxhash (length x))) - (do* ((i sb!vm:vector-data-offset (+ i 1)) - ;; FIXME: should we respect DEPTHOID? SXHASH on - ;; strings doesn't seem to... - (end-1 (+ sb!vm:vector-data-offset - (floor (1- length) sb!vm:n-word-bits)))) - ((= i end-1) - (let ((num - (logand - (ash (1- (ash 1 (mod length sb!vm:n-word-bits))) - ,(ecase sb!c:*backend-byte-order* - (:little-endian 0) - (:big-endian - '(- sb!vm:n-word-bits - (mod length sb!vm:n-word-bits))))) - (%raw-bits x i)))) - (mix result ,(ecase sb!c:*backend-byte-order* - (:little-endian - '(logand num most-positive-fixnum)) - (:big-endian - '(ash num (- sb!vm:n-lowtag-bits))))))) - (declare (type index i end-1)) - (let ((num (%raw-bits x i))) - (mixf result ,(ecase sb!c:*backend-byte-order* - (:little-endian - '(logand num most-positive-fixnum)) - ;; FIXME: I'm not certain that - ;; N-LOWTAG-BITS is the clearest way of - ;; expressing this: it's essentially the - ;; difference between `(UNSIGNED-BYTE - ;; ,SB!VM:N-WORD-BITS) and (AND FIXNUM - ;; UNSIGNED-BYTE). - (:big-endian - '(ash num (- sb!vm:n-lowtag-bits)))))))))))) + ((= length 0) (mix result (sxhash 0))) + (t + (mixf result (sxhash (length x))) + (do* ((i sb!vm:vector-data-offset (+ i 1)) + ;; FIXME: should we respect DEPTHOID? SXHASH on + ;; strings doesn't seem to... + (end-1 (+ sb!vm:vector-data-offset + (floor (1- length) sb!vm:n-word-bits)))) + ((= i end-1) + (let ((num + (logand + (ash (1- (ash 1 (mod length sb!vm:n-word-bits))) + ,(ecase sb!c:*backend-byte-order* + (:little-endian 0) + (:big-endian + '(- sb!vm:n-word-bits + (mod length sb!vm:n-word-bits))))) + (%raw-bits x i)))) + (mix result ,(ecase sb!c:*backend-byte-order* + (:little-endian + '(logand num most-positive-fixnum)) + (:big-endian + '(ash num (- sb!vm:n-lowtag-bits))))))) + (declare (type index i end-1)) + (let ((num (%raw-bits x i))) + (mixf result ,(ecase sb!c:*backend-byte-order* + (:little-endian + '(logand num most-positive-fixnum)) + ;; FIXME: I'm not certain that + ;; N-LOWTAG-BITS is the clearest way of + ;; expressing this: it's essentially the + ;; difference between `(UNSIGNED-BYTE + ;; ,SB!VM:N-WORD-BITS) and (AND FIXNUM + ;; UNSIGNED-BYTE). + (:big-endian + '(ash num (- sb!vm:n-lowtag-bits)))))))))))) ;;; Some other common SXHASH cases are defined as DEFTRANSFORMs in ;;; order to avoid having to do TYPECASE at runtime. @@ -104,28 +104,28 @@ (if #+sb-xc-host nil #-sb-xc-host (constant-lvar-p x) (sxhash (lvar-value x)) (if (csubtypep (lvar-type x) (specifier-type 'null)) - ;; FIXME: this isn't in fact as optimized as it could be; - ;; this does a memory load, whereas (because we know the - ;; layout of NIL) we could simply take the address of NIL - ;; (or the contents of NULL-TN) and mask off the appropriate - ;; bits, since SYMBOL-HASH of NIL is also NIL's CDR, which - ;; is NIL. -- CSR, 2004-07-14 - '(symbol-hash x) - ;; Cache the value of the symbol's sxhash in the symbol-hash - ;; slot. - '(let ((result (symbol-hash x))) - ;; 0 marks uninitialized slot. We can't use negative - ;; values for the uninitialized slots since NIL might be - ;; located so high in memory on some platforms that its - ;; SYMBOL-HASH (which contains NIL itself) is a negative - ;; fixnum. - (if (= 0 result) - (let ((sxhash (%sxhash-simple-string (symbol-name x)))) - ;; We could do a (logior sxhash #x10000000) to - ;; ensure that we never store a 0 in the - ;; slot. However, it's such an unlikely event - ;; (1/5e8?) that it makes more sense to optimize for - ;; the common case... - (%set-symbol-hash x sxhash) - sxhash) - result))))) + ;; FIXME: this isn't in fact as optimized as it could be; + ;; this does a memory load, whereas (because we know the + ;; layout of NIL) we could simply take the address of NIL + ;; (or the contents of NULL-TN) and mask off the appropriate + ;; bits, since SYMBOL-HASH of NIL is also NIL's CDR, which + ;; is NIL. -- CSR, 2004-07-14 + '(symbol-hash x) + ;; Cache the value of the symbol's sxhash in the symbol-hash + ;; slot. + '(let ((result (symbol-hash x))) + ;; 0 marks uninitialized slot. We can't use negative + ;; values for the uninitialized slots since NIL might be + ;; located so high in memory on some platforms that its + ;; SYMBOL-HASH (which contains NIL itself) is a negative + ;; fixnum. + (if (= 0 result) + (let ((sxhash (%sxhash-simple-string (symbol-name x)))) + ;; We could do a (logior sxhash #x10000000) to + ;; ensure that we never store a 0 in the + ;; slot. However, it's such an unlikely event + ;; (1/5e8?) that it makes more sense to optimize for + ;; the common case... + (%set-symbol-hash x sxhash) + sxhash) + result))))) diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp index 557141b..ab82c19 100644 --- a/src/code/symbol.lisp +++ b/src/code/symbol.lisp @@ -43,9 +43,9 @@ "Make SYMBOL unbound, removing any value it may currently have." (with-single-package-locked-error (:symbol symbol "unbinding the symbol ~A") (set symbol - (%primitive sb!c:make-other-immediate-type - 0 - sb!vm:unbound-marker-widetag)) + (%primitive sb!c:make-other-immediate-type + 0 + sb!vm:unbound-marker-widetag)) symbol)) ;;; Return the built-in hash value for SYMBOL. @@ -59,7 +59,7 @@ (defun (setf symbol-function) (new-value symbol) (declare (type symbol symbol) (type function new-value)) - (with-single-package-locked-error + (with-single-package-locked-error (:symbol symbol "setting the symbol-function of ~A") (setf (%coerce-name-to-fun symbol) new-value))) @@ -97,10 +97,10 @@ (do ((pl (symbol-plist symbol) (cddr pl))) ((atom pl) default) (cond ((atom (cdr pl)) - (error "~S has an odd number of items in its property list." - symbol)) - ((eq (car pl) indicator) - (return (cadr pl)))))) + (error "~S has an odd number of items in its property list." + symbol)) + ((eq (car pl) indicator) + (return (cadr pl)))))) (defun %put (symbol indicator value) #!+sb-doc @@ -109,14 +109,14 @@ (do ((pl (symbol-plist symbol) (cddr pl))) ((endp pl) (setf (symbol-plist symbol) - (list* indicator value (symbol-plist symbol))) + (list* indicator value (symbol-plist symbol))) value) (cond ((endp (cdr pl)) - (error "~S has an odd number of items in its property list." - symbol)) - ((eq (car pl) indicator) - (rplaca (cdr pl) value) - (return value))))) + (error "~S has an odd number of items in its property list." + symbol)) + ((eq (car pl) indicator) + (rplaca (cdr pl) value) + (return value))))) (defun remprop (symbol indicator) #!+sb-doc @@ -131,13 +131,13 @@ (prev nil pl)) ((atom pl) nil) (cond ((atom (cdr pl)) - (error "~S has an odd number of items in its property list." - symbol)) - ((eq (car pl) indicator) - (cond (prev (rplacd (cdr prev) (cddr pl))) - (t - (setf (symbol-plist symbol) (cddr pl)))) - (return pl))))) + (error "~S has an odd number of items in its property list." + symbol)) + ((eq (car pl) indicator) + (cond (prev (rplacd (cdr prev) (cddr pl))) + (t + (setf (symbol-plist symbol) (cddr pl)))) + (return pl))))) (defun getf (place indicator &optional (default ())) #!+sb-doc @@ -146,13 +146,13 @@ (do ((plist place (cddr plist))) ((null plist) default) (cond ((atom (cdr plist)) - (error 'simple-type-error - :format-control "malformed property list: ~S." - :format-arguments (list place) - :datum (cdr plist) - :expected-type 'cons)) - ((eq (car plist) indicator) - (return (cadr plist)))))) + (error 'simple-type-error + :format-control "malformed property list: ~S." + :format-arguments (list place) + :datum (cdr plist) + :expected-type 'cons)) + ((eq (car plist) indicator) + (return (cadr plist)))))) (defun %putf (place property new-value) (declare (type list place)) @@ -171,13 +171,13 @@ (do ((plist place (cddr plist))) ((null plist) (values nil nil nil)) (cond ((atom (cdr plist)) - (error 'simple-type-error - :format-control "malformed property list: ~S." - :format-arguments (list place) - :datum (cdr plist) - :expected-type 'cons)) - ((memq (car plist) indicator-list) - (return (values (car plist) (cadr plist) plist)))))) + (error 'simple-type-error + :format-control "malformed property list: ~S." + :format-arguments (list place) + :datum (cdr plist) + :expected-type 'cons)) + ((memq (car plist) indicator-list) + (return (values (car plist) (cadr plist) plist)))))) (defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol) #!+sb-doc @@ -189,9 +189,9 @@ (setq new-symbol (make-symbol (symbol-name symbol))) (when copy-props (%set-symbol-value new-symbol - (%primitive sb!c:fast-symbol-value symbol)) + (%primitive sb!c:fast-symbol-value symbol)) (setf (symbol-plist new-symbol) - (copy-list (symbol-plist symbol))) + (copy-list (symbol-plist symbol))) (when (fboundp symbol) (setf (symbol-function new-symbol) (symbol-function symbol)))) new-symbol) @@ -223,20 +223,20 @@ (let ((old *gensym-counter*)) (unless (numberp thing) (let ((new (etypecase old - (index (1+ old)) - (unsigned-byte (1+ old))))) - (declare (optimize (speed 3) (safety 0)(inhibit-warnings 3))) - (setq *gensym-counter* new))) + (index (1+ old)) + (unsigned-byte (1+ old))))) + (declare (optimize (speed 3) (safety 0)(inhibit-warnings 3))) + (setq *gensym-counter* new))) (multiple-value-bind (prefix int) - (etypecase thing - (simple-string (values thing old)) - (fixnum (values "G" thing)) - (string (values (coerce thing 'simple-string) old))) + (etypecase thing + (simple-string (values thing old)) + (fixnum (values "G" thing)) + (string (values (coerce thing 'simple-string) old))) (declare (simple-string prefix)) (make-symbol (concatenate 'simple-string prefix - (the simple-string - (quick-integer-to-string int))))))) + (the simple-string + (quick-integer-to-string int))))))) (defvar *gentemp-counter* 0) (declaim (type unsigned-byte *gentemp-counter*)) @@ -247,9 +247,9 @@ (declare (type string prefix)) (loop (let ((*print-base* 10) - (*print-radix* nil) - (*print-pretty* nil) - (new-pname (format nil "~A~D" prefix (incf *gentemp-counter*)))) + (*print-radix* nil) + (*print-pretty* nil) + (new-pname (format nil "~A~D" prefix (incf *gentemp-counter*)))) (multiple-value-bind (symbol existsp) (find-symbol new-pname package) - (declare (ignore symbol)) - (unless existsp (return (values (intern new-pname package)))))))) + (declare (ignore symbol)) + (unless existsp (return (values (intern new-pname package)))))))) diff --git a/src/code/sysmacs.lisp b/src/code/sysmacs.lisp index 66114f0..8110d1b 100644 --- a/src/code/sysmacs.lisp +++ b/src/code/sysmacs.lisp @@ -49,30 +49,30 @@ (let ((svar (gensym))) `(let ((,svar ,stream)) (cond ((null ,svar) *standard-input*) - ((eq ,svar t) *terminal-io*) - (t ,@(when check-type `((enforce-type ,svar ,check-type))) ; - #!+high-security - (unless (input-stream-p ,svar) - (error 'simple-type-error - :datum ,svar - :expected-type '(satisfies input-stream-p) - :format-control "~S isn't an input stream" - :format-arguments (list ,svar))) - ,svar))))) + ((eq ,svar t) *terminal-io*) + (t ,@(when check-type `((enforce-type ,svar ,check-type))) ; + #!+high-security + (unless (input-stream-p ,svar) + (error 'simple-type-error + :datum ,svar + :expected-type '(satisfies input-stream-p) + :format-control "~S isn't an input stream" + :format-arguments (list ,svar))) + ,svar))))) (defmacro out-synonym-of (stream &optional check-type) (let ((svar (gensym))) `(let ((,svar ,stream)) (cond ((null ,svar) *standard-output*) - ((eq ,svar t) *terminal-io*) - (t ,@(when check-type `((check-type ,svar ,check-type))) - #!+high-security - (unless (output-stream-p ,svar) - (error 'simple-type-error - :datum ,svar - :expected-type '(satisfies output-stream-p) - :format-control "~S isn't an output stream." - :format-arguments (list ,svar))) - ,svar))))) + ((eq ,svar t) *terminal-io*) + (t ,@(when check-type `((check-type ,svar ,check-type))) + #!+high-security + (unless (output-stream-p ,svar) + (error 'simple-type-error + :datum ,svar + :expected-type '(satisfies output-stream-p) + :format-control "~S isn't an output stream." + :format-arguments (list ,svar))) + ,svar))))) ;;; WITH-mumble-STREAM calls the function in the given SLOT of the ;;; STREAM with the ARGS for ANSI-STREAMs, or the FUNCTION with the @@ -80,22 +80,22 @@ (defmacro with-in-stream (stream (slot &rest args) &optional stream-dispatch) `(let ((stream (in-synonym-of ,stream))) ,(if stream-dispatch - `(if (ansi-stream-p stream) - (funcall (,slot stream) stream ,@args) - ,@(when stream-dispatch - `(,(destructuring-bind (function &rest args) stream-dispatch - `(,function stream ,@args))))) - `(funcall (,slot stream) stream ,@args)))) + `(if (ansi-stream-p stream) + (funcall (,slot stream) stream ,@args) + ,@(when stream-dispatch + `(,(destructuring-bind (function &rest args) stream-dispatch + `(,function stream ,@args))))) + `(funcall (,slot stream) stream ,@args)))) (defmacro with-out-stream (stream (slot &rest args) &optional stream-dispatch) `(let ((stream (out-synonym-of ,stream))) ,(if stream-dispatch - `(if (ansi-stream-p stream) - (funcall (,slot stream) stream ,@args) - ,@(when stream-dispatch - `(,(destructuring-bind (function &rest args) stream-dispatch - `(,function stream ,@args))))) - `(funcall (,slot stream) stream ,@args)))) + `(if (ansi-stream-p stream) + (funcall (,slot stream) stream ,@args) + ,@(when stream-dispatch + `(,(destructuring-bind (function &rest args) stream-dispatch + `(,function stream ,@args))))) + `(funcall (,slot stream) stream ,@args)))) ;;;; These are hacks to make the reader win. @@ -104,11 +104,11 @@ ;;; is assumed to be a ANSI-STREAM. (defmacro prepare-for-fast-read-char (stream &body forms) `(let* ((%frc-stream% ,stream) - (%frc-method% (ansi-stream-in %frc-stream%)) - (%frc-buffer% (ansi-stream-cin-buffer %frc-stream%)) - (%frc-index% (ansi-stream-in-index %frc-stream%))) + (%frc-method% (ansi-stream-in %frc-stream%)) + (%frc-buffer% (ansi-stream-cin-buffer %frc-stream%)) + (%frc-index% (ansi-stream-in-index %frc-stream%))) (declare (type index %frc-index%) - (type ansi-stream %frc-stream%)) + (type ansi-stream %frc-stream%)) ,@forms)) ;;; This macro must be called after one is done with FAST-READ-CHAR @@ -124,10 +124,10 @@ (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value)) ((= %frc-index% +ansi-stream-in-buffer-length+) (prog1 (fast-read-char-refill %frc-stream% ,eof-error-p ,eof-value) - (setq %frc-index% (ansi-stream-in-index %frc-stream%)))) + (setq %frc-index% (ansi-stream-in-index %frc-stream%)))) (t (prog1 (aref %frc-buffer% %frc-index%) - (incf %frc-index%))))) + (incf %frc-index%))))) ;;;; And these for the fasloader... @@ -143,11 +143,11 @@ ;;; for the FAST-READ-CHAR stuff) -- WHN 19990825 (defmacro prepare-for-fast-read-byte (stream &body forms) `(let* ((%frc-stream% ,stream) - (%frc-method% (ansi-stream-bin %frc-stream%)) - (%frc-buffer% (ansi-stream-in-buffer %frc-stream%)) - (%frc-index% (ansi-stream-in-index %frc-stream%))) + (%frc-method% (ansi-stream-bin %frc-stream%)) + (%frc-buffer% (ansi-stream-in-buffer %frc-stream%)) + (%frc-index% (ansi-stream-in-index %frc-stream%))) (declare (type index %frc-index%) - (type ansi-stream %frc-stream%)) + (type ansi-stream %frc-stream%)) ,@forms)) ;;; Similar to fast-read-char, but we use a different refill routine & don't @@ -162,9 +162,9 @@ (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value)) ((= %frc-index% +ansi-stream-in-buffer-length+) (prog1 (fast-read-byte-refill %frc-stream% ,eof-error-p ,eof-value) - (setq %frc-index% (ansi-stream-in-index %frc-stream%)))) + (setq %frc-index% (ansi-stream-in-index %frc-stream%)))) (t (prog1 (aref %frc-buffer% %frc-index%) - (incf %frc-index%)))))) + (incf %frc-index%)))))) (defmacro done-with-fast-read-byte () `(done-with-fast-read-char)) diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 01b46fb..822dd7d 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -42,7 +42,7 @@ (values name (guess-alien-name-from-lisp-name name))) (list (unless (proper-list-of-length-p name 2) - (error "badly formed alien name")) + (error "badly formed alien name")) (values (cadr name) (car name)))))) (defmacro define-alien-variable (name type &environment env) @@ -54,12 +54,12 @@ (multiple-value-bind (lisp-name alien-name) (pick-lisp-and-alien-names name) (with-auxiliary-alien-types env (let ((alien-type (parse-alien-type type env))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - ,@(when *new-auxiliary-types* - `((%def-auxiliary-alien-types ',*new-auxiliary-types*))) - (%define-alien-variable ',lisp-name - ',alien-name - ',alien-type)))))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@(when *new-auxiliary-types* + `((%def-auxiliary-alien-types ',*new-auxiliary-types*))) + (%define-alien-variable ',lisp-name + ',alien-name + ',alien-type)))))) (defmacro def-alien-variable (&rest rest) (deprecation-warning 'def-alien-variable 'define-alien-variable) @@ -72,21 +72,21 @@ (setf (info :variable :where-from lisp-name) :defined) (clear-info :variable :constant-value lisp-name) (setf (info :variable :alien-info lisp-name) - (make-heap-alien-info :type type - :sap-form `(foreign-symbol-sap ',alien-name t))))) + (make-heap-alien-info :type type + :sap-form `(foreign-symbol-sap ',alien-name t))))) (defmacro extern-alien (name type &environment env) #!+sb-doc "Access the alien variable named NAME, assuming it is of type TYPE. This is SETFable." (let* ((alien-name (etypecase name - (symbol (guess-alien-name-from-lisp-name name)) - (string name))) - (alien-type (parse-alien-type type env)) - (datap (not (alien-fun-type-p alien-type)))) + (symbol (guess-alien-name-from-lisp-name name)) + (string name))) + (alien-type (parse-alien-type type env)) + (datap (not (alien-fun-type-p alien-type)))) `(%heap-alien ',(make-heap-alien-info - :type alien-type - :sap-form `(foreign-symbol-sap ',alien-name ,datap))))) + :type alien-type + :sap-form `(foreign-symbol-sap ',alien-name ,datap))))) (defmacro with-alien (bindings &body body &environment env) #!+sb-doc @@ -107,69 +107,69 @@ (dolist (binding (reverse bindings)) (/show binding) (destructuring-bind - (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) - binding - (/show symbol type opt1 opt2) - (let* ((alien-type (parse-alien-type type env)) - (datap (not (alien-fun-type-p alien-type)))) - (/show alien-type) - (multiple-value-bind (allocation initial-value) - (if opt2p - (values opt1 opt2) - (case opt1 - (:extern - (values opt1 (guess-alien-name-from-lisp-name symbol))) - (:static - (values opt1 nil)) - (t - (values :local opt1)))) - (/show allocation initial-value) - (setf body - (ecase allocation - #+nil - (:static - (let ((sap - (make-symbol (concatenate 'string "SAP-FOR-" - (symbol-name symbol))))) - `((let ((,sap (load-time-value (%make-alien ...)))) - (declare (type system-area-pointer ,sap)) - (symbol-macrolet - ((,symbol (sap-alien ,sap ,type))) - ,@(when initial-value - `((setq ,symbol ,initial-value))) - ,@body))))) - (:extern - (/show0 ":EXTERN case") - (let ((info (make-heap-alien-info - :type alien-type - :sap-form `(foreign-symbol-sap ',initial-value - ,datap)))) - `((symbol-macrolet - ((,symbol (%heap-alien ',info))) - ,@body)))) - (:local - (/show0 ":LOCAL case") - (let ((var (gensym)) - (initval (if initial-value (gensym))) - (info (make-local-alien-info :type alien-type))) - (/show var initval info) - `((let ((,var (make-local-alien ',info)) - ,@(when initial-value - `((,initval ,initial-value)))) - (note-local-alien-type ',info ,var) - (multiple-value-prog1 - (symbol-macrolet - ((,symbol (local-alien ',info ,var))) - ,@(when initial-value - `((setq ,symbol ,initval))) - ,@body) - (dispose-local-alien ',info ,var)))))))))))) + (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) + binding + (/show symbol type opt1 opt2) + (let* ((alien-type (parse-alien-type type env)) + (datap (not (alien-fun-type-p alien-type)))) + (/show alien-type) + (multiple-value-bind (allocation initial-value) + (if opt2p + (values opt1 opt2) + (case opt1 + (:extern + (values opt1 (guess-alien-name-from-lisp-name symbol))) + (:static + (values opt1 nil)) + (t + (values :local opt1)))) + (/show allocation initial-value) + (setf body + (ecase allocation + #+nil + (:static + (let ((sap + (make-symbol (concatenate 'string "SAP-FOR-" + (symbol-name symbol))))) + `((let ((,sap (load-time-value (%make-alien ...)))) + (declare (type system-area-pointer ,sap)) + (symbol-macrolet + ((,symbol (sap-alien ,sap ,type))) + ,@(when initial-value + `((setq ,symbol ,initial-value))) + ,@body))))) + (:extern + (/show0 ":EXTERN case") + (let ((info (make-heap-alien-info + :type alien-type + :sap-form `(foreign-symbol-sap ',initial-value + ,datap)))) + `((symbol-macrolet + ((,symbol (%heap-alien ',info))) + ,@body)))) + (:local + (/show0 ":LOCAL case") + (let ((var (gensym)) + (initval (if initial-value (gensym))) + (info (make-local-alien-info :type alien-type))) + (/show var initval info) + `((let ((,var (make-local-alien ',info)) + ,@(when initial-value + `((,initval ,initial-value)))) + (note-local-alien-type ',info ,var) + (multiple-value-prog1 + (symbol-macrolet + ((,symbol (local-alien ',info ,var))) + ,@(when initial-value + `((setq ,symbol ,initval))) + ,@body) + (dispose-local-alien ',info ,var)))))))))))) (/show "revised" body) (verify-local-auxiliaries-okay) (/show0 "back from VERIFY-LOCAL-AUXILIARIES-OK, returning") `(symbol-macrolet ((&auxiliary-type-definitions& - ,(append *new-auxiliary-types* - (auxiliary-type-definitions env)))) + ,(append *new-auxiliary-types* + (auxiliary-type-definitions env)))) ,@body))) ;;;; runtime C values that don't correspond directly to Lisp types @@ -180,10 +180,10 @@ (def!method print-object ((value alien-value) stream) (print-unreadable-object (value stream) (format stream - "~S ~S #X~8,'0X ~S ~S" - 'alien-value - :sap (sap-int (alien-value-sap value)) - :type (unparse-alien-type (alien-value-type value))))) + "~S ~S #X~8,'0X ~S ~S" + 'alien-value + :sap (sap-int (alien-value-sap value)) + :type (unparse-alien-type (alien-value-type value))))) #!-sb-fluid (declaim (inline null-alien)) (defun null-alien (x) @@ -197,12 +197,12 @@ evaluated.) TYPE must be pointer-like." (let ((alien-type (parse-alien-type type env))) (if (eq (compute-alien-rep-type alien-type) 'system-area-pointer) - `(%sap-alien ,sap ',alien-type) - (error "cannot make an alien of type ~S out of a SAP" type)))) + `(%sap-alien ,sap ',alien-type) + (error "cannot make an alien of type ~S out of a SAP" type)))) (defun %sap-alien (sap type) (declare (type system-area-pointer sap) - (type alien-type type)) + (type alien-type type)) (make-alien-value :sap sap :type type)) (defun alien-sap (alien) @@ -222,38 +222,38 @@ memory is allocated using ``malloc'', so it can be passed to foreign functions which use ``free''." (let ((alien-type (if (alien-type-p type) - type - (parse-alien-type type env)))) + type + (parse-alien-type type env)))) (multiple-value-bind (size-expr element-type) - (if (alien-array-type-p alien-type) - (let ((dims (alien-array-type-dimensions alien-type))) - (cond - (size - (unless dims - (error - "cannot override the size of zero-dimensional arrays")) - (when (constantp size) - (setf alien-type (copy-alien-array-type alien-type)) - (setf (alien-array-type-dimensions alien-type) - (cons (eval size) (cdr dims))))) - (dims - (setf size (car dims))) - (t - (setf size 1))) - (values `(* ,size ,@(cdr dims)) - (alien-array-type-element-type alien-type))) - (values (or size 1) alien-type)) + (if (alien-array-type-p alien-type) + (let ((dims (alien-array-type-dimensions alien-type))) + (cond + (size + (unless dims + (error + "cannot override the size of zero-dimensional arrays")) + (when (constantp size) + (setf alien-type (copy-alien-array-type alien-type)) + (setf (alien-array-type-dimensions alien-type) + (cons (eval size) (cdr dims))))) + (dims + (setf size (car dims))) + (t + (setf size 1))) + (values `(* ,size ,@(cdr dims)) + (alien-array-type-element-type alien-type))) + (values (or size 1) alien-type)) (let ((bits (alien-type-bits element-type)) - (alignment (alien-type-alignment element-type))) - (unless bits - (error "The size of ~S is unknown." - (unparse-alien-type element-type))) - (unless alignment - (error "The alignment of ~S is unknown." - (unparse-alien-type element-type))) - `(%sap-alien (%make-alien (* ,(align-offset bits alignment) - ,size-expr)) - ',(make-alien-pointer-type :to alien-type)))))) + (alignment (alien-type-alignment element-type))) + (unless bits + (error "The size of ~S is unknown." + (unparse-alien-type element-type))) + (unless alignment + (error "The alignment of ~S is unknown." + (unparse-alien-type element-type))) + `(%sap-alien (%make-alien (* ,(align-offset bits alignment) + ,size-expr)) + ',(make-alien-pointer-type :to alien-type)))))) ;;; Allocate a block of memory at least BITS bits long and return a ;;; system area pointer to it. @@ -261,8 +261,8 @@ (defun %make-alien (bits) (declare (type index bits)) (alien-funcall (extern-alien "malloc" - (function system-area-pointer unsigned)) - (ash (the index (+ bits 7)) -3))) + (function system-area-pointer unsigned)) + (ash (the index (+ bits 7)) -3))) #!-sb-fluid (declaim (inline free-alien)) (defun free-alien (alien) @@ -270,7 +270,7 @@ "Dispose of the storage pointed to by ALIEN. ALIEN must have been allocated by MAKE-ALIEN or malloc(3)." (alien-funcall (extern-alien "free" (function (values) system-area-pointer)) - (alien-sap alien)) + (alien-sap alien)) nil) ;;;; the SLOT operator @@ -278,9 +278,9 @@ ;;; Find the field named SLOT, or die trying. (defun slot-or-lose (type slot) (declare (type alien-record-type type) - (type symbol slot)) + (type symbol slot)) (or (find slot (alien-record-type-fields type) - :key #'alien-record-field-name) + :key #'alien-record-field-name) (error "There is no slot named ~S in ~S." slot type))) ;;; Extract the value from the named slot from the record ALIEN. If @@ -289,51 +289,51 @@ #!+sb-doc "Extract SLOT from the Alien STRUCT or UNION ALIEN. May be set with SETF." (declare (type alien-value alien) - (type symbol slot) - (optimize (inhibit-warnings 3))) + (type symbol slot) + (optimize (inhibit-warnings 3))) (let ((type (alien-value-type alien))) (etypecase type (alien-pointer-type (slot (deref alien) slot)) (alien-record-type (let ((field (slot-or-lose type slot))) - (extract-alien-value (alien-value-sap alien) - (alien-record-field-offset field) - (alien-record-field-type field))))))) + (extract-alien-value (alien-value-sap alien) + (alien-record-field-offset field) + (alien-record-field-type field))))))) ;;; Deposit the value in the specified slot of the record ALIEN. If ;;; the ALIEN is really a pointer, DEREF it first. The compiler uses ;;; this when it can't figure out anything better. (defun %set-slot (alien slot value) (declare (type alien-value alien) - (type symbol slot) - (optimize (inhibit-warnings 3))) + (type symbol slot) + (optimize (inhibit-warnings 3))) (let ((type (alien-value-type alien))) (etypecase type (alien-pointer-type (%set-slot (deref alien) slot value)) (alien-record-type (let ((field (slot-or-lose type slot))) - (deposit-alien-value (alien-value-sap alien) - (alien-record-field-offset field) - (alien-record-field-type field) - value)))))) + (deposit-alien-value (alien-value-sap alien) + (alien-record-field-offset field) + (alien-record-field-type field) + value)))))) ;;; Compute the address of the specified slot and return a pointer to it. (defun %slot-addr (alien slot) (declare (type alien-value alien) - (type symbol slot) - (optimize (inhibit-warnings 3))) + (type symbol slot) + (optimize (inhibit-warnings 3))) (let ((type (alien-value-type alien))) (etypecase type (alien-pointer-type (%slot-addr (deref alien) slot)) (alien-record-type (let* ((field (slot-or-lose type slot)) - (offset (alien-record-field-offset field)) - (field-type (alien-record-field-type field))) - (%sap-alien (sap+ (alien-sap alien) (/ offset sb!vm:n-byte-bits)) - (make-alien-pointer-type :to field-type))))))) + (offset (alien-record-field-offset field)) + (field-type (alien-record-field-type field))) + (%sap-alien (sap+ (alien-sap alien) (/ offset sb!vm:n-byte-bits)) + (make-alien-pointer-type :to field-type))))))) ;;;; the DEREF operator @@ -342,40 +342,40 @@ ;;; of the referred-to alien. (defun deref-guts (alien indices) (declare (type alien-value alien) - (type list indices) - (values alien-type integer)) + (type list indices) + (values alien-type integer)) (let ((type (alien-value-type alien))) (etypecase type (alien-pointer-type (when (cdr indices) - (error "too many indices when DEREF'ing ~S: ~W" - type - (length indices))) + (error "too many indices when DEREF'ing ~S: ~W" + type + (length indices))) (let ((element-type (alien-pointer-type-to type))) - (values element-type - (if indices - (* (align-offset (alien-type-bits element-type) - (alien-type-alignment element-type)) - (car indices)) - 0)))) + (values element-type + (if indices + (* (align-offset (alien-type-bits element-type) + (alien-type-alignment element-type)) + (car indices)) + 0)))) (alien-array-type (unless (= (length indices) (length (alien-array-type-dimensions type))) - (error "incorrect number of indices when DEREF'ing ~S: ~W" - type (length indices))) + (error "incorrect number of indices when DEREF'ing ~S: ~W" + type (length indices))) (labels ((frob (dims indices offset) - (if (null dims) - offset - (frob (cdr dims) (cdr indices) - (+ (if (zerop offset) - 0 - (* offset (car dims))) - (car indices)))))) - (let ((element-type (alien-array-type-element-type type))) - (values element-type - (* (align-offset (alien-type-bits element-type) - (alien-type-alignment element-type)) - (frob (alien-array-type-dimensions type) - indices 0))))))))) + (if (null dims) + offset + (frob (cdr dims) (cdr indices) + (+ (if (zerop offset) + 0 + (* offset (car dims))) + (car indices)))))) + (let ((element-type (alien-array-type-element-type type))) + (values element-type + (* (align-offset (alien-type-bits element-type) + (alien-type-alignment element-type)) + (frob (alien-array-type-dimensions type) + indices 0))))))))) ;;; Dereference the alien and return the results. (defun deref (alien &rest indices) @@ -384,65 +384,65 @@ as the indices of the array element to access. If a pointer, one index can optionally be specified, giving the equivalent of C pointer arithmetic." (declare (type alien-value alien) - (type list indices) - (optimize (inhibit-warnings 3))) + (type list indices) + (optimize (inhibit-warnings 3))) (multiple-value-bind (target-type offset) (deref-guts alien indices) (extract-alien-value (alien-value-sap alien) - offset - target-type))) + offset + target-type))) (defun %set-deref (alien value &rest indices) (declare (type alien-value alien) - (type list indices) - (optimize (inhibit-warnings 3))) + (type list indices) + (optimize (inhibit-warnings 3))) (multiple-value-bind (target-type offset) (deref-guts alien indices) (deposit-alien-value (alien-value-sap alien) - offset - target-type - value))) + offset + target-type + value))) (defun %deref-addr (alien &rest indices) (declare (type alien-value alien) - (type list indices) - (optimize (inhibit-warnings 3))) + (type list indices) + (optimize (inhibit-warnings 3))) (multiple-value-bind (target-type offset) (deref-guts alien indices) (%sap-alien (sap+ (alien-value-sap alien) (/ offset sb!vm:n-byte-bits)) - (make-alien-pointer-type :to target-type)))) + (make-alien-pointer-type :to target-type)))) ;;;; accessing heap alien variables (defun %heap-alien (info) (declare (type heap-alien-info info) - (optimize (inhibit-warnings 3))) + (optimize (inhibit-warnings 3))) (extract-alien-value (eval (heap-alien-info-sap-form info)) - 0 - (heap-alien-info-type info))) + 0 + (heap-alien-info-type info))) (defun %set-heap-alien (info value) (declare (type heap-alien-info info) - (optimize (inhibit-warnings 3))) + (optimize (inhibit-warnings 3))) (deposit-alien-value (eval (heap-alien-info-sap-form info)) - 0 - (heap-alien-info-type info) - value)) + 0 + (heap-alien-info-type info) + value)) (defun %heap-alien-addr (info) (declare (type heap-alien-info info) - (optimize (inhibit-warnings 3))) + (optimize (inhibit-warnings 3))) (%sap-alien (eval (heap-alien-info-sap-form info)) - (make-alien-pointer-type :to (heap-alien-info-type info)))) + (make-alien-pointer-type :to (heap-alien-info-type info)))) ;;;; accessing local aliens (defun make-local-alien (info) (let* ((alien (eval `(make-alien ,(local-alien-info-type info)))) - (alien-sap (alien-sap alien))) + (alien-sap (alien-sap alien))) (finalize alien (lambda () (alien-funcall - (extern-alien "free" (function (values) system-area-pointer)) - alien-sap))) + (extern-alien "free" (function (values) system-area-pointer)) + alien-sap))) alien)) (defun note-local-alien-type (info alien) @@ -459,19 +459,19 @@ (define-setf-expander local-alien (&whole whole info alien) (let ((value (gensym)) - (info (if (and (consp info) - (eq (car info) 'quote)) - (second info) - (error "Something is wrong; local-alien-info not found: ~S" - whole)))) + (info (if (and (consp info) + (eq (car info) 'quote)) + (second info) + (error "Something is wrong; local-alien-info not found: ~S" + whole)))) (values nil - nil - (list value) - `(if (%local-alien-forced-to-memory-p ',info) - (%set-local-alien ',info ,alien ,value) - (setf ,alien - (deport ,value ',(local-alien-info-type info)))) - whole))) + nil + (list value) + `(if (%local-alien-forced-to-memory-p ',info) + (%set-local-alien ',info ,alien ,value) + (setf ,alien + (deport ,value ',(local-alien-info-type info)))) + whole))) (defun %local-alien-forced-to-memory-p (info) (local-alien-info-force-to-memory-p info)) @@ -497,18 +497,18 @@ (defun %cast (alien target-type) (declare (type alien-value alien) - (type alien-type target-type) - (optimize (safety 2)) - (optimize (inhibit-warnings 3))) + (type alien-type target-type) + (optimize (safety 2)) + (optimize (inhibit-warnings 3))) (if (or (alien-pointer-type-p target-type) - (alien-array-type-p target-type) - (alien-fun-type-p target-type)) + (alien-array-type-p target-type) + (alien-fun-type-p target-type)) (let ((alien-type (alien-value-type alien))) - (if (or (alien-pointer-type-p alien-type) - (alien-array-type-p alien-type) - (alien-fun-type-p alien-type)) - (naturalize (alien-value-sap alien) target-type) - (error "~S cannot be casted." alien))) + (if (or (alien-pointer-type-p alien-type) + (alien-array-type-p alien-type) + (alien-fun-type-p alien-type)) + (naturalize (alien-value-sap alien) target-type) + (error "~S cannot be casted." alien))) (error "cannot cast to alien type ~S" (unparse-alien-type target-type)))) ;;;; the ALIEN-SIZE macro @@ -518,41 +518,41 @@ "Return the size of the alien type TYPE. UNITS specifies the units to use and can be either :BITS, :BYTES, or :WORDS." (let* ((alien-type (parse-alien-type type env)) - (bits (alien-type-bits alien-type))) + (bits (alien-type-bits alien-type))) (if bits - (values (ceiling bits - (ecase units - (:bits 1) - (:bytes sb!vm:n-byte-bits) - (:words sb!vm:n-word-bits)))) - (error "unknown size for alien type ~S" - (unparse-alien-type alien-type))))) + (values (ceiling bits + (ecase units + (:bits 1) + (:bytes sb!vm:n-byte-bits) + (:words sb!vm:n-word-bits)))) + (error "unknown size for alien type ~S" + (unparse-alien-type alien-type))))) ;;;; NATURALIZE, DEPORT, EXTRACT-ALIEN-VALUE, DEPOSIT-ALIEN-VALUE (defun naturalize (alien type) (declare (type alien-type type)) (funcall (coerce (compute-naturalize-lambda type) 'function) - alien type)) + alien type)) (defun deport (value type) (declare (type alien-type type)) (funcall (coerce (compute-deport-lambda type) 'function) - value type)) + value type)) (defun extract-alien-value (sap offset type) (declare (type system-area-pointer sap) - (type unsigned-byte offset) - (type alien-type type)) + (type unsigned-byte offset) + (type alien-type type)) (funcall (coerce (compute-extract-lambda type) 'function) - sap offset type)) + sap offset type)) (defun deposit-alien-value (sap offset type value) (declare (type system-area-pointer sap) - (type unsigned-byte offset) - (type alien-type type)) + (type unsigned-byte offset) + (type alien-type type)) (funcall (coerce (compute-deposit-lambda type) 'function) - sap offset type value)) + sap offset type value)) ;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE @@ -567,29 +567,29 @@ (apply #'alien-funcall (deref alien) args)) (alien-fun-type (unless (= (length (alien-fun-type-arg-types type)) - (length args)) - (error "wrong number of arguments for ~S~%expected ~W, got ~W" - type - (length (alien-fun-type-arg-types type)) - (length args))) + (length args)) + (error "wrong number of arguments for ~S~%expected ~W, got ~W" + type + (length (alien-fun-type-arg-types type)) + (length args))) (let ((stub (alien-fun-type-stub type))) - (unless stub - (setf stub - (let ((fun (gensym)) - (parms (make-gensym-list (length args)))) - (compile nil - `(lambda (,fun ,@parms) + (unless stub + (setf stub + (let ((fun (gensym)) + (parms (make-gensym-list (length args)))) + (compile nil + `(lambda (,fun ,@parms) (declare (optimize (sb!c::insert-step-conditions 0))) - (declare (type (alien ,type) ,fun)) - (alien-funcall ,fun ,@parms))))) - (setf (alien-fun-type-stub type) stub)) - (apply stub alien args))) + (declare (type (alien ,type) ,fun)) + (alien-funcall ,fun ,@parms))))) + (setf (alien-fun-type-stub type) stub)) + (apply stub alien args))) (t (error "~S is not an alien function." alien))))) (defmacro define-alien-routine (name result-type - &rest args - &environment lexenv) + &rest args + &environment lexenv) #!+sb-doc "DEFINE-ALIEN-ROUTINE Name Result-Type {(Arg-Name Arg-Type [Style])}* @@ -599,7 +599,7 @@ NAME may be either a string, a symbol, or a list of the form (string symbol). RETURN-TYPE is the alien type for the function return value. VOID may be - used to specify a function with no result. + used to specify a function with no result. The remaining forms specify individual arguments that are passed to the routine. ARG-NAME is a symbol that names the argument, primarily for @@ -641,18 +641,18 @@ ;; FIXME: Check for VALUES. (list `(alien ,result-type))))) (arg-types) (alien-vars) - (alien-args) (results)) + (alien-args) (results)) (dolist (arg args) - (if (stringp arg) - (docs arg) - (destructuring-bind (name type &optional (style :in)) arg - (unless (member style '(:in :copy :out :in-out)) - (error "bogus argument style ~S in ~S" style arg)) - (when (and (member style '(:out :in-out)) - (typep (parse-alien-type type lexenv) - 'alien-pointer-type)) - (error "can't use :OUT or :IN-OUT on pointer-like type:~% ~S" - type)) + (if (stringp arg) + (docs arg) + (destructuring-bind (name type &optional (style :in)) arg + (unless (member style '(:in :copy :out :in-out)) + (error "bogus argument style ~S in ~S" style arg)) + (when (and (member style '(:out :in-out)) + (typep (parse-alien-type type lexenv) + 'alien-pointer-type)) + (error "can't use :OUT or :IN-OUT on pointer-like type:~% ~S" + type)) (let (arg-type) (cond ((eq style :in) (setq arg-type type) @@ -672,24 +672,24 @@ ;; for we also accept SAPs where ;; pointers are required. ))) - (when (or (eq style :out) (eq style :in-out)) - (results name) + (when (or (eq style :out) (eq style :in-out)) + (results name) (lisp-result-types `(alien ,type)))))) `(progn - ;; The theory behind this automatic DECLAIM is that (1) if - ;; you're calling C, static typing is what you're doing - ;; anyway, and (2) such a declamation can be (especially for - ;; alien values) both messy to do by hand and very important - ;; for performance of later code which uses the return value. - (declaim (ftype (function ,(lisp-arg-types) + ;; The theory behind this automatic DECLAIM is that (1) if + ;; you're calling C, static typing is what you're doing + ;; anyway, and (2) such a declamation can be (especially for + ;; alien values) both messy to do by hand and very important + ;; for performance of later code which uses the return value. + (declaim (ftype (function ,(lisp-arg-types) (values ,@(lisp-result-types) &optional)) ,lisp-name)) - (defun ,lisp-name ,(lisp-args) - ,@(docs) - (with-alien - ((,lisp-name (function ,result-type ,@(arg-types)) - :extern ,alien-name) - ,@(alien-vars)) + (defun ,lisp-name ,(lisp-args) + ,@(docs) + (with-alien + ((,lisp-name (function ,result-type ,@(arg-types)) + :extern ,alien-name) + ,@(alien-vars)) #-nil (values (alien-funcall ,lisp-name ,@(alien-args)) ,@(results)) @@ -701,13 +701,13 @@ ;; disagrees with the computation of the return type ;; and with all usages of this macro. -- APD, ;; 2002-03-02 - (let ((temps (make-gensym-list - (length - (alien-values-type-values result-type))))) - `(multiple-value-bind ,temps - (alien-funcall ,lisp-name ,@(alien-args)) - (values ,@temps ,@(results)))) - (values (alien-funcall ,lisp-name ,@(alien-args)) + (let ((temps (make-gensym-list + (length + (alien-values-type-values result-type))))) + `(multiple-value-bind ,temps + (alien-funcall ,lisp-name ,@(alien-args)) + (values ,@temps ,@(results)))) + (values (alien-funcall ,lisp-name ,@(alien-args)) ,@(results))))))))) (defmacro def-alien-routine (&rest rest) @@ -719,9 +719,9 @@ "Return T iff OBJECT is an alien of type TYPE." (let ((lisp-rep-type (compute-lisp-rep-type type))) (if lisp-rep-type - (typep object lisp-rep-type) - (and (alien-value-p object) - (alien-subtype-p (alien-value-type object) type))))) + (typep object lisp-rep-type) + (and (alien-value-p object) + (alien-subtype-p (alien-value-type object) type))))) ;;;; ALIEN CALLBACKS ;;;; @@ -760,27 +760,27 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") (defun %alien-callback-sap (specifier result-type argument-types function wrapper) (let ((key (cons specifier function))) (or (gethash key *alien-callbacks*) - (setf (gethash key *alien-callbacks*) - (let* ((index (fill-pointer *alien-callback-trampolines*)) - ;; Aside from the INDEX this is known at - ;; compile-time, which could be utilized by - ;; having the two-stage assembler tramp & - ;; wrapper mentioned in [1] above: only the - ;; per-function tramp would need assembler at - ;; runtime. Possibly we could even pregenerate - ;; the code and just patch the index in later. - (assembler-wrapper (alien-callback-assembler-wrapper - index result-type argument-types))) - (vector-push-extend - (alien-callback-lisp-trampoline wrapper function) - *alien-callback-trampolines*) - (let ((sap (vector-sap assembler-wrapper))) - (push (cons sap (make-callback-info :specifier specifier - :function function - :wrapper wrapper - :index index)) - *alien-callback-info*) - sap)))))) + (setf (gethash key *alien-callbacks*) + (let* ((index (fill-pointer *alien-callback-trampolines*)) + ;; Aside from the INDEX this is known at + ;; compile-time, which could be utilized by + ;; having the two-stage assembler tramp & + ;; wrapper mentioned in [1] above: only the + ;; per-function tramp would need assembler at + ;; runtime. Possibly we could even pregenerate + ;; the code and just patch the index in later. + (assembler-wrapper (alien-callback-assembler-wrapper + index result-type argument-types))) + (vector-push-extend + (alien-callback-lisp-trampoline wrapper function) + *alien-callback-trampolines*) + (let ((sap (vector-sap assembler-wrapper))) + (push (cons sap (make-callback-info :specifier specifier + :function function + :wrapper wrapper + :index index)) + *alien-callback-info*) + sap)))))) (defun alien-callback-lisp-trampoline (wrapper function) (declare (function wrapper) (optimize speed)) @@ -789,37 +789,37 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") (defun alien-callback-lisp-wrapper-lambda (specifier result-type argument-types env) (let* ((arguments (make-gensym-list (length argument-types))) - (argument-names arguments) - (argument-specs (cddr specifier))) + (argument-names arguments) + (argument-specs (cddr specifier))) `(lambda (args-pointer result-pointer function) - (let ((args-sap (int-sap - (sb!kernel:get-lisp-obj-address args-pointer))) - (res-sap (int-sap - (sb!kernel:get-lisp-obj-address result-pointer)))) - (with-alien - ,(loop - for spec in argument-specs - for offset = 0 ; FIXME: Should this not be AND OFFSET ...? - then (+ offset (alien-callback-argument-bytes spec env)) - collect `(,(pop argument-names) ,spec - :local ,(alien-callback-accessor-form - spec 'args-sap offset))) - ,(flet ((store (spec) - (if spec - `(setf (deref (sap-alien res-sap (* ,spec))) - (funcall function ,@arguments)) - `(funcall function ,@arguments)))) - (cond ((alien-void-type-p result-type) - (store nil)) - ((alien-integer-type-p result-type) - (if (alien-integer-type-signed result-type) - (store `(signed - ,(alien-type-word-aligned-bits result-type))) - (store - `(unsigned - ,(alien-type-word-aligned-bits result-type))))) - (t - (store (unparse-alien-type result-type))))))) + (let ((args-sap (int-sap + (sb!kernel:get-lisp-obj-address args-pointer))) + (res-sap (int-sap + (sb!kernel:get-lisp-obj-address result-pointer)))) + (with-alien + ,(loop + for spec in argument-specs + for offset = 0 ; FIXME: Should this not be AND OFFSET ...? + then (+ offset (alien-callback-argument-bytes spec env)) + collect `(,(pop argument-names) ,spec + :local ,(alien-callback-accessor-form + spec 'args-sap offset))) + ,(flet ((store (spec) + (if spec + `(setf (deref (sap-alien res-sap (* ,spec))) + (funcall function ,@arguments)) + `(funcall function ,@arguments)))) + (cond ((alien-void-type-p result-type) + (store nil)) + ((alien-integer-type-p result-type) + (if (alien-integer-type-signed result-type) + (store `(signed + ,(alien-type-word-aligned-bits result-type))) + (store + `(unsigned + ,(alien-type-word-aligned-bits result-type))))) + (t + (store (unparse-alien-type result-type))))))) (values)))) (defun invalid-alien-callback (&rest arguments) @@ -837,10 +837,10 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") (destructuring-bind (function result-type &rest argument-types) specifier (aver (eq 'function function)) - (values (parse-alien-type result-type env) - (mapcar (lambda (spec) - (parse-alien-type spec env)) - argument-types)))) + (values (parse-alien-type result-type env) + (mapcar (lambda (spec) + (parse-alien-type spec env)) + argument-types)))) (defun alien-void-type-p (type) (and (alien-values-type-p type) (not (alien-values-type-values type)))) @@ -851,15 +851,15 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") (defun alien-callback-argument-bytes (spec env) (let ((type (parse-alien-type spec env))) (if (or (alien-integer-type-p type) - (alien-float-type-p type) - (alien-pointer-type-p type)) - (ceiling (alien-type-word-aligned-bits type) sb!vm:n-byte-bits) - (error "Unsupported callback argument type: ~A" type)))) + (alien-float-type-p type) + (alien-pointer-type-p type)) + (ceiling (alien-type-word-aligned-bits type) sb!vm:n-byte-bits) + (error "Unsupported callback argument type: ~A" type)))) (defun enter-alien-callback (index return arguments) (funcall (aref *alien-callback-trampolines* index) - return - arguments)) + return + arguments)) ;;;; interface (not public, yet) for alien callbacks @@ -871,13 +871,13 @@ one." ;; Pull out as much work as is convenient to macro-expansion time, specifically ;; everything that can be done given just the SPECIFIER and ENV. (multiple-value-bind (result-type argument-types) (parse-alien-ftype specifier env) - `(%sap-alien + `(%sap-alien (%alien-callback-sap ',specifier ',result-type ',argument-types - ,function - (or (gethash ',specifier *alien-callback-wrappers*) - (setf (gethash ',specifier *alien-callback-wrappers*) - ,(alien-callback-lisp-wrapper-lambda - specifier result-type argument-types env)))) + ,function + (or (gethash ',specifier *alien-callback-wrappers*) + (setf (gethash ',specifier *alien-callback-wrappers*) + ,(alien-callback-lisp-wrapper-lambda + specifier result-type argument-types env)))) ',(parse-alien-type specifier env)))) (defun alien-callback-p (alien) @@ -896,7 +896,7 @@ and a secondary return value of true if the callback is still valid." (defun (setf alien-callback-function) (function alien) "Changes the lisp function designated by the callback." (let ((info (alien-callback-info alien))) - (unless info + (unless info (error "Not an alien callback: ~S" alien)) ;; sap cache (let ((key (callback-info-key info))) @@ -904,7 +904,7 @@ and a secondary return value of true if the callback is still valid." (setf (gethash key *alien-callbacks*) (alien-sap alien))) ;; trampoline (setf (aref *alien-callback-trampolines* (callback-info-index info)) - (alien-callback-lisp-trampoline (callback-info-wrapper info) function)) + (alien-callback-lisp-trampoline (callback-info-wrapper info) function)) ;; metadata (setf (callback-info-function info) function) function)) @@ -919,7 +919,7 @@ callback signal an error." (remhash (callback-info-key info) *alien-callbacks*) ;; trampoline (setf (aref *alien-callback-trampolines* (callback-info-index info)) - #'invalid-alien-callback) + #'invalid-alien-callback) ;; metadata (setf (callback-info-function info) nil) t))) diff --git a/src/code/target-allocate.lisp b/src/code/target-allocate.lisp index 25ac6ff..2eec4aa 100644 --- a/src/code/target-allocate.lisp +++ b/src/code/target-allocate.lisp @@ -12,21 +12,21 @@ (in-package "SB!KERNEL") (sb!alien:define-alien-routine ("os_allocate" allocate-system-memory) - system-area-pointer + system-area-pointer (bytes sb!alien:unsigned-long)) (sb!alien:define-alien-routine ("os_allocate_at" allocate-system-memory-at) - system-area-pointer + system-area-pointer (address system-area-pointer) (bytes sb!alien:unsigned-long)) (sb!alien:define-alien-routine ("os_reallocate" reallocate-system-memory) - system-area-pointer + system-area-pointer (old system-area-pointer) (old-size sb!alien:unsigned-long) (new-size sb!alien:unsigned-long)) (sb!alien:define-alien-routine ("os_deallocate" deallocate-system-memory) - sb!alien:void + sb!alien:void (addr system-area-pointer) (bytes sb!alien:unsigned-long)) diff --git a/src/code/target-c-call.lisp b/src/code/target-c-call.lisp index 4730dbd..2d21d6d 100644 --- a/src/code/target-c-call.lisp +++ b/src/code/target-c-call.lisp @@ -47,18 +47,18 @@ until (zerop (sap-ref-8 sap offset)) finally (return offset)))) (let ((result (make-string length :element-type 'base-char))) - (sb!kernel:copy-ub8-from-system-area sap 0 result 0 length) - result)))) + (sb!kernel:copy-ub8-from-system-area sap 0 result 0 length) + result)))) (defun %naturalize-utf8-string (sap) (declare (type system-area-pointer sap)) (locally (declare (optimize (speed 3) (safety 0))) (let ((byte-length (do* ((offset 0 (1+ offset)) - (byte #1=(sap-ref-8 sap offset) #1#)) - ((zerop byte) offset)))) + (byte #1=(sap-ref-8 sap offset) #1#)) + ((zerop byte) offset)))) (handler-bind ((sb!impl::octet-decoding-error #'sb!impl::use-unicode-replacement-char)) - (sb!impl::utf8->string-sap-ref-8 sap 0 byte-length))))) + (sb!impl::utf8->string-sap-ref-8 sap 0 byte-length))))) (defun %deport-utf8-string (string) (declare (type simple-string string)) diff --git a/src/code/target-char.lisp b/src/code/target-char.lisp index a846dad..68b02d0 100644 --- a/src/code/target-char.lisp +++ b/src/code/target-char.lisp @@ -25,8 +25,8 @@ ;;; We compile some trivial character operations via inline expansion. #!-sb-fluid (declaim (inline standard-char-p graphic-char-p alpha-char-p - upper-case-p lower-case-p both-case-p alphanumericp - char-int)) + upper-case-p lower-case-p both-case-p alphanumericp + char-int)) (declaim (maybe-inline digit-char-p digit-weight)) (deftype char-code () @@ -50,7 +50,7 @@ :element-type '(unsigned-byte 8)))) (read-sequence array stream) `(defun !character-database-cold-init () - (setq *character-database* ',array)))))) + (setq *character-database* ',array)))))) (frob)) #+sb-xc-host (!character-database-cold-init) @@ -58,83 +58,83 @@ ;;; with long names. The first name in this list for a given character ;;; is used on typeout and is the preferred form for input. (macrolet ((frob (char-names-list) - (collect ((results)) - (dolist (code char-names-list) - (destructuring-bind (ccode names) code - (dolist (name names) - (results (cons name ccode))))) - `(defparameter *char-name-alist* + (collect ((results)) + (dolist (code char-names-list) + (destructuring-bind (ccode names) code + (dolist (name names) + (results (cons name ccode))))) + `(defparameter *char-name-alist* (mapcar (lambda (x) (cons (car x) (code-char (cdr x)))) ',(results)))))) ;; Note: The *** markers here indicate character names which are ;; required by the ANSI specification of #'CHAR-NAME. For the others, ;; we prefer the ASCII standard name. (frob ((#x00 ("Nul" "Null" "^@")) - (#x01 ("Soh" "^a")) - (#x02 ("Stx" "^b")) - (#x03 ("Etx" "^c")) - (#x04 ("Eot" "^d")) - (#x05 ("Enq" "^e")) - (#x06 ("Ack" "^f")) - (#x07 ("Bel" "Bell" "^g")) - (#x08 ("Backspace" "^h" "Bs")) ; *** See Note above. - (#x09 ("Tab" "^i" "Ht")) ; *** See Note above. - (#x0A ("Newline" "Linefeed" "^j" "Lf" "Nl" )) ; *** See Note above. - (#x0B ("Vt" "^k")) - (#x0C ("Page" "^l" "Form" "Formfeed" "Ff" "Np")) ; *** See Note above. - (#x0D ("Return" "^m" "Cr")) ; *** See Note above. - (#x0E ("So" "^n")) - (#x0F ("Si" "^o")) - (#x10 ("Dle" "^p")) - (#x11 ("Dc1" "^q")) - (#x12 ("Dc2" "^r")) - (#x13 ("Dc3" "^s")) - (#x14 ("Dc4" "^t")) - (#x15 ("Nak" "^u")) - (#x16 ("Syn" "^v")) - (#x17 ("Etb" "^w")) - (#x18 ("Can" "^x")) - (#x19 ("Em" "^y")) - (#x1A ("Sub" "^z")) - (#x1B ("Esc" "Escape" "^[" "Altmode" "Alt")) - (#x1C ("Fs" "^\\")) - (#x1D ("Gs" "^]")) - (#x1E ("Rs" "^^")) - (#x1F ("Us" "^_")) - (#x20 ("Space" "Sp")) ; *** See Note above. - (#x7f ("Rubout" "Delete" "Del")) - (#x80 ("C80")) - (#x81 ("C81")) - (#x82 ("Break-Permitted")) - (#x83 ("No-Break-Permitted")) - (#x84 ("C84")) - (#x85 ("Next-Line")) - (#x86 ("Start-Selected-Area")) - (#x87 ("End-Selected-Area")) - (#x88 ("Character-Tabulation-Set")) - (#x89 ("Character-Tabulation-With-Justification")) - (#x8A ("Line-Tabulation-Set")) - (#x8B ("Partial-Line-Forward")) - (#x8C ("Partial-Line-Backward")) - (#x8D ("Reverse-Linefeed")) - (#x8E ("Single-Shift-Two")) - (#x8F ("Single-Shift-Three")) - (#x90 ("Device-Control-String")) - (#x91 ("Private-Use-One")) - (#x92 ("Private-Use-Two")) - (#x93 ("Set-Transmit-State")) - (#x94 ("Cancel-Character")) - (#x95 ("Message-Waiting")) - (#x96 ("Start-Guarded-Area")) - (#x97 ("End-Guarded-Area")) - (#x98 ("Start-String")) - (#x99 ("C99")) - (#x9A ("Single-Character-Introducer")) - (#x9B ("Control-Sequence-Introducer")) - (#x9C ("String-Terminator")) - (#x9D ("Operating-System-Command")) - (#x9E ("Privacy-Message")) - (#x9F ("Application-Program-Command"))))) ; *** See Note above. + (#x01 ("Soh" "^a")) + (#x02 ("Stx" "^b")) + (#x03 ("Etx" "^c")) + (#x04 ("Eot" "^d")) + (#x05 ("Enq" "^e")) + (#x06 ("Ack" "^f")) + (#x07 ("Bel" "Bell" "^g")) + (#x08 ("Backspace" "^h" "Bs")) ; *** See Note above. + (#x09 ("Tab" "^i" "Ht")) ; *** See Note above. + (#x0A ("Newline" "Linefeed" "^j" "Lf" "Nl" )) ; *** See Note above. + (#x0B ("Vt" "^k")) + (#x0C ("Page" "^l" "Form" "Formfeed" "Ff" "Np")) ; *** See Note above. + (#x0D ("Return" "^m" "Cr")) ; *** See Note above. + (#x0E ("So" "^n")) + (#x0F ("Si" "^o")) + (#x10 ("Dle" "^p")) + (#x11 ("Dc1" "^q")) + (#x12 ("Dc2" "^r")) + (#x13 ("Dc3" "^s")) + (#x14 ("Dc4" "^t")) + (#x15 ("Nak" "^u")) + (#x16 ("Syn" "^v")) + (#x17 ("Etb" "^w")) + (#x18 ("Can" "^x")) + (#x19 ("Em" "^y")) + (#x1A ("Sub" "^z")) + (#x1B ("Esc" "Escape" "^[" "Altmode" "Alt")) + (#x1C ("Fs" "^\\")) + (#x1D ("Gs" "^]")) + (#x1E ("Rs" "^^")) + (#x1F ("Us" "^_")) + (#x20 ("Space" "Sp")) ; *** See Note above. + (#x7f ("Rubout" "Delete" "Del")) + (#x80 ("C80")) + (#x81 ("C81")) + (#x82 ("Break-Permitted")) + (#x83 ("No-Break-Permitted")) + (#x84 ("C84")) + (#x85 ("Next-Line")) + (#x86 ("Start-Selected-Area")) + (#x87 ("End-Selected-Area")) + (#x88 ("Character-Tabulation-Set")) + (#x89 ("Character-Tabulation-With-Justification")) + (#x8A ("Line-Tabulation-Set")) + (#x8B ("Partial-Line-Forward")) + (#x8C ("Partial-Line-Backward")) + (#x8D ("Reverse-Linefeed")) + (#x8E ("Single-Shift-Two")) + (#x8F ("Single-Shift-Three")) + (#x90 ("Device-Control-String")) + (#x91 ("Private-Use-One")) + (#x92 ("Private-Use-Two")) + (#x93 ("Set-Transmit-State")) + (#x94 ("Cancel-Character")) + (#x95 ("Message-Waiting")) + (#x96 ("Start-Guarded-Area")) + (#x97 ("End-Guarded-Area")) + (#x98 ("Start-String")) + (#x99 ("C99")) + (#x9A ("Single-Character-Introducer")) + (#x9B ("Control-Sequence-Introducer")) + (#x9C ("String-Terminator")) + (#x9D ("Operating-System-Command")) + (#x9E ("Privacy-Message")) + (#x9F ("Application-Program-Command"))))) ; *** See Note above. ;;;; accessor functions @@ -142,8 +142,8 @@ ;; (+ 1488 (ash #x110000 -8)) => 5840 (defun ucd-index (char) (let* ((cp (char-code char)) - (cp-high (ash cp -8)) - (page (aref *character-database* (+ 1488 cp-high)))) + (cp-high (ash cp -8)) + (page (aref *character-database* (+ 1488 cp-high)))) (+ 5840 (ash page 10) (ash (ldb (byte 8 0) cp) 2)))) (defun ucd-value-0 (char) @@ -152,17 +152,17 @@ (defun ucd-value-1 (char) (let ((index (ucd-index char))) (dpb (aref *character-database* (+ index 3)) - (byte 8 16) - (dpb (aref *character-database* (+ index 2)) - (byte 8 8) - (aref *character-database* (1+ index)))))) + (byte 8 16) + (dpb (aref *character-database* (+ index 2)) + (byte 8 8) + (aref *character-database* (1+ index)))))) (defun ucd-general-category (char) (aref *character-database* (* 8 (ucd-value-0 char)))) (defun ucd-decimal-digit (char) (let ((decimal-digit (aref *character-database* - (+ 3 (* 8 (ucd-value-0 char)))))) + (+ 3 (* 8 (ucd-value-0 char)))))) (when (< decimal-digit 10) decimal-digit))) @@ -186,25 +186,25 @@ (defun character (object) #!+sb-doc - "Coerce OBJECT into a CHARACTER if possible. Legal inputs are + "Coerce OBJECT into a CHARACTER if possible. Legal inputs are characters, strings and symbols of length 1." (flet ((do-error (control args) - (error 'simple-type-error - :datum object - ;;?? how to express "symbol with name of length 1"? - :expected-type '(or character (string 1)) - :format-control control - :format-arguments args))) + (error 'simple-type-error + :datum object + ;;?? how to express "symbol with name of length 1"? + :expected-type '(or character (string 1)) + :format-control control + :format-arguments args))) (typecase object (character object) (string (if (= 1 (length (the string object))) - (char object 0) - (do-error - "String is not of length one: ~S" (list object)))) + (char object 0) + (do-error + "String is not of length one: ~S" (list object)))) (symbol (if (= 1 (length (symbol-name object))) - (schar (symbol-name object) 0) - (do-error - "Symbol name is not of length one: ~S" (list object)))) + (schar (symbol-name object) 0) + (do-error + "Symbol name is not of length one: ~S" (list object)))) (t (do-error "~S cannot be coerced to a character." (list object)))))) (defun char-name (char) @@ -227,8 +227,8 @@ or ." (and (typep char 'base-char) (let ((n (char-code (the base-char char)))) - (or (< 31 n 127) - (= n 10))))) + (or (< 31 n 127) + (= n 10))))) (defun %standard-char-p (thing) #!+sb-doc @@ -243,7 +243,7 @@ returns NIL." (let ((n (char-code char))) (or (< 31 n 127) - (< 159 n)))) + (< 159 n)))) (defun alpha-char-p (char) #!+sb-doc @@ -277,18 +277,18 @@ (let ((m (- (char-code char) 48))) (declare (fixnum m)) (cond ((<= radix 10.) - ;; Special-case decimal and smaller radices. - (if (and (>= m 0) (< m radix)) m nil)) - ;; Digits 0 - 9 are used as is, since radix is larger. - ((and (>= m 0) (< m 10)) m) - ;; Check for upper case A - Z. - ((and (>= (setq m (- m 7)) 10) (< m radix)) m) - ;; Also check lower case a - z. - ((and (>= (setq m (- m 32)) 10) (< m radix)) m) - ;; Else, fail. - (t (let ((number (ucd-decimal-digit char))) - (when (and number (< number radix)) - number)))))) + ;; Special-case decimal and smaller radices. + (if (and (>= m 0) (< m radix)) m nil)) + ;; Digits 0 - 9 are used as is, since radix is larger. + ((and (>= m 0) (< m 10)) m) + ;; Check for upper case A - Z. + ((and (>= (setq m (- m 7)) 10) (< m radix)) m) + ;; Also check lower case a - z. + ((and (>= (setq m (- m 32)) 10) (< m radix)) m) + ;; Else, fail. + (t (let ((number (ucd-decimal-digit char))) + (when (and number (< number radix)) + number)))))) (defun alphanumericp (char) #!+sb-doc @@ -296,7 +296,7 @@ argument is either numeric or alphabetic." (let ((gc (ucd-general-category char))) (or (< gc 5) - (= gc 12)))) + (= gc 12)))) (defun char= (character &rest more-characters) #!+sb-doc @@ -309,7 +309,7 @@ #!+sb-doc "Return T if no two of the arguments are the same character." (do* ((head character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (declare (type character head)) (dolist (c list) @@ -320,40 +320,40 @@ #!+sb-doc "Return T if the arguments are in strictly increasing alphabetic order." (do* ((c character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (< (char-int c) - (char-int (car list))) + (char-int (car list))) (return nil)))) (defun char> (character &rest more-characters) #!+sb-doc "Return T if the arguments are in strictly decreasing alphabetic order." (do* ((c character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (> (char-int c) - (char-int (car list))) + (char-int (car list))) (return nil)))) (defun char<= (character &rest more-characters) #!+sb-doc "Return T if the arguments are in strictly non-decreasing alphabetic order." (do* ((c character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (<= (char-int c) - (char-int (car list))) + (char-int (car list))) (return nil)))) (defun char>= (character &rest more-characters) #!+sb-doc "Return T if the arguments are in strictly non-increasing alphabetic order." (do* ((c character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (>= (char-int c) - (char-int (car list))) + (char-int (car list))) (return nil)))) ;;; EQUAL-CHAR-CODE is used by the following functions as a version of CHAR-INT @@ -363,8 +363,8 @@ (let ((ch (gensym))) `(let ((,ch ,character)) (if (= (ucd-value-0 ,ch) 0) - (ucd-value-1 ,ch) - (char-code ,ch))))) + (ucd-value-1 ,ch) + (char-code ,ch))))) (defun char-equal (character &rest more-characters) #!+sb-doc @@ -373,7 +373,7 @@ (do ((clist more-characters (cdr clist))) ((null clist) t) (unless (= (equal-char-code (car clist)) - (equal-char-code character)) + (equal-char-code character)) (return nil)))) (defun char-not-equal (character &rest more-characters) @@ -381,13 +381,13 @@ "Return T if no two of the arguments are the same character. Font, bits, and case are ignored." (do* ((head character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (do* ((l list (cdr l))) - ((null l) t) - (if (= (equal-char-code head) - (equal-char-code (car l))) - (return nil))) + ((null l) t) + (if (= (equal-char-code head) + (equal-char-code (car l))) + (return nil))) (return nil)))) (defun char-lessp (character &rest more-characters) @@ -395,10 +395,10 @@ "Return T if the arguments are in strictly increasing alphabetic order. Font, bits, and case are ignored." (do* ((c character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (< (equal-char-code c) - (equal-char-code (car list))) + (equal-char-code (car list))) (return nil)))) (defun char-greaterp (character &rest more-characters) @@ -406,10 +406,10 @@ "Return T if the arguments are in strictly decreasing alphabetic order. Font, bits, and case are ignored." (do* ((c character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (> (equal-char-code c) - (equal-char-code (car list))) + (equal-char-code (car list))) (return nil)))) (defun char-not-greaterp (character &rest more-characters) @@ -417,10 +417,10 @@ "Return T if the arguments are in strictly non-decreasing alphabetic order. Font, bits, and case are ignored." (do* ((c character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (<= (equal-char-code c) - (equal-char-code (car list))) + (equal-char-code (car list))) (return nil)))) (defun char-not-lessp (character &rest more-characters) @@ -428,10 +428,10 @@ "Return T if the arguments are in strictly non-increasing alphabetic order. Font, bits, and case are ignored." (do* ((c character (car list)) - (list more-characters (cdr list))) + (list more-characters (cdr list))) ((null list) t) (unless (>= (equal-char-code c) - (equal-char-code (car list))) + (equal-char-code (car list))) (return nil)))) ;;;; miscellaneous functions diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 22d7199..5fb9ac1 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -170,11 +170,11 @@ ;;; doesn't matter, since PCL only sets the FIN function. (defun (setf funcallable-instance-fun) (new-value fin) (setf (%funcallable-instance-fun fin) - (%closure-fun new-value)) + (%closure-fun new-value)) (setf (%funcallable-instance-lexenv fin) - (if (funcallable-instance-p new-value) - (%funcallable-instance-lexenv new-value) - new-value))) + (if (funcallable-instance-p new-value) + (%funcallable-instance-lexenv new-value) + new-value))) ;;; service function for structure constructors (defun %make-instance-with-layout (layout) @@ -200,10 +200,10 @@ (/show0 "entering PROTECT-CL, SYMBOL=..") (/hexstr symbol) (when (and *cold-init-complete-p* - (eq (symbol-package symbol) *cl-package*)) + (eq (symbol-package symbol) *cl-package*)) (cerror "Go ahead and patch the system." - "attempting to modify a symbol in the COMMON-LISP package: ~S" - symbol)) + "attempting to modify a symbol in the COMMON-LISP package: ~S" + symbol)) (/show0 "leaving PROTECT-CL") (values)) @@ -232,20 +232,20 @@ (let ((accessor-name (dsd-accessor-name dsd))) ;; We mustn't step on any inherited accessors (unless (accessor-inherited-data accessor-name dd) - (/show0 "ACCESSOR-NAME=..") - (/hexstr accessor-name) - (protect-cl accessor-name) - (/hexstr "getting READER-FUN and WRITER-FUN") - (multiple-value-bind (reader-fun writer-fun) - (slot-accessor-funs dd dsd) - (declare (type function reader-fun writer-fun)) - (/show0 "got READER-FUN and WRITER-FUN=..") - (/hexstr reader-fun) - (setf (symbol-function accessor-name) reader-fun) - (unless (dsd-read-only dsd) - (/show0 "setting FDEFINITION for WRITER-FUN=..") - (/hexstr writer-fun) - (setf (fdefinition `(setf ,accessor-name)) writer-fun)))))) + (/show0 "ACCESSOR-NAME=..") + (/hexstr accessor-name) + (protect-cl accessor-name) + (/hexstr "getting READER-FUN and WRITER-FUN") + (multiple-value-bind (reader-fun writer-fun) + (slot-accessor-funs dd dsd) + (declare (type function reader-fun writer-fun)) + (/show0 "got READER-FUN and WRITER-FUN=..") + (/hexstr reader-fun) + (setf (symbol-function accessor-name) reader-fun) + (unless (dsd-read-only dsd) + (/show0 "setting FDEFINITION for WRITER-FUN=..") + (/hexstr writer-fun) + (setf (fdefinition `(setf ,accessor-name)) writer-fun)))))) ;; Set FDEFINITION for copier. (when (dd-copier-name dd) @@ -256,44 +256,44 @@ ;; (And funcallable instances don't need copiers anyway.) (aver (eql (dd-type dd) 'structure)) (setf (symbol-function (dd-copier-name dd)) - ;; FIXME: should use a closure which checks arg type before copying - #'copy-structure)) + ;; FIXME: should use a closure which checks arg type before copying + #'copy-structure)) ;; Set FDEFINITION for predicate. (when (dd-predicate-name dd) (/show0 "doing FDEFINITION for predicate") (protect-cl (dd-predicate-name dd)) (setf (symbol-function (dd-predicate-name dd)) - (ecase (dd-type dd) - ;; structures with LAYOUTs - ((structure funcallable-structure) - (/show0 "with-LAYOUT case") - (lambda (object) - (locally ; <- to keep SAFETY 0 from affecting arg count checking - (declare (optimize (speed 3) (safety 0))) - (/noshow0 "in with-LAYOUT structure predicate closure, OBJECT,LAYOUT=..") - (/nohexstr object) - (/nohexstr layout) - (typep-to-layout object layout)))) - ;; structures with no LAYOUT (i.e. :TYPE VECTOR or :TYPE LIST) - ;; - ;; FIXME: should handle the :NAMED T case in these cases - (vector - (/show0 ":TYPE VECTOR case") - #'vectorp) - (list - (/show0 ":TYPE LIST case") - #'listp)))) + (ecase (dd-type dd) + ;; structures with LAYOUTs + ((structure funcallable-structure) + (/show0 "with-LAYOUT case") + (lambda (object) + (locally ; <- to keep SAFETY 0 from affecting arg count checking + (declare (optimize (speed 3) (safety 0))) + (/noshow0 "in with-LAYOUT structure predicate closure, OBJECT,LAYOUT=..") + (/nohexstr object) + (/nohexstr layout) + (typep-to-layout object layout)))) + ;; structures with no LAYOUT (i.e. :TYPE VECTOR or :TYPE LIST) + ;; + ;; FIXME: should handle the :NAMED T case in these cases + (vector + (/show0 ":TYPE VECTOR case") + #'vectorp) + (list + (/show0 ":TYPE LIST case") + #'listp)))) (when (dd-doc dd) (setf (fdocumentation (dd-name dd) 'structure) - (dd-doc dd))) + (dd-doc dd))) ;; the BOUNDP test here is to get past cold-init. (when (boundp '*defstruct-hooks*) (dolist (fun *defstruct-hooks*) (funcall fun (find-classoid (dd-name dd))))) - + (/show0 "leaving %TARGET-DEFSTRUCT") (values)) @@ -318,53 +318,53 @@ ;; things like INSTANCE and DSD-INDEX from the namespace they're ;; expanded in. (macrolet (;; code shared between funcallable instance case and the - ;; ordinary STRUCTURE-OBJECT case: Handle native - ;; structures with LAYOUTs and (possibly) raw slots. - (%native-slot-accessor-funs (dd-ref-fun-name) - (let ((instance-type-check-form - '(%check-structure-type-from-layout instance layout))) - (/show "macroexpanding %NATIVE-SLOT-ACCESSOR-FUNS" dd-ref-fun-name instance-type-check-form) - `(let ((layout (dd-layout-or-lose dd)) - (dsd-raw-type (dsd-raw-type dsd))) - #+sb-xc (/show0 "in %NATIVE-SLOT-ACCESSOR-FUNS macroexpanded code") - ;; Map over all the possible RAW-TYPEs, compiling - ;; a different closure function for each one, so - ;; that once the COND over RAW-TYPEs happens (at - ;; the time closure is allocated) there are no - ;; more decisions to be made and things execute - ;; reasonably efficiently. - (cond - ;; nonraw slot case - ((eql dsd-raw-type t) - #+sb-xc (/show0 "in nonraw slot case") - (%slotplace-accessor-funs - (,dd-ref-fun-name instance dsd-index) - ,instance-type-check-form)) - ;; raw slot cases - ,@(mapcar (lambda (rtd) - (let ((raw-type (raw-slot-data-raw-type rtd)) - (accessor-name - (raw-slot-data-accessor-name rtd))) - `((equal dsd-raw-type ',raw-type) - #+sb-xc (/show0 "in raw slot case") - (%slotplace-accessor-funs - (,accessor-name instance dsd-index) - ,instance-type-check-form)))) - *raw-slot-data-list*) - ;; oops - (t - (bug "unexpected DSD-RAW-TYPE ~S" dsd-raw-type)))))) - ;; code shared between DEFSTRUCT :TYPE LIST and - ;; DEFSTRUCT :TYPE VECTOR cases: Handle the "typed - ;; structure" case, with no LAYOUTs and no raw slots. - (%colontyped-slot-accessor-funs () (error "stub")) - ;; the common structure of the raw-slot and not-raw-slot - ;; cases, defined in terms of the writable SLOTPLACE. All - ;; possible flavors of slot access should be able to pass - ;; through here. - (%slotplace-accessor-funs (slotplace instance-type-check-form) - (/show "macroexpanding %SLOTPLACE-ACCESSOR-FUNS" slotplace instance-type-check-form) - `(let ((typecheckfun (typespec-typecheckfun dsd-type))) + ;; ordinary STRUCTURE-OBJECT case: Handle native + ;; structures with LAYOUTs and (possibly) raw slots. + (%native-slot-accessor-funs (dd-ref-fun-name) + (let ((instance-type-check-form + '(%check-structure-type-from-layout instance layout))) + (/show "macroexpanding %NATIVE-SLOT-ACCESSOR-FUNS" dd-ref-fun-name instance-type-check-form) + `(let ((layout (dd-layout-or-lose dd)) + (dsd-raw-type (dsd-raw-type dsd))) + #+sb-xc (/show0 "in %NATIVE-SLOT-ACCESSOR-FUNS macroexpanded code") + ;; Map over all the possible RAW-TYPEs, compiling + ;; a different closure function for each one, so + ;; that once the COND over RAW-TYPEs happens (at + ;; the time closure is allocated) there are no + ;; more decisions to be made and things execute + ;; reasonably efficiently. + (cond + ;; nonraw slot case + ((eql dsd-raw-type t) + #+sb-xc (/show0 "in nonraw slot case") + (%slotplace-accessor-funs + (,dd-ref-fun-name instance dsd-index) + ,instance-type-check-form)) + ;; raw slot cases + ,@(mapcar (lambda (rtd) + (let ((raw-type (raw-slot-data-raw-type rtd)) + (accessor-name + (raw-slot-data-accessor-name rtd))) + `((equal dsd-raw-type ',raw-type) + #+sb-xc (/show0 "in raw slot case") + (%slotplace-accessor-funs + (,accessor-name instance dsd-index) + ,instance-type-check-form)))) + *raw-slot-data-list*) + ;; oops + (t + (bug "unexpected DSD-RAW-TYPE ~S" dsd-raw-type)))))) + ;; code shared between DEFSTRUCT :TYPE LIST and + ;; DEFSTRUCT :TYPE VECTOR cases: Handle the "typed + ;; structure" case, with no LAYOUTs and no raw slots. + (%colontyped-slot-accessor-funs () (error "stub")) + ;; the common structure of the raw-slot and not-raw-slot + ;; cases, defined in terms of the writable SLOTPLACE. All + ;; possible flavors of slot access should be able to pass + ;; through here. + (%slotplace-accessor-funs (slotplace instance-type-check-form) + (/show "macroexpanding %SLOTPLACE-ACCESSOR-FUNS" slotplace instance-type-check-form) + `(let ((typecheckfun (typespec-typecheckfun dsd-type))) (values (if (dsd-safe-p dsd) (lambda (instance) (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader") @@ -379,40 +379,40 @@ (funcall typecheckfun value) value))) (lambda (new-value instance) - (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined writer") - ,instance-type-check-form - (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM") - (funcall typecheckfun new-value) - (/noshow0 "back from TYPECHECKFUN") - (setf ,slotplace new-value)))))) + (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined writer") + ,instance-type-check-form + (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM") + (funcall typecheckfun new-value) + (/noshow0 "back from TYPECHECKFUN") + (setf ,slotplace new-value)))))) (let ((dsd-index (dsd-index dsd)) - (dsd-type (dsd-type dsd))) + (dsd-type (dsd-type dsd))) #+sb-xc (/show0 "got DSD-TYPE=..") #+sb-xc (/hexstr dsd-type) (ecase (dd-type dd) - ;; native structures - (structure - #+sb-xc (/show0 "case of DSD-TYPE = STRUCTURE") - (%native-slot-accessor-funs %instance-ref)) + ;; native structures + (structure + #+sb-xc (/show0 "case of DSD-TYPE = STRUCTURE") + (%native-slot-accessor-funs %instance-ref)) - ;; structures with the :TYPE option + ;; structures with the :TYPE option - ;; FIXME: Worry about these later.. - #| + ;; FIXME: Worry about these later.. + #| ;; In :TYPE LIST and :TYPE VECTOR structures, ANSI specifies the ;; layout completely, so that raw slots are impossible. (list (dd-type-slot-accessor-funs nth-but-with-sane-arg-order - `(%check-structure-type-from-dd - :maybe-raw-p nil)) + `(%check-structure-type-from-dd + :maybe-raw-p nil)) (vector (dd-type-slot-accessor-funs aref - :maybe-raw-p nil))) + :maybe-raw-p nil))) |# - )))) + )))) ;;; Copy any old kind of structure. (defun copy-structure (structure) @@ -420,9 +420,9 @@ "Return a copy of STRUCTURE with the same (EQL) slot values." (declare (type structure-object structure)) (let* ((len (%instance-length structure)) - (res (%make-instance len)) - (layout (%instance-layout structure)) - (nuntagged (layout-n-untagged-slots layout))) + (res (%make-instance len)) + (layout (%instance-layout structure)) + (nuntagged (layout-n-untagged-slots layout))) (declare (type index len)) (when (layout-invalid layout) @@ -432,13 +432,13 @@ (dotimes (i (- len nuntagged)) (declare (type index i)) (setf (%instance-ref res i) - (%instance-ref structure i))) + (%instance-ref structure i))) ;; Copy raw slots. (dotimes (i nuntagged) (declare (type index i)) (setf (%raw-instance-ref/word res i) - (%raw-instance-ref/word structure i))) + (%raw-instance-ref/word structure i))) res)) @@ -446,16 +446,16 @@ (defun %default-structure-pretty-print (structure stream) (let* ((layout (%instance-layout structure)) - (name (classoid-name (layout-classoid layout))) - (dd (layout-info layout))) + (name (classoid-name (layout-classoid layout))) + (dd (layout-info layout))) ;; KLUDGE: during the build process with SB-SHOW, we can sometimes ;; attempt to print out a PCL object (with null LAYOUT-INFO). #!+sb-show (when (null dd) (pprint-logical-block (stream nil :prefix "#<" :suffix ">") - (prin1 name stream) - (write-char #\space stream) - (write-string "(no LAYOUT-INFO)")) + (prin1 name stream) + (write-char #\space stream) + (write-string "(no LAYOUT-INFO)")) (return-from %default-structure-pretty-print nil)) ;; the structure type doesn't count as a component for ;; *PRINT-LEVEL* processing. We can likewise elide the logical @@ -469,29 +469,29 @@ (pprint-logical-block (stream nil :prefix "#S(" :suffix ")") (prin1 name stream) (let ((remaining-slots (dd-slots dd))) - (when remaining-slots - (write-char #\space stream) - ;; CMU CL had (PPRINT-INDENT :BLOCK 2 STREAM) here, - ;; but I can't see why. -- WHN 20000205 - (pprint-newline :linear stream) - (loop - (pprint-pop) - (let ((slot (pop remaining-slots))) - (write-char #\: stream) - (output-symbol-name (symbol-name (dsd-name slot)) stream) - (write-char #\space stream) - (pprint-newline :miser stream) - (output-object (funcall (fdefinition (dsd-accessor-name slot)) - structure) - stream) - (when (null remaining-slots) - (return)) - (write-char #\space stream) - (pprint-newline :linear stream)))))))) + (when remaining-slots + (write-char #\space stream) + ;; CMU CL had (PPRINT-INDENT :BLOCK 2 STREAM) here, + ;; but I can't see why. -- WHN 20000205 + (pprint-newline :linear stream) + (loop + (pprint-pop) + (let ((slot (pop remaining-slots))) + (write-char #\: stream) + (output-symbol-name (symbol-name (dsd-name slot)) stream) + (write-char #\space stream) + (pprint-newline :miser stream) + (output-object (funcall (fdefinition (dsd-accessor-name slot)) + structure) + stream) + (when (null remaining-slots) + (return)) + (write-char #\space stream) + (pprint-newline :linear stream)))))))) (defun %default-structure-ugly-print (structure stream) (let* ((layout (%instance-layout structure)) - (name (classoid-name (layout-classoid layout))) - (dd (layout-info layout))) + (name (classoid-name (layout-classoid layout))) + (dd (layout-info layout))) (when (and dd (null (dd-slots dd))) (write-string "#S(" stream) (prin1 name stream) @@ -501,32 +501,32 @@ (write-string "#S(" stream) (prin1 name stream) (do ((index 0 (1+ index)) - (remaining-slots (dd-slots dd) (cdr remaining-slots))) - ((or (null remaining-slots) - (and (not *print-readably*) - *print-length* - (>= index *print-length*))) - (if (null remaining-slots) - (write-string ")" stream) - (write-string " ...)" stream))) - (declare (type index index)) - (write-char #\space stream) - (write-char #\: stream) - (let ((slot (first remaining-slots))) - (output-symbol-name (symbol-name (dsd-name slot)) stream) - (write-char #\space stream) - (output-object - (funcall (fdefinition (dsd-accessor-name slot)) - structure) - stream)))))) + (remaining-slots (dd-slots dd) (cdr remaining-slots))) + ((or (null remaining-slots) + (and (not *print-readably*) + *print-length* + (>= index *print-length*))) + (if (null remaining-slots) + (write-string ")" stream) + (write-string " ...)" stream))) + (declare (type index index)) + (write-char #\space stream) + (write-char #\: stream) + (let ((slot (first remaining-slots))) + (output-symbol-name (symbol-name (dsd-name slot)) stream) + (write-char #\space stream) + (output-object + (funcall (fdefinition (dsd-accessor-name slot)) + structure) + stream)))))) (defun default-structure-print (structure stream depth) (declare (ignore depth)) (cond ((funcallable-instance-p structure) - (print-unreadable-object (structure stream :identity t :type t))) - (*print-pretty* - (%default-structure-pretty-print structure stream)) - (t - (%default-structure-ugly-print structure stream)))) + (print-unreadable-object (structure stream :identity t :type t))) + (*print-pretty* + (%default-structure-pretty-print structure stream)) + (t + (%default-structure-ugly-print structure stream)))) (def!method print-object ((x structure-object) stream) (default-structure-print x stream *current-level-in-print*)) @@ -555,24 +555,24 @@ ;; (TYPEP OBJ 'INSTANCE) is optimized to equally efficient code. (and (typep obj 'instance) (let ((obj-layout (%instance-layout obj))) - (cond ((eq obj-layout layout) - ;; (In this case OBJ-LAYOUT can't be invalid, because - ;; we determined LAYOUT is valid in the test above.) - (/noshow0 "EQ case") - t) - ((layout-invalid obj-layout) - (/noshow0 "LAYOUT-INVALID case") - (error 'layout-invalid - :expected-type (layout-classoid obj-layout) - :datum obj)) - (t - (let ((depthoid (layout-depthoid layout))) - (/noshow0 "DEPTHOID case, DEPTHOID,LAYOUT-INHERITS=..") - (/nohexstr depthoid) - (/nohexstr layout-inherits) - (and (> (layout-depthoid obj-layout) depthoid) - (eq (svref (layout-inherits obj-layout) depthoid) - layout)))))))) + (cond ((eq obj-layout layout) + ;; (In this case OBJ-LAYOUT can't be invalid, because + ;; we determined LAYOUT is valid in the test above.) + (/noshow0 "EQ case") + t) + ((layout-invalid obj-layout) + (/noshow0 "LAYOUT-INVALID case") + (error 'layout-invalid + :expected-type (layout-classoid obj-layout) + :datum obj)) + (t + (let ((depthoid (layout-depthoid layout))) + (/noshow0 "DEPTHOID case, DEPTHOID,LAYOUT-INHERITS=..") + (/nohexstr depthoid) + (/nohexstr layout-inherits) + (and (> (layout-depthoid obj-layout) depthoid) + (eq (svref (layout-inherits obj-layout) depthoid) + layout)))))))) ;;;; checking structure types @@ -587,45 +587,45 @@ (ecase (dd-type dd) ((structure funcallable-instance) `(%check-structure-type-from-layout - ,x - ,(compiler-layout-or-lose class-name))) + ,x + ,(compiler-layout-or-lose class-name))) ((vector) (with-unique-names (xx) - `(let ((,xx ,x)) - (declare (type vector ,xx)) - ,@(when (dd-named dd) - `((unless (eql (aref ,xx 0) ',class-name) - (error - 'simple-type-error - :datum (aref ,xx 0) - :expected-type `(member ,class-name) - :format-control - "~@" - :format-arguments (list ',class-name ,xx))))) - (values)))) + :format-arguments (list ',class-name ,xx))))) + (values)))) ((list) (with-unique-names (xx) - `(let ((,xx ,x)) - (declare (type list ,xx)) - ,@(when (dd-named dd) - `((unless (eql (first ,xx) ',class-name) - (error - 'simple-type-error - :datum (aref ,xx 0) - :expected-type `(member ,class-name) - :format-control - "~@" - :format-arguments (list ',class-name ,xx))))) - (values))))))) + :format-arguments (list ',class-name ,xx))))) + (values))))))) ;;; Check that X is an instance of the structure class with layout LAYOUT. (defun %check-structure-type-from-layout (x layout) (unless (typep-to-layout x layout) (error 'type-error - :datum x - :expected-type (classoid-name (layout-classoid layout)))) + :datum x + :expected-type (classoid-name (layout-classoid layout)))) (values)) (/show0 "target-defstruct.lisp end of file") diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp index 288f3e1..2406d7b 100644 --- a/src/code/target-error.lisp +++ b/src/code/target-error.lisp @@ -30,7 +30,7 @@ (def!method print-object ((restart restart) stream) (if *print-escape* (print-unreadable-object (restart stream :type t :identity t) - (prin1 (restart-name restart) stream)) + (prin1 (restart-name restart) stream)) (restart-report restart stream))) (defun compute-restarts (&optional condition) @@ -40,20 +40,20 @@ specified, then only restarts associated with CONDITION (or with no condition) will be returned." (let ((associated ()) - (other ())) + (other ())) (dolist (alist *condition-restarts*) (if (eq (car alist) condition) - (setq associated (cdr alist)) - (setq other (append (cdr alist) other)))) + (setq associated (cdr alist)) + (setq other (append (cdr alist) other)))) (collect ((res)) (dolist (restart-cluster *restart-clusters*) - (dolist (restart restart-cluster) - (when (and (or (not condition) - (member restart associated) - (not (member restart other))) - (funcall (restart-test-function restart) + (dolist (restart restart-cluster) + (when (and (or (not condition) + (member restart associated) + (not (member restart other))) + (funcall (restart-test-function restart) condition)) - (res restart)))) + (res restart)))) (res)))) #!+sb-doc @@ -62,11 +62,11 @@ (defun restart-report (restart stream) (funcall (or (restart-report-function restart) - (let ((name (restart-name restart))) - (lambda (stream) - (if name (format stream "~S" name) - (format stream "~S" restart))))) - stream)) + (let ((name (restart-name restart))) + (lambda (stream) + (if name (format stream "~S" name) + (format stream "~S" restart))))) + stream)) (defun find-restart (name &optional condition) #!+sb-doc @@ -87,8 +87,8 @@ (defun find-restart-or-control-error (identifier &optional condition) (or (find-restart identifier condition) (error 'simple-control-error - :format-control "No restart ~S is active~@[ for ~S~]." - :format-arguments (list identifier condition)))) + :format-control "No restart ~S is active~@[ for ~S~]." + :format-arguments (list identifier condition)))) (defun invoke-restart (restart &rest values) #!+sb-doc @@ -102,8 +102,8 @@ (defun interactive-restart-arguments (real-restart) (let ((interactive-function (restart-interactive-function real-restart))) (if interactive-function - (funcall interactive-function) - '()))) + (funcall interactive-function) + '()))) (defun invoke-restart-interactively (restart) #!+sb-doc @@ -111,30 +111,30 @@ necessary arguments. If the argument restart is not a restart or a currently active non-NIL restart name, then a CONTROL-ERROR is signalled." (let* ((real-restart (find-restart-or-control-error restart)) - (args (interactive-restart-arguments real-restart))) + (args (interactive-restart-arguments real-restart))) (apply (restart-function real-restart) args))) (defun assert-error (assertion places datum &rest arguments) (let ((cond (if datum - (coerce-to-condition datum - arguments - 'simple-error - 'error) - (make-condition 'simple-error - :format-control "The assertion ~S failed." - :format-arguments (list assertion))))) + (coerce-to-condition datum + arguments + 'simple-error + 'error) + (make-condition 'simple-error + :format-control "The assertion ~S failed." + :format-arguments (list assertion))))) (restart-case - (error cond) + (error cond) (continue () - :report (lambda (stream) - (format stream "Retry assertion") - (if places - (format stream - " with new value~P for ~{~S~^, ~}." - (length places) - places) - (format stream "."))) - nil)))) + :report (lambda (stream) + (format stream "Retry assertion") + (if places + (format stream + " with new value~P for ~{~S~^, ~}." + (length places) + places) + (format stream "."))) + nil)))) ;;; READ-EVALUATED-FORM is used as the interactive method for restart cases ;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros @@ -145,29 +145,29 @@ (defun check-type-error (place place-value type type-string) (let ((condition - (make-condition - 'simple-type-error - :datum place-value - :expected-type type - :format-control - "The value of ~S is ~S, which is not ~:[of type ~S~;~:*~A~]." - :format-arguments (list place place-value type-string type)))) + (make-condition + 'simple-type-error + :datum place-value + :expected-type type + :format-control + "The value of ~S is ~S, which is not ~:[of type ~S~;~:*~A~]." + :format-arguments (list place place-value type-string type)))) (restart-case (error condition) (store-value (value) - :report (lambda (stream) - (format stream "Supply a new value for ~S." place)) - :interactive read-evaluated-form - value)))) + :report (lambda (stream) + (format stream "Supply a new value for ~S." place)) + :interactive read-evaluated-form + value)))) (defun case-body-error (name keyform keyform-value expected-type keys) (restart-case (error 'case-failure - :name name - :datum keyform-value - :expected-type expected-type - :possibilities keys) + :name name + :datum keyform-value + :expected-type expected-type + :possibilities keys) (store-value (value) :report (lambda (stream) - (format stream "Supply a new value for ~S." keyform)) + (format stream "Supply a new value for ~S." keyform)) :interactive read-evaluated-form value))) diff --git a/src/code/target-extensions.lisp b/src/code/target-extensions.lisp index 625c514..87d4446 100644 --- a/src/code/target-extensions.lisp +++ b/src/code/target-extensions.lisp @@ -38,11 +38,11 @@ applications.") ;;; like LISTEN, but any whitespace in the input stream will be flushed (defun listen-skip-whitespace (&optional (stream *standard-input*)) (do ((char (read-char-no-hang stream nil nil nil) - (read-char-no-hang stream nil nil nil))) + (read-char-no-hang stream nil nil nil))) ((null char) nil) (cond ((not (whitespacep char)) - (unread-char char stream) - (return t))))) + (unread-char char stream) + (return t))))) ;;;; helpers for C library calls @@ -50,15 +50,15 @@ applications.") ;;; errno problem, arranging for the condition's print representation ;;; to be similar to the ANSI C perror(3) style. (defun simple-perror (prefix-string - &key - (errno (get-errno)) - (simple-error 'simple-error) - other-condition-args) + &key + (errno (get-errno)) + (simple-error 'simple-error) + other-condition-args) (declare (type symbol simple-error)) (aver (subtypep simple-error 'simple-condition)) (aver (subtypep simple-error 'error)) (apply #'error - simple-error - :format-control "~@<~A: ~2I~_~A~:>" - :format-arguments (list prefix-string (strerror errno)) - other-condition-args)) + simple-error + :format-control "~@<~A: ~2I~_~A~:>" + :format-arguments (list prefix-string (strerror errno)) + other-condition-args)) diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp index b15183f..0106059 100644 --- a/src/code/target-format.lisp +++ b/src/code/target-format.lisp @@ -55,44 +55,44 @@ (if (functionp string-or-fun) (apply string-or-fun stream args) (catch 'up-and-out - (let* ((string (etypecase string-or-fun - (simple-string - string-or-fun) - (string - (coerce string-or-fun 'simple-string)))) - (*default-format-error-control-string* string) - (*logical-block-popper* nil)) - (interpret-directive-list stream (tokenize-control-string string) - orig-args args))))) + (let* ((string (etypecase string-or-fun + (simple-string + string-or-fun) + (string + (coerce string-or-fun 'simple-string)))) + (*default-format-error-control-string* string) + (*logical-block-popper* nil)) + (interpret-directive-list stream (tokenize-control-string string) + orig-args args))))) (defun interpret-directive-list (stream directives orig-args args) (if directives (let ((directive (car directives))) - (etypecase directive - (simple-string - (write-string directive stream) - (interpret-directive-list stream (cdr directives) orig-args args)) - (format-directive - (multiple-value-bind (new-directives new-args) - (let* ((character (format-directive-character directive)) - (function + (etypecase directive + (simple-string + (write-string directive stream) + (interpret-directive-list stream (cdr directives) orig-args args)) + (format-directive + (multiple-value-bind (new-directives new-args) + (let* ((character (format-directive-character directive)) + (function (typecase character - (base-char - (svref *format-directive-interpreters* - (char-code character))) + (base-char + (svref *format-directive-interpreters* + (char-code character))) (character nil))) - (*default-format-error-offset* - (1- (format-directive-end directive)))) - (unless function - (error 'format-error - :complaint "unknown format directive ~@[(character: ~A)~]" - :args (list (char-name character)))) - (multiple-value-bind (new-directives new-args) - (funcall function stream directive - (cdr directives) orig-args args) - (values new-directives new-args))) - (interpret-directive-list stream new-directives - orig-args new-args))))) + (*default-format-error-offset* + (1- (format-directive-end directive)))) + (unless function + (error 'format-error + :complaint "unknown format directive ~@[(character: ~A)~]" + :args (list (char-name character)))) + (multiple-value-bind (new-directives new-args) + (funcall function stream directive + (cdr directives) orig-args args) + (values new-directives new-args))) + (interpret-directive-list stream new-directives + orig-args new-args))))) args)) ;;;; FORMAT directive definition macros and runtime support @@ -105,32 +105,32 @@ `(progn (when (null args) (error 'format-error - :complaint "no more arguments" - ,@(when offset - `(:offset ,offset)))) + :complaint "no more arguments" + ,@(when offset + `(:offset ,offset)))) (when *logical-block-popper* (funcall *logical-block-popper*)) (pop args))) (sb!xc:defmacro def-complex-format-interpreter (char lambda-list &body body) (let ((defun-name - (intern (format nil - "~:@(~:C~)-FORMAT-DIRECTIVE-INTERPRETER" - char))) - (directive (gensym)) - (directives (if lambda-list (car (last lambda-list)) (gensym)))) + (intern (format nil + "~:@(~:C~)-FORMAT-DIRECTIVE-INTERPRETER" + char))) + (directive (gensym)) + (directives (if lambda-list (car (last lambda-list)) (gensym)))) `(progn (defun ,defun-name (stream ,directive ,directives orig-args args) - (declare (ignorable stream orig-args args)) - ,@(if lambda-list - `((let ,(mapcar (lambda (var) - `(,var - (,(symbolicate "FORMAT-DIRECTIVE-" var) - ,directive))) - (butlast lambda-list)) - (values (progn ,@body) args))) - `((declare (ignore ,directive ,directives)) - ,@body))) + (declare (ignorable stream orig-args args)) + ,@(if lambda-list + `((let ,(mapcar (lambda (var) + `(,var + (,(symbolicate "FORMAT-DIRECTIVE-" var) + ,directive))) + (butlast lambda-list)) + (values (progn ,@body) args))) + `((declare (ignore ,directive ,directives)) + ,@body))) (%set-format-directive-interpreter ,char #',defun-name)))) (sb!xc:defmacro def-format-interpreter (char lambda-list &body body) @@ -143,23 +143,23 @@ (once-only ((params params)) (collect ((bindings)) (dolist (spec specs) - (destructuring-bind (var default) spec - (bindings `(,var (let* ((param-and-offset (pop ,params)) - (offset (car param-and-offset)) - (param (cdr param-and-offset))) - (case param - (:arg (or (next-arg offset) ,default)) - (:remaining (length args)) - ((nil) ,default) - (t param))))))) + (destructuring-bind (var default) spec + (bindings `(,var (let* ((param-and-offset (pop ,params)) + (offset (car param-and-offset)) + (param (cdr param-and-offset))) + (case param + (:arg (or (next-arg offset) ,default)) + (:remaining (length args)) + ((nil) ,default) + (t param))))))) `(let* ,(bindings) - (when ,params - (error 'format-error - :complaint - "too many parameters, expected no more than ~W" - :args (list ,(length specs)) - :offset (caar ,params))) - ,@body)))) + (when ,params + (error 'format-error + :complaint + "too many parameters, expected no more than ~W" + :args (list ,(length specs)) + :offset (caar ,params))) + ,@body)))) ) ; EVAL-WHEN @@ -176,70 +176,70 @@ ;; the unsupplied-MINCOL-and-COLINC case without blowing up. (when (and mincol colinc) (do ((chars (+ (length string) (max minpad 0)) (+ chars colinc))) - ((>= chars mincol)) + ((>= chars mincol)) (dotimes (i colinc) - (write-char padchar stream)))) + (write-char padchar stream)))) (when padleft (write-string string stream))) (defun format-princ (stream arg colonp atsignp mincol colinc minpad padchar) (format-write-field stream - (if (or arg (not colonp)) - (princ-to-string arg) - "()") - mincol colinc minpad padchar atsignp)) + (if (or arg (not colonp)) + (princ-to-string arg) + "()") + mincol colinc minpad padchar atsignp)) (def-format-interpreter #\A (colonp atsignp params) (if params (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) - (padchar #\space)) - params - (format-princ stream (next-arg) colonp atsignp - mincol colinc minpad padchar)) + (padchar #\space)) + params + (format-princ stream (next-arg) colonp atsignp + mincol colinc minpad padchar)) (princ (if colonp (or (next-arg) "()") (next-arg)) stream))) (defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar) (format-write-field stream - (if (or arg (not colonp)) - (prin1-to-string arg) - "()") - mincol colinc minpad padchar atsignp)) + (if (or arg (not colonp)) + (prin1-to-string arg) + "()") + mincol colinc minpad padchar atsignp)) (def-format-interpreter #\S (colonp atsignp params) (cond (params - (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) - (padchar #\space)) - params - (format-prin1 stream (next-arg) colonp atsignp - mincol colinc minpad padchar))) - (colonp - (let ((arg (next-arg))) - (if arg - (prin1 arg stream) - (princ "()" stream)))) - (t - (prin1 (next-arg) stream)))) + (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) + (padchar #\space)) + params + (format-prin1 stream (next-arg) colonp atsignp + mincol colinc minpad padchar))) + (colonp + (let ((arg (next-arg))) + (if arg + (prin1 arg stream) + (princ "()" stream)))) + (t + (prin1 (next-arg) stream)))) (def-format-interpreter #\C (colonp atsignp params) (interpret-bind-defaults () params (if colonp - (format-print-named-character (next-arg) stream) - (if atsignp - (prin1 (next-arg) stream) - (write-char (next-arg) stream))))) + (format-print-named-character (next-arg) stream) + (if atsignp + (prin1 (next-arg) stream) + (write-char (next-arg) stream))))) (defun format-print-named-character (char stream) (let* ((name (char-name char))) (cond (name - (write-string (string-capitalize name) stream)) - (t - (write-char char stream))))) + (write-string (string-capitalize name) stream)) + (t + (write-char char stream))))) (def-format-interpreter #\W (colonp atsignp params) (interpret-bind-defaults () params (let ((*print-pretty* (or colonp *print-pretty*)) - (*print-level* (unless atsignp *print-level*)) - (*print-length* (unless atsignp *print-length*))) + (*print-level* (unless atsignp *print-level*)) + (*print-length* (unless atsignp *print-length*))) (output-object (next-arg) stream)))) ;;;; format interpreters and support functions for integer output @@ -247,46 +247,46 @@ ;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing ;;; directives. The parameters are interpreted as defined for ~D. (defun format-print-integer (stream number print-commas-p print-sign-p - radix mincol padchar commachar commainterval) + radix mincol padchar commachar commainterval) (let ((*print-base* radix) - (*print-radix* nil)) + (*print-radix* nil)) (if (integerp number) - (let* ((text (princ-to-string (abs number))) - (commaed (if print-commas-p - (format-add-commas text commachar commainterval) - text)) - (signed (cond ((minusp number) - (concatenate 'string "-" commaed)) - (print-sign-p - (concatenate 'string "+" commaed)) - (t commaed)))) - ;; colinc = 1, minpad = 0, padleft = t - (format-write-field stream signed mincol 1 0 padchar t)) - (princ number stream)))) + (let* ((text (princ-to-string (abs number))) + (commaed (if print-commas-p + (format-add-commas text commachar commainterval) + text)) + (signed (cond ((minusp number) + (concatenate 'string "-" commaed)) + (print-sign-p + (concatenate 'string "+" commaed)) + (t commaed)))) + ;; colinc = 1, minpad = 0, padleft = t + (format-write-field stream signed mincol 1 0 padchar t)) + (princ number stream)))) (defun format-add-commas (string commachar commainterval) (let ((length (length string))) (multiple-value-bind (commas extra) (truncate (1- length) commainterval) (let ((new-string (make-string (+ length commas))) - (first-comma (1+ extra))) - (replace new-string string :end1 first-comma :end2 first-comma) - (do ((src first-comma (+ src commainterval)) - (dst first-comma (+ dst commainterval 1))) - ((= src length)) - (setf (schar new-string dst) commachar) - (replace new-string string :start1 (1+ dst) - :start2 src :end2 (+ src commainterval))) - new-string)))) + (first-comma (1+ extra))) + (replace new-string string :end1 first-comma :end2 first-comma) + (do ((src first-comma (+ src commainterval)) + (dst first-comma (+ dst commainterval 1))) + ((= src length)) + (setf (schar new-string dst) commachar) + (replace new-string string :start1 (1+ dst) + :start2 src :end2 (+ src commainterval))) + new-string)))) ;;; FIXME: This is only needed in this file, could be defined with ;;; SB!XC:DEFMACRO inside EVAL-WHEN (defmacro interpret-format-integer (base) `(if (or colonp atsignp params) (interpret-bind-defaults - ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) - params - (format-print-integer stream (next-arg) colonp atsignp ,base mincol - padchar commachar commainterval)) + ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) + params + (format-print-integer stream (next-arg) colonp atsignp ,base mincol + padchar commachar commainterval)) (write (next-arg) :stream stream :base ,base :radix nil :escape nil))) (def-format-interpreter #\D (colonp atsignp params) @@ -323,7 +323,7 @@ (defparameter *cardinal-tens* #(nil nil "twenty" "thirty" "forty" - "fifty" "sixty" "seventy" "eighty" "ninety")) + "fifty" "sixty" "seventy" "eighty" "ninety")) (defparameter *cardinal-teens* #("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD @@ -338,11 +338,11 @@ (defparameter *ordinal-ones* #(nil "first" "second" "third" "fourth" - "fifth" "sixth" "seventh" "eighth" "ninth")) + "fifth" "sixth" "seventh" "eighth" "ninth")) (defparameter *ordinal-tens* #(nil "tenth" "twentieth" "thirtieth" "fortieth" - "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")) + "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")) (defun format-print-small-cardinal (stream n) (multiple-value-bind (hundreds rem) (truncate n 100) @@ -350,27 +350,27 @@ (write-string (svref *cardinal-ones* hundreds) stream) (write-string " hundred" stream) (when (plusp rem) - (write-char #\space stream))) + (write-char #\space stream))) (when (plusp rem) (multiple-value-bind (tens ones) (truncate rem 10) - (cond ((< 1 tens) - (write-string (svref *cardinal-tens* tens) stream) - (when (plusp ones) - (write-char #\- stream) - (write-string (svref *cardinal-ones* ones) stream))) - ((= tens 1) - (write-string (svref *cardinal-teens* ones) stream)) - ((plusp ones) - (write-string (svref *cardinal-ones* ones) stream))))))) + (cond ((< 1 tens) + (write-string (svref *cardinal-tens* tens) stream) + (when (plusp ones) + (write-char #\- stream) + (write-string (svref *cardinal-ones* ones) stream))) + ((= tens 1) + (write-string (svref *cardinal-teens* ones) stream)) + ((plusp ones) + (write-string (svref *cardinal-ones* ones) stream))))))) (defun format-print-cardinal (stream n) (cond ((minusp n) - (write-string "negative " stream) - (format-print-cardinal-aux stream (- n) 0 n)) - ((zerop n) - (write-string "zero" stream)) - (t - (format-print-cardinal-aux stream n 0 n)))) + (write-string "negative " stream) + (format-print-cardinal-aux stream (- n) 0 n)) + ((zerop n) + (write-string "zero" stream)) + (t + (format-print-cardinal-aux stream n 0 n)))) (defun format-print-cardinal-aux (stream n period err) (multiple-value-bind (beyond here) (truncate n 1000) @@ -380,7 +380,7 @@ (format-print-cardinal-aux stream beyond (1+ period) err)) (unless (zerop here) (unless (zerop beyond) - (write-char #\space stream)) + (write-char #\space stream)) (format-print-small-cardinal stream here) (write-string (svref *cardinal-periods* period) stream)))) @@ -390,26 +390,26 @@ (let ((number (abs n))) (multiple-value-bind (top bot) (truncate number 100) (unless (zerop top) - (format-print-cardinal stream (- number bot))) + (format-print-cardinal stream (- number bot))) (when (and (plusp top) (plusp bot)) - (write-char #\space stream)) + (write-char #\space stream)) (multiple-value-bind (tens ones) (truncate bot 10) - (cond ((= bot 12) (write-string "twelfth" stream)) - ((= tens 1) - (write-string (svref *cardinal-teens* ones) stream);;;RAD - (write-string "th" stream)) - ((and (zerop tens) (plusp ones)) - (write-string (svref *ordinal-ones* ones) stream)) - ((and (zerop ones)(plusp tens)) - (write-string (svref *ordinal-tens* tens) stream)) - ((plusp bot) - (write-string (svref *cardinal-tens* tens) stream) - (write-char #\- stream) - (write-string (svref *ordinal-ones* ones) stream)) - ((plusp number) - (write-string "th" stream)) - (t - (write-string "zeroth" stream))))))) + (cond ((= bot 12) (write-string "twelfth" stream)) + ((= tens 1) + (write-string (svref *cardinal-teens* ones) stream);;;RAD + (write-string "th" stream)) + ((and (zerop tens) (plusp ones)) + (write-string (svref *ordinal-ones* ones) stream)) + ((and (zerop ones)(plusp tens)) + (write-string (svref *ordinal-tens* tens) stream)) + ((plusp bot) + (write-string (svref *cardinal-tens* tens) stream) + (write-char #\- stream) + (write-string (svref *ordinal-ones* ones) stream)) + ((plusp number) + (write-string "th" stream)) + (t + (write-string "zeroth" stream))))))) ;;; Print Roman numerals @@ -421,9 +421,9 @@ (cur-char #\M (car char-list)) (cur-val 1000 (car val-list)) (start n (do ((i start (progn - (write-char cur-char stream) - (- i cur-val)))) - ((< i cur-val) i)))) + (write-char cur-char stream) + (- i cur-val)))) + ((< i cur-val) i)))) ((zerop start)))) (defun format-print-roman (stream n) @@ -438,31 +438,31 @@ (cur-sub-char #\C (car sub-chars)) (cur-sub-val 100 (car sub-val)) (start n (do ((i start (progn - (write-char cur-char stream) - (- i cur-val)))) - ((< i cur-val) - (cond ((<= (- cur-val cur-sub-val) i) - (write-char cur-sub-char stream) - (write-char cur-char stream) - (- i (- cur-val cur-sub-val))) - (t i)))))) - ((zerop start)))) + (write-char cur-char stream) + (- i cur-val)))) + ((< i cur-val) + (cond ((<= (- cur-val cur-sub-val) i) + (write-char cur-sub-char stream) + (write-char cur-char stream) + (- i (- cur-val cur-sub-val))) + (t i)))))) + ((zerop start)))) ;;;; plural (def-format-interpreter #\P (colonp atsignp params) (interpret-bind-defaults () params (let ((arg (if colonp - (if (eq orig-args args) - (error 'format-error - :complaint "no previous argument") - (do ((arg-ptr orig-args (cdr arg-ptr))) - ((eq (cdr arg-ptr) args) - (car arg-ptr)))) - (next-arg)))) + (if (eq orig-args args) + (error 'format-error + :complaint "no previous argument") + (do ((arg-ptr orig-args (cdr arg-ptr))) + ((eq (cdr arg-ptr) args) + (car arg-ptr)))) + (next-arg)))) (if atsignp - (write-string (if (eql arg 1) "y" "ies") stream) - (unless (eql arg 1) (write-char #\s stream)))))) + (write-string (if (eql arg 1) "y" "ies") stream) + (unless (eql arg 1) (write-char #\s stream)))))) ;;;; format interpreters and support functions for floating point output @@ -472,23 +472,23 @@ (def-format-interpreter #\F (colonp atsignp params) (when colonp (error 'format-error - :complaint - "cannot specify the colon modifier with this directive")) + :complaint + "cannot specify the colon modifier with this directive")) (interpret-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) - params + params (format-fixed stream (next-arg) w d k ovf pad atsignp))) (defun format-fixed (stream number w d k ovf pad atsign) (if (numberp number) (if (floatp number) - (format-fixed-aux stream number w d k ovf pad atsign) - (if (rationalp number) - (format-fixed-aux stream - (coerce number 'single-float) - w d k ovf pad atsign) - (format-write-field stream - (decimal-string number) - w 1 0 #\space t))) + (format-fixed-aux stream number w d k ovf pad atsign) + (if (rationalp number) + (format-fixed-aux stream + (coerce number 'single-float) + w d k ovf pad atsign) + (format-write-field stream + (decimal-string number) + w 1 0 #\space t))) (format-princ stream number nil nil w 1 0 pad))) ;;; We return true if we overflowed, so that ~G can output the overflow char @@ -497,50 +497,50 @@ (declare (type float number)) (cond ((and (floatp number) - (or (float-infinity-p number) - (float-nan-p number))) + (or (float-infinity-p number) + (float-nan-p number))) (prin1 number stream) nil) (t (let ((spaceleft w)) - (when (and w (or atsign (minusp (float-sign number)))) - (decf spaceleft)) + (when (and w (or atsign (minusp (float-sign number)))) + (decf spaceleft)) (multiple-value-bind (str len lpoint tpoint) - (sb!impl::flonum-to-string (abs number) spaceleft d k) - ;;if caller specifically requested no fraction digits, suppress the - ;;optional trailing zero - (when (and d (zerop d)) (setq tpoint nil)) - (when w - (decf spaceleft len) - ;;optional leading zero - (when lpoint - (if (or (> spaceleft 0) tpoint) ;force at least one digit - (decf spaceleft) - (setq lpoint nil))) - ;;optional trailing zero - (when tpoint - (if (> spaceleft 0) - (decf spaceleft) - (setq tpoint nil)))) - (cond ((and w (< spaceleft 0) ovf) - ;;field width overflow - (dotimes (i w) (write-char ovf stream)) - t) - (t - (when w (dotimes (i spaceleft) (write-char pad stream))) - (if (minusp (float-sign number)) - (write-char #\- stream) - (if atsign (write-char #\+ stream))) - (when lpoint (write-char #\0 stream)) - (write-string str stream) - (when tpoint (write-char #\0 stream)) - nil))))))) + (sb!impl::flonum-to-string (abs number) spaceleft d k) + ;;if caller specifically requested no fraction digits, suppress the + ;;optional trailing zero + (when (and d (zerop d)) (setq tpoint nil)) + (when w + (decf spaceleft len) + ;;optional leading zero + (when lpoint + (if (or (> spaceleft 0) tpoint) ;force at least one digit + (decf spaceleft) + (setq lpoint nil))) + ;;optional trailing zero + (when tpoint + (if (> spaceleft 0) + (decf spaceleft) + (setq tpoint nil)))) + (cond ((and w (< spaceleft 0) ovf) + ;;field width overflow + (dotimes (i w) (write-char ovf stream)) + t) + (t + (when w (dotimes (i spaceleft) (write-char pad stream))) + (if (minusp (float-sign number)) + (write-char #\- stream) + (if atsign (write-char #\+ stream))) + (when lpoint (write-char #\0 stream)) + (write-string str stream) + (when tpoint (write-char #\0 stream)) + nil))))))) (def-format-interpreter #\E (colonp atsignp params) (when colonp (error 'format-error - :complaint - "cannot specify the colon modifier with this directive")) + :complaint + "cannot specify the colon modifier with this directive")) (interpret-bind-defaults ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil)) params @@ -549,24 +549,24 @@ (defun format-exponential (stream number w d e k ovf pad marker atsign) (if (numberp number) (if (floatp number) - (format-exp-aux stream number w d e k ovf pad marker atsign) - (if (rationalp number) - (format-exp-aux stream - (coerce number 'single-float) - w d e k ovf pad marker atsign) - (format-write-field stream - (decimal-string number) - w 1 0 #\space t))) + (format-exp-aux stream number w d e k ovf pad marker atsign) + (if (rationalp number) + (format-exp-aux stream + (coerce number 'single-float) + w d e k ovf pad marker atsign) + (format-write-field stream + (decimal-string number) + w 1 0 #\space t))) (format-princ stream number nil nil w 1 0 pad))) (defun format-exponent-marker (number) (if (typep number *read-default-float-format*) #\e (typecase number - (single-float #\f) - (double-float #\d) - (short-float #\s) - (long-float #\l)))) + (single-float #\f) + (double-float #\d) + (short-float #\s) + (long-float #\l)))) ;;; Here we prevent the scale factor from shifting all significance out of ;;; a number to the right. We allow insignificant zeroes to be shifted in @@ -583,61 +583,61 @@ (defun format-exp-aux (stream number w d e k ovf pad marker atsign) (declare (type float number)) (if (or (float-infinity-p number) - (float-nan-p number)) + (float-nan-p number)) (prin1 number stream) (multiple-value-bind (num expt) (sb!impl::scale-exponent (abs number)) - (let* ((expt (- expt k)) - (estr (decimal-string (abs expt))) - (elen (if e (max (length estr) e) (length estr))) - (fdig (if d (if (plusp k) (1+ (- d k)) d) nil)) - (fmin (if (minusp k) (- 1 k) nil)) - (spaceleft (if w - (- w 2 elen - (if (or atsign (minusp (float-sign number))) - 1 0)) - nil))) - (if (and w ovf e (> elen e)) ;exponent overflow - (dotimes (i w) (write-char ovf stream)) - (multiple-value-bind (fstr flen lpoint tpoint) - (sb!impl::flonum-to-string num spaceleft fdig k fmin) - (when (and d (zerop d)) (setq tpoint nil)) - (when w - (decf spaceleft flen) - (when lpoint - (if (or (> spaceleft 0) tpoint) - (decf spaceleft) - (setq lpoint nil))) - (when tpoint - (if (> spaceleft 0) - (decf spaceleft) - (setq tpoint nil)))) - (cond ((and w (< spaceleft 0) ovf) - ;;significand overflow - (dotimes (i w) (write-char ovf stream))) - (t (when w - (dotimes (i spaceleft) (write-char pad stream))) - (if (minusp (float-sign number)) - (write-char #\- stream) - (if atsign (write-char #\+ stream))) - (when lpoint (write-char #\0 stream)) - (write-string fstr stream) - (when tpoint (write-char #\0 stream)) - (write-char (if marker - marker - (format-exponent-marker number)) - stream) - (write-char (if (minusp expt) #\- #\+) stream) - (when e - ;;zero-fill before exponent if necessary - (dotimes (i (- e (length estr))) - (write-char #\0 stream))) - (write-string estr stream))))))))) + (let* ((expt (- expt k)) + (estr (decimal-string (abs expt))) + (elen (if e (max (length estr) e) (length estr))) + (fdig (if d (if (plusp k) (1+ (- d k)) d) nil)) + (fmin (if (minusp k) (- 1 k) nil)) + (spaceleft (if w + (- w 2 elen + (if (or atsign (minusp (float-sign number))) + 1 0)) + nil))) + (if (and w ovf e (> elen e)) ;exponent overflow + (dotimes (i w) (write-char ovf stream)) + (multiple-value-bind (fstr flen lpoint tpoint) + (sb!impl::flonum-to-string num spaceleft fdig k fmin) + (when (and d (zerop d)) (setq tpoint nil)) + (when w + (decf spaceleft flen) + (when lpoint + (if (or (> spaceleft 0) tpoint) + (decf spaceleft) + (setq lpoint nil))) + (when tpoint + (if (> spaceleft 0) + (decf spaceleft) + (setq tpoint nil)))) + (cond ((and w (< spaceleft 0) ovf) + ;;significand overflow + (dotimes (i w) (write-char ovf stream))) + (t (when w + (dotimes (i spaceleft) (write-char pad stream))) + (if (minusp (float-sign number)) + (write-char #\- stream) + (if atsign (write-char #\+ stream))) + (when lpoint (write-char #\0 stream)) + (write-string fstr stream) + (when tpoint (write-char #\0 stream)) + (write-char (if marker + marker + (format-exponent-marker number)) + stream) + (write-char (if (minusp expt) #\- #\+) stream) + (when e + ;;zero-fill before exponent if necessary + (dotimes (i (- e (length estr))) + (write-char #\0 stream))) + (write-string estr stream))))))))) (def-format-interpreter #\G (colonp atsignp params) (when colonp (error 'format-error - :complaint - "cannot specify the colon modifier with this directive")) + :complaint + "cannot specify the colon modifier with this directive")) (interpret-bind-defaults ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil)) params @@ -646,46 +646,46 @@ (defun format-general (stream number w d e k ovf pad marker atsign) (if (numberp number) (if (floatp number) - (format-general-aux stream number w d e k ovf pad marker atsign) - (if (rationalp number) - (format-general-aux stream - (coerce number 'single-float) - w d e k ovf pad marker atsign) - (format-write-field stream - (decimal-string number) - w 1 0 #\space t))) + (format-general-aux stream number w d e k ovf pad marker atsign) + (if (rationalp number) + (format-general-aux stream + (coerce number 'single-float) + w d e k ovf pad marker atsign) + (format-write-field stream + (decimal-string number) + w 1 0 #\space t))) (format-princ stream number nil nil w 1 0 pad))) ;;; Raymond Toy writes: same change as for format-exp-aux (defun format-general-aux (stream number w d e k ovf pad marker atsign) (declare (type float number)) (if (or (float-infinity-p number) - (float-nan-p number)) + (float-nan-p number)) (prin1 number stream) (multiple-value-bind (ignore n) (sb!impl::scale-exponent (abs number)) - (declare (ignore ignore)) - ;; KLUDGE: Default d if omitted. The procedure is taken directly from - ;; the definition given in the manual, and is not very efficient, since - ;; we generate the digits twice. Future maintainers are encouraged to - ;; improve on this. -- rtoy?? 1998?? - (unless d - (multiple-value-bind (str len) - (sb!impl::flonum-to-string (abs number)) - (declare (ignore str)) - (let ((q (if (= len 1) 1 (1- len)))) - (setq d (max q (min n 7)))))) - (let* ((ee (if e (+ e 2) 4)) - (ww (if w (- w ee) nil)) - (dd (- d n))) - (cond ((<= 0 dd d) - (let ((char (if (format-fixed-aux stream number ww dd nil - ovf pad atsign) - ovf - #\space))) - (dotimes (i ee) (write-char char stream)))) - (t - (format-exp-aux stream number w d e (or k 1) - ovf pad marker atsign))))))) + (declare (ignore ignore)) + ;; KLUDGE: Default d if omitted. The procedure is taken directly from + ;; the definition given in the manual, and is not very efficient, since + ;; we generate the digits twice. Future maintainers are encouraged to + ;; improve on this. -- rtoy?? 1998?? + (unless d + (multiple-value-bind (str len) + (sb!impl::flonum-to-string (abs number)) + (declare (ignore str)) + (let ((q (if (= len 1) 1 (1- len)))) + (setq d (max q (min n 7)))))) + (let* ((ee (if e (+ e 2) 4)) + (ww (if w (- w ee) nil)) + (dd (- d n))) + (cond ((<= 0 dd d) + (let ((char (if (format-fixed-aux stream number ww dd nil + ovf pad atsign) + ovf + #\space))) + (dotimes (i ee) (write-char char stream)))) + (t + (format-exp-aux stream number w d e (or k 1) + ovf pad marker atsign))))))) (def-format-interpreter #\$ (colonp atsignp params) (interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params @@ -699,33 +699,33 @@ ;; thing, and at least the user shouldn't be surprised. (setq number (coerce number 'single-float))) (if (floatp number) - (let* ((signstr (if (minusp (float-sign number)) - "-" - (if atsign "+" ""))) - (signlen (length signstr))) - (multiple-value-bind (str strlen ig2 ig3 pointplace) + (let* ((signstr (if (minusp (float-sign number)) + "-" + (if atsign "+" ""))) + (signlen (length signstr))) + (multiple-value-bind (str strlen ig2 ig3 pointplace) (sb!impl::flonum-to-string number nil d nil) - (declare (ignore ig2 ig3 strlen)) - (when colon - (write-string signstr stream)) - (dotimes (i (- w signlen (max n pointplace) 1 d)) - (write-char pad stream)) - (unless colon - (write-string signstr stream)) - (dotimes (i (- n pointplace)) - (write-char #\0 stream)) - (write-string str stream))) + (declare (ignore ig2 ig3 strlen)) + (when colon + (write-string signstr stream)) + (dotimes (i (- w signlen (max n pointplace) 1 d)) + (write-char pad stream)) + (unless colon + (write-string signstr stream)) + (dotimes (i (- n pointplace)) + (write-char #\0 stream)) + (write-string str stream))) (format-write-field stream - (decimal-string number) - w 1 0 #\space t))) + (decimal-string number) + w 1 0 #\space t))) ;;;; FORMAT interpreters and support functions for line/page breaks etc. (def-format-interpreter #\% (colonp atsignp params) (when (or colonp atsignp) (error 'format-error - :complaint - "cannot specify either colon or atsign for this directive")) + :complaint + "cannot specify either colon or atsign for this directive")) (interpret-bind-defaults ((count 1)) params (dotimes (i count) (terpri stream)))) @@ -733,8 +733,8 @@ (def-format-interpreter #\& (colonp atsignp params) (when (or colonp atsignp) (error 'format-error - :complaint - "cannot specify either colon or atsign for this directive")) + :complaint + "cannot specify either colon or atsign for this directive")) (interpret-bind-defaults ((count 1)) params (fresh-line stream) (dotimes (i (1- count)) @@ -743,8 +743,8 @@ (def-format-interpreter #\| (colonp atsignp params) (when (or colonp atsignp) (error 'format-error - :complaint - "cannot specify either colon or atsign for this directive")) + :complaint + "cannot specify either colon or atsign for this directive")) (interpret-bind-defaults ((count 1)) params (dotimes (i count) (write-char (code-char form-feed-char-code) stream)))) @@ -752,8 +752,8 @@ (def-format-interpreter #\~ (colonp atsignp params) (when (or colonp atsignp) (error 'format-error - :complaint - "cannot specify either colon or atsign for this directive")) + :complaint + "cannot specify either colon or atsign for this directive")) (interpret-bind-defaults ((count 1)) params (dotimes (i count) (write-char #\~ stream)))) @@ -761,17 +761,17 @@ (def-complex-format-interpreter #\newline (colonp atsignp params directives) (when (and colonp atsignp) (error 'format-error - :complaint - "cannot specify both colon and atsign for this directive")) + :complaint + "cannot specify both colon and atsign for this directive")) (interpret-bind-defaults () params (when atsignp (write-char #\newline stream))) (if (and (not colonp) - directives - (simple-string-p (car directives))) + directives + (simple-string-p (car directives))) (cons (string-left-trim *format-whitespace-chars* - (car directives)) - (cdr directives)) + (car directives)) + (cdr directives)) directives)) ;;;; format interpreters and support functions for tabs and simple pretty @@ -780,18 +780,18 @@ (def-format-interpreter #\T (colonp atsignp params) (if colonp (interpret-bind-defaults ((n 1) (m 1)) params - (pprint-tab (if atsignp :section-relative :section) n m stream)) + (pprint-tab (if atsignp :section-relative :section) n m stream)) (if atsignp - (interpret-bind-defaults ((colrel 1) (colinc 1)) params - (format-relative-tab stream colrel colinc)) - (interpret-bind-defaults ((colnum 1) (colinc 1)) params - (format-absolute-tab stream colnum colinc))))) + (interpret-bind-defaults ((colrel 1) (colinc 1)) params + (format-relative-tab stream colrel colinc)) + (interpret-bind-defaults ((colnum 1) (colinc 1)) params + (format-absolute-tab stream colnum colinc))))) (defun output-spaces (stream n) (let ((spaces #.(make-string 100 :initial-element #\space))) (loop (when (< n (length spaces)) - (return)) + (return)) (write-string spaces stream) (decf n (length spaces))) (write-string spaces stream :end n))) @@ -800,39 +800,39 @@ (if (sb!pretty:pretty-stream-p stream) (pprint-tab :line-relative colrel colinc stream) (let* ((cur (sb!impl::charpos stream)) - (spaces (if (and cur (plusp colinc)) - (- (* (ceiling (+ cur colrel) colinc) colinc) cur) - colrel))) - (output-spaces stream spaces)))) + (spaces (if (and cur (plusp colinc)) + (- (* (ceiling (+ cur colrel) colinc) colinc) cur) + colrel))) + (output-spaces stream spaces)))) (defun format-absolute-tab (stream colnum colinc) (if (sb!pretty:pretty-stream-p stream) (pprint-tab :line colnum colinc stream) (let ((cur (sb!impl::charpos stream))) - (cond ((null cur) - (write-string " " stream)) - ((< cur colnum) - (output-spaces stream (- colnum cur))) - (t - (unless (zerop colinc) - (output-spaces stream - (- colinc (rem (- cur colnum) colinc))))))))) + (cond ((null cur) + (write-string " " stream)) + ((< cur colnum) + (output-spaces stream (- colnum cur))) + (t + (unless (zerop colinc) + (output-spaces stream + (- colinc (rem (- cur colnum) colinc))))))))) (def-format-interpreter #\_ (colonp atsignp params) (interpret-bind-defaults () params (pprint-newline (if colonp - (if atsignp - :mandatory - :fill) - (if atsignp - :miser - :linear)) - stream))) + (if atsignp + :mandatory + :fill) + (if atsignp + :miser + :linear)) + stream))) (def-format-interpreter #\I (colonp atsignp params) (when atsignp (error 'format-error - :complaint "cannot specify the at-sign modifier")) + :complaint "cannot specify the at-sign modifier")) (interpret-bind-defaults ((n 0)) params (pprint-indent (if colonp :current :block) n stream))) @@ -841,53 +841,53 @@ (def-format-interpreter #\* (colonp atsignp params) (if atsignp (if colonp - (error 'format-error - :complaint "cannot specify both colon and at-sign") - (interpret-bind-defaults ((posn 0)) params - (if (<= 0 posn (length orig-args)) - (setf args (nthcdr posn orig-args)) - (error 'format-error - :complaint "Index ~W is out of bounds. (It should ~ + (error 'format-error + :complaint "cannot specify both colon and at-sign") + (interpret-bind-defaults ((posn 0)) params + (if (<= 0 posn (length orig-args)) + (setf args (nthcdr posn orig-args)) + (error 'format-error + :complaint "Index ~W is out of bounds. (It should ~ have been between 0 and ~W.)" - :args (list posn (length orig-args)))))) + :args (list posn (length orig-args)))))) (if colonp - (interpret-bind-defaults ((n 1)) params - (do ((cur-posn 0 (1+ cur-posn)) - (arg-ptr orig-args (cdr arg-ptr))) - ((eq arg-ptr args) - (let ((new-posn (- cur-posn n))) - (if (<= 0 new-posn (length orig-args)) - (setf args (nthcdr new-posn orig-args)) - (error 'format-error - :complaint - "Index ~W is out of bounds. (It should + (interpret-bind-defaults ((n 1)) params + (do ((cur-posn 0 (1+ cur-posn)) + (arg-ptr orig-args (cdr arg-ptr))) + ((eq arg-ptr args) + (let ((new-posn (- cur-posn n))) + (if (<= 0 new-posn (length orig-args)) + (setf args (nthcdr new-posn orig-args)) + (error 'format-error + :complaint + "Index ~W is out of bounds. (It should have been between 0 and ~W.)" - :args - (list new-posn (length orig-args)))))))) - (interpret-bind-defaults ((n 1)) params - (dotimes (i n) - (next-arg)))))) + :args + (list new-posn (length orig-args)))))))) + (interpret-bind-defaults ((n 1)) params + (dotimes (i n) + (next-arg)))))) ;;;; format interpreter for indirection (def-format-interpreter #\? (colonp atsignp params string end) (when colonp (error 'format-error - :complaint "cannot specify the colon modifier")) + :complaint "cannot specify the colon modifier")) (interpret-bind-defaults () params (handler-bind - ((format-error - (lambda (condition) - (error 'format-error - :complaint - "~A~%while processing indirect format string:" - :args (list condition) - :print-banner nil - :control-string string - :offset (1- end))))) + ((format-error + (lambda (condition) + (error 'format-error + :complaint + "~A~%while processing indirect format string:" + :args (list condition) + :print-banner nil + :control-string string + :offset (1- end))))) (if atsignp - (setf args (%format stream (next-arg) orig-args args)) - (%format stream (next-arg) (next-arg)))))) + (setf args (%format stream (next-arg) orig-args args)) + (%format stream (next-arg) (next-arg)))))) ;;;; format interpreters for capitalization @@ -895,25 +895,25 @@ (let ((close (find-directive directives #\) nil))) (unless close (error 'format-error - :complaint "no corresponding close paren")) + :complaint "no corresponding close paren")) (interpret-bind-defaults () params (let* ((posn (position close directives)) - (before (subseq directives 0 posn)) - (after (nthcdr (1+ posn) directives)) - (stream (make-case-frob-stream stream - (if colonp - (if atsignp - :upcase - :capitalize) - (if atsignp - :capitalize-first - :downcase))))) - (setf args (interpret-directive-list stream before orig-args args)) - after)))) + (before (subseq directives 0 posn)) + (after (nthcdr (1+ posn) directives)) + (stream (make-case-frob-stream stream + (if colonp + (if atsignp + :upcase + :capitalize) + (if atsignp + :capitalize-first + :downcase))))) + (setf args (interpret-directive-list stream before orig-args args)) + after)))) (def-complex-format-interpreter #\) () (error 'format-error - :complaint "no corresponding open paren")) + :complaint "no corresponding open paren")) ;;;; format interpreters and support functions for conditionalization @@ -921,56 +921,56 @@ (multiple-value-bind (sublists last-semi-with-colon-p remaining) (parse-conditional-directive directives) (setf args - (if atsignp - (if colonp - (error 'format-error - :complaint - "cannot specify both the colon and at-sign modifiers") - (if (cdr sublists) - (error 'format-error - :complaint - "can only specify one section") - (interpret-bind-defaults () params - (let ((prev-args args) - (arg (next-arg))) - (if arg - (interpret-directive-list stream - (car sublists) - orig-args - prev-args) - args))))) - (if colonp - (if (= (length sublists) 2) - (interpret-bind-defaults () params - (if (next-arg) - (interpret-directive-list stream (car sublists) - orig-args args) - (interpret-directive-list stream (cadr sublists) - orig-args args))) - (error 'format-error - :complaint - "must specify exactly two sections")) - (interpret-bind-defaults ((index (next-arg))) params - (let* ((default (and last-semi-with-colon-p - (pop sublists))) - (last (1- (length sublists))) - (sublist - (if (<= 0 index last) - (nth (- last index) sublists) - default))) - (interpret-directive-list stream sublist orig-args - args)))))) + (if atsignp + (if colonp + (error 'format-error + :complaint + "cannot specify both the colon and at-sign modifiers") + (if (cdr sublists) + (error 'format-error + :complaint + "can only specify one section") + (interpret-bind-defaults () params + (let ((prev-args args) + (arg (next-arg))) + (if arg + (interpret-directive-list stream + (car sublists) + orig-args + prev-args) + args))))) + (if colonp + (if (= (length sublists) 2) + (interpret-bind-defaults () params + (if (next-arg) + (interpret-directive-list stream (car sublists) + orig-args args) + (interpret-directive-list stream (cadr sublists) + orig-args args))) + (error 'format-error + :complaint + "must specify exactly two sections")) + (interpret-bind-defaults ((index (next-arg))) params + (let* ((default (and last-semi-with-colon-p + (pop sublists))) + (last (1- (length sublists))) + (sublist + (if (<= 0 index last) + (nth (- last index) sublists) + default))) + (interpret-directive-list stream sublist orig-args + args)))))) remaining)) (def-complex-format-interpreter #\; () (error 'format-error - :complaint - "~~; not contained within either ~~[...~~] or ~~<...~~>")) + :complaint + "~~; not contained within either ~~[...~~] or ~~<...~~>")) (def-complex-format-interpreter #\] () (error 'format-error - :complaint - "no corresponding open bracket")) + :complaint + "no corresponding open bracket")) ;;;; format interpreter for up-and-out @@ -979,10 +979,10 @@ (def-format-interpreter #\^ (colonp atsignp params) (when atsignp (error 'format-error - :complaint "cannot specify the at-sign modifier")) + :complaint "cannot specify the at-sign modifier")) (when (and colonp (not *up-up-and-out-allowed*)) (error 'format-error - :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct")) + :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct")) (when (interpret-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params (cond (arg3 (<= arg1 arg2 arg3)) (arg2 (eql arg1 arg2)) @@ -991,97 +991,97 @@ (null *outside-args*) (null args))))) (throw (if colonp 'up-up-and-out 'up-and-out) - args))) + args))) ;;;; format interpreters for iteration (def-complex-format-interpreter #\{ - (colonp atsignp params string end directives) + (colonp atsignp params string end directives) (let ((close (find-directive directives #\} nil))) (unless close (error 'format-error - :complaint - "no corresponding close brace")) + :complaint + "no corresponding close brace")) (interpret-bind-defaults ((max-count nil)) params (let* ((closed-with-colon (format-directive-colonp close)) - (posn (position close directives)) - (insides (if (zerop posn) - (next-arg) - (subseq directives 0 posn))) - (*up-up-and-out-allowed* colonp)) - (labels - ((do-guts (orig-args args) - (if (zerop posn) - (handler-bind - ((format-error - (lambda (condition) - (error - 'format-error - :complaint - "~A~%while processing indirect format string:" - :args (list condition) - :print-banner nil - :control-string string - :offset (1- end))))) - (%format stream insides orig-args args)) - (interpret-directive-list stream insides - orig-args args))) - (bind-args (orig-args args) - (if colonp - (let* ((arg (next-arg)) - (*logical-block-popper* nil) - (*outside-args* args)) - (catch 'up-and-out - (do-guts arg arg)) + (posn (position close directives)) + (insides (if (zerop posn) + (next-arg) + (subseq directives 0 posn))) + (*up-up-and-out-allowed* colonp)) + (labels + ((do-guts (orig-args args) + (if (zerop posn) + (handler-bind + ((format-error + (lambda (condition) + (error + 'format-error + :complaint + "~A~%while processing indirect format string:" + :args (list condition) + :print-banner nil + :control-string string + :offset (1- end))))) + (%format stream insides orig-args args)) + (interpret-directive-list stream insides + orig-args args))) + (bind-args (orig-args args) + (if colonp + (let* ((arg (next-arg)) + (*logical-block-popper* nil) + (*outside-args* args)) + (catch 'up-and-out + (do-guts arg arg)) args) - (do-guts orig-args args))) - (do-loop (orig-args args) - (catch (if colonp 'up-up-and-out 'up-and-out) - (loop - (when (and (not closed-with-colon) (null args)) - (return)) - (when (and max-count (minusp (decf max-count))) - (return)) - (setf args (bind-args orig-args args)) - (when (and closed-with-colon (null args)) - (return))) - args))) - (if atsignp - (setf args (do-loop orig-args args)) - (let ((arg (next-arg)) - (*logical-block-popper* nil)) - (do-loop arg arg))) - (nthcdr (1+ posn) directives)))))) + (do-guts orig-args args))) + (do-loop (orig-args args) + (catch (if colonp 'up-up-and-out 'up-and-out) + (loop + (when (and (not closed-with-colon) (null args)) + (return)) + (when (and max-count (minusp (decf max-count))) + (return)) + (setf args (bind-args orig-args args)) + (when (and closed-with-colon (null args)) + (return))) + args))) + (if atsignp + (setf args (do-loop orig-args args)) + (let ((arg (next-arg)) + (*logical-block-popper* nil)) + (do-loop arg arg))) + (nthcdr (1+ posn) directives)))))) (def-complex-format-interpreter #\} () (error 'format-error - :complaint "no corresponding open brace")) + :complaint "no corresponding open brace")) ;;;; format interpreters and support functions for justification (def-complex-format-interpreter #\< - (colonp atsignp params string end directives) + (colonp atsignp params string end directives) (multiple-value-bind (segments first-semi close remaining) (parse-format-justification directives) (setf args - (if (format-directive-colonp close) - (multiple-value-bind (prefix per-line-p insides suffix) - (parse-format-logical-block segments colonp first-semi - close params string end) - (interpret-format-logical-block stream orig-args args - prefix per-line-p insides - suffix atsignp)) - (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments)))) - (when (> count 0) - ;; ANSI specifies that "an error is signalled" in this - ;; situation. - (error 'format-error - :complaint "~D illegal directive~:P found inside justification block" - :args (list count) + (if (format-directive-colonp close) + (multiple-value-bind (prefix per-line-p insides suffix) + (parse-format-logical-block segments colonp first-semi + close params string end) + (interpret-format-logical-block stream orig-args args + prefix per-line-p insides + suffix atsignp)) + (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments)))) + (when (> count 0) + ;; ANSI specifies that "an error is signalled" in this + ;; situation. + (error 'format-error + :complaint "~D illegal directive~:P found inside justification block" + :args (list count) :references (list '(:ansi-cl :section (22 3 5 2))))) - (interpret-format-justification stream orig-args args - segments colonp atsignp - first-semi params)))) + (interpret-format-justification stream orig-args args + segments colonp atsignp + first-semi params)))) remaining)) (defun interpret-format-justification @@ -1090,88 +1090,88 @@ ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) params (let ((newline-string nil) - (strings nil) - (extra-space 0) - (line-len 0)) + (strings nil) + (extra-space 0) + (line-len 0)) (setf args - (catch 'up-and-out - (when (and first-semi (format-directive-colonp first-semi)) - (interpret-bind-defaults - ((extra 0) - (len (or (sb!impl::line-length stream) 72))) - (format-directive-params first-semi) - (setf newline-string - (with-output-to-string (stream) - (setf args - (interpret-directive-list stream - (pop segments) - orig-args - args)))) - (setf extra-space extra) - (setf line-len len))) - (dolist (segment segments) - (push (with-output-to-string (stream) - (setf args - (interpret-directive-list stream segment - orig-args args))) - strings)) - args)) + (catch 'up-and-out + (when (and first-semi (format-directive-colonp first-semi)) + (interpret-bind-defaults + ((extra 0) + (len (or (sb!impl::line-length stream) 72))) + (format-directive-params first-semi) + (setf newline-string + (with-output-to-string (stream) + (setf args + (interpret-directive-list stream + (pop segments) + orig-args + args)))) + (setf extra-space extra) + (setf line-len len))) + (dolist (segment segments) + (push (with-output-to-string (stream) + (setf args + (interpret-directive-list stream segment + orig-args args))) + strings)) + args)) (format-justification stream newline-string extra-space line-len strings - colonp atsignp mincol colinc minpad padchar))) + colonp atsignp mincol colinc minpad padchar))) args) (defun format-justification (stream newline-prefix extra-space line-len strings - pad-left pad-right mincol colinc minpad padchar) + pad-left pad-right mincol colinc minpad padchar) (setf strings (reverse strings)) (let* ((num-gaps (+ (1- (length strings)) - (if pad-left 1 0) - (if pad-right 1 0))) - (chars (+ (* num-gaps minpad) - (loop - for string in strings - summing (length string)))) - (length (if (> chars mincol) - (+ mincol (* (ceiling (- chars mincol) colinc) colinc)) - mincol)) - (padding (+ (- length chars) (* num-gaps minpad)))) + (if pad-left 1 0) + (if pad-right 1 0))) + (chars (+ (* num-gaps minpad) + (loop + for string in strings + summing (length string)))) + (length (if (> chars mincol) + (+ mincol (* (ceiling (- chars mincol) colinc) colinc)) + mincol)) + (padding (+ (- length chars) (* num-gaps minpad)))) (when (and newline-prefix - (> (+ (or (sb!impl::charpos stream) 0) - length extra-space) - line-len)) + (> (+ (or (sb!impl::charpos stream) 0) + length extra-space) + line-len)) (write-string newline-prefix stream)) (flet ((do-padding () - (let ((pad-len + (let ((pad-len (if (zerop num-gaps) padding (truncate padding num-gaps)))) - (decf padding pad-len) - (decf num-gaps) - (dotimes (i pad-len) (write-char padchar stream))))) + (decf padding pad-len) + (decf num-gaps) + (dotimes (i pad-len) (write-char padchar stream))))) (when (or pad-left (and (not pad-right) (null (cdr strings)))) - (do-padding)) + (do-padding)) (when strings - (write-string (car strings) stream) - (dolist (string (cdr strings)) - (do-padding) - (write-string string stream))) + (write-string (car strings) stream) + (dolist (string (cdr strings)) + (do-padding) + (write-string string stream))) (when pad-right - (do-padding))))) + (do-padding))))) (defun interpret-format-logical-block (stream orig-args args prefix per-line-p insides suffix atsignp) (let ((arg (if atsignp args (next-arg)))) (if per-line-p - (pprint-logical-block - (stream arg :per-line-prefix prefix :suffix suffix) - (let ((*logical-block-popper* (lambda () (pprint-pop)))) - (catch 'up-and-out - (interpret-directive-list stream insides - (if atsignp orig-args arg) - arg)))) - (pprint-logical-block (stream arg :prefix prefix :suffix suffix) - (let ((*logical-block-popper* (lambda () (pprint-pop)))) - (catch 'up-and-out - (interpret-directive-list stream insides - (if atsignp orig-args arg) - arg)))))) + (pprint-logical-block + (stream arg :per-line-prefix prefix :suffix suffix) + (let ((*logical-block-popper* (lambda () (pprint-pop)))) + (catch 'up-and-out + (interpret-directive-list stream insides + (if atsignp orig-args arg) + arg)))) + (pprint-logical-block (stream arg :prefix prefix :suffix suffix) + (let ((*logical-block-popper* (lambda () (pprint-pop)))) + (catch 'up-and-out + (interpret-directive-list stream insides + (if atsignp orig-args arg) + arg)))))) (if atsignp nil args)) ;;;; format interpreter and support functions for user-defined method @@ -1180,9 +1180,9 @@ (let ((symbol (extract-user-fun-name string start end))) (collect ((args)) (dolist (param-and-offset params) - (let ((param (cdr param-and-offset))) - (case param - (:arg (args (next-arg))) - (:remaining (args (length args))) - (t (args param))))) + (let ((param (cdr param-and-offset))) + (case param + (:arg (args (next-arg))) + (:remaining (args (length args))) + (t (args param))))) (apply (fdefinition symbol) stream (next-arg) colonp atsignp (args))))) diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index 70d6ddb..5adefc9 100644 --- a/src/code/target-hash-table.lisp +++ b/src/code/target-hash-table.lisp @@ -34,7 +34,7 @@ (defun eq-hash (key) (declare (values hash (member t nil))) (values (pointer-hash key) - (oddp (get-lisp-obj-address key)))) + (oddp (get-lisp-obj-address key)))) #!-sb-fluid (declaim (inline equal-hash)) (defun equal-hash (key) @@ -72,10 +72,10 @@ #!+sb-doc "Define a new kind of hash table test." (declare (type symbol name) - (type function test-fun hash-fun)) + (type function test-fun hash-fun)) (setf *hash-table-tests* - (cons (list name test-fun hash-fun) - (remove name *hash-table-tests* :test #'eq :key #'car))) + (cons (list name test-fun hash-fun) + (remove name *hash-table-tests* :test #'eq :key #'car))) name) ;;;; construction and simple accessors @@ -88,10 +88,10 @@ (defconstant +magic-hash-vector-value+ #x80000000) (defun make-hash-table (&key (test 'eql) - (size +min-hash-table-size+) - (rehash-size 1.5) - (rehash-threshold 1) - (weak-p nil)) + (size +min-hash-table-size+) + (rehash-size 1.5) + (rehash-threshold 1) + (weak-p nil)) #!+sb-doc "Create and return a new hash table. The keywords are as follows: :TEST -- Indicates what kind of test to use. @@ -114,38 +114,38 @@ (error "stub: unsupported WEAK-P option")) (multiple-value-bind (test test-fun hash-fun) (cond ((or (eq test #'eq) (eq test 'eq)) - (values 'eq #'eq #'eq-hash)) - ((or (eq test #'eql) (eq test 'eql)) - (values 'eql #'eql #'eql-hash)) - ((or (eq test #'equal) (eq test 'equal)) - (values 'equal #'equal #'equal-hash)) - ((or (eq test #'equalp) (eq test 'equalp)) - (values 'equalp #'equalp #'equalp-hash)) - (t - ;; FIXME: I'd like to remove *HASH-TABLE-TESTS* stuff. - ;; Failing that, I'd like to rename it to - ;; *USER-HASH-TABLE-TESTS*. - (dolist (info *hash-table-tests* - (error "unknown :TEST for MAKE-HASH-TABLE: ~S" - test)) - (destructuring-bind (test-name test-fun hash-fun) info - (when (or (eq test test-name) (eq test test-fun)) - (return (values test-name test-fun hash-fun))))))) + (values 'eq #'eq #'eq-hash)) + ((or (eq test #'eql) (eq test 'eql)) + (values 'eql #'eql #'eql-hash)) + ((or (eq test #'equal) (eq test 'equal)) + (values 'equal #'equal #'equal-hash)) + ((or (eq test #'equalp) (eq test 'equalp)) + (values 'equalp #'equalp #'equalp-hash)) + (t + ;; FIXME: I'd like to remove *HASH-TABLE-TESTS* stuff. + ;; Failing that, I'd like to rename it to + ;; *USER-HASH-TABLE-TESTS*. + (dolist (info *hash-table-tests* + (error "unknown :TEST for MAKE-HASH-TABLE: ~S" + test)) + (destructuring-bind (test-name test-fun hash-fun) info + (when (or (eq test test-name) (eq test test-fun)) + (return (values test-name test-fun hash-fun))))))) (let* ((size (max +min-hash-table-size+ - (min size - ;; SIZE is just a hint, so if the user asks - ;; for a SIZE which'd be too big for us to - ;; easily implement, we bump it down. - (floor array-dimension-limit 1024)))) - (rehash-size (if (integerp rehash-size) - rehash-size - (float rehash-size 1.0))) - ;; FIXME: Original REHASH-THRESHOLD default should be 1.0, - ;; not 1, to make it easier for the compiler to avoid - ;; boxing. - (rehash-threshold (max +min-hash-table-rehash-threshold+ - (float rehash-threshold 1.0))) - (size+1 (1+ size)) ; The first element is not usable. + (min size + ;; SIZE is just a hint, so if the user asks + ;; for a SIZE which'd be too big for us to + ;; easily implement, we bump it down. + (floor array-dimension-limit 1024)))) + (rehash-size (if (integerp rehash-size) + rehash-size + (float rehash-size 1.0))) + ;; FIXME: Original REHASH-THRESHOLD default should be 1.0, + ;; not 1, to make it easier for the compiler to avoid + ;; boxing. + (rehash-threshold (max +min-hash-table-rehash-threshold+ + (float rehash-threshold 1.0))) + (size+1 (1+ size)) ; The first element is not usable. ;; KLUDGE: The most natural way of expressing the below is ;; (round (/ (float size+1) rehash-threshold)), and indeed ;; it was expressed like that until 0.7.0. However, @@ -154,43 +154,43 @@ ;; but only for truncating; therefore, we fudge this issue ;; a little. The other uses of truncate, below, similarly ;; used to be round. -- CSR, 2002-10-01 - ;; - ;; Note that this has not yet been audited for - ;; correctness. It just seems to work. -- CSR, 2002-11-02 - (scaled-size (truncate (/ (float size+1) rehash-threshold))) - (length (almost-primify (max scaled-size - (1+ +min-hash-table-size+)))) - (index-vector (make-array length - :element-type - '(unsigned-byte #.sb!vm:n-word-bits) - :initial-element 0)) - ;; needs to be the same length as the KV vector + ;; + ;; Note that this has not yet been audited for + ;; correctness. It just seems to work. -- CSR, 2002-11-02 + (scaled-size (truncate (/ (float size+1) rehash-threshold))) + (length (almost-primify (max scaled-size + (1+ +min-hash-table-size+)))) + (index-vector (make-array length + :element-type + '(unsigned-byte #.sb!vm:n-word-bits) + :initial-element 0)) + ;; needs to be the same length as the KV vector ;; (FIXME: really? why doesn't the code agree?) - (next-vector (make-array size+1 - :element-type - '(unsigned-byte #.sb!vm:n-word-bits))) - (kv-vector (make-array (* 2 size+1) - :initial-element +empty-ht-slot+)) - (table (%make-hash-table - :test test - :test-fun test-fun - :hash-fun hash-fun - :rehash-size rehash-size - :rehash-threshold rehash-threshold - :rehash-trigger size - :table kv-vector - :weak-p weak-p - :index-vector index-vector - :next-vector next-vector - :hash-vector (unless (eq test 'eq) - (make-array size+1 - :element-type '(unsigned-byte #.sb!vm:n-word-bits) - :initial-element +magic-hash-vector-value+))))) + (next-vector (make-array size+1 + :element-type + '(unsigned-byte #.sb!vm:n-word-bits))) + (kv-vector (make-array (* 2 size+1) + :initial-element +empty-ht-slot+)) + (table (%make-hash-table + :test test + :test-fun test-fun + :hash-fun hash-fun + :rehash-size rehash-size + :rehash-threshold rehash-threshold + :rehash-trigger size + :table kv-vector + :weak-p weak-p + :index-vector index-vector + :next-vector next-vector + :hash-vector (unless (eq test 'eq) + (make-array size+1 + :element-type '(unsigned-byte #.sb!vm:n-word-bits) + :initial-element +magic-hash-vector-value+))))) (declare (type index size+1 scaled-size length)) ;; Set up the free list, all free. These lists are 0 terminated. (do ((i 1 (1+ i))) - ((>= i size)) - (setf (aref next-vector i) (1+ i))) + ((>= i size)) + (setf (aref next-vector i) (1+ i))) (setf (aref next-vector size) 0) (setf (hash-table-next-free-kv table) 1) (setf (hash-table-needing-rehash table) 0) @@ -201,7 +201,7 @@ #!+sb-doc "Return the number of entries in the given HASH-TABLE." (declare (type hash-table hash-table) - (values index)) + (values index)) (hash-table-number-entries hash-table)) #!+sb-doc @@ -235,32 +235,32 @@ (defun rehash (table) (declare (type hash-table table)) (let* ((old-kv-vector (hash-table-table table)) - (old-next-vector (hash-table-next-vector table)) - (old-hash-vector (hash-table-hash-vector table)) - (old-size (length old-next-vector)) - (new-size - (let ((rehash-size (hash-table-rehash-size table))) - (etypecase rehash-size - (fixnum - (+ rehash-size old-size)) - (float - (the index (truncate (* rehash-size old-size))))))) - (new-kv-vector (make-array (* 2 new-size) - :initial-element +empty-ht-slot+)) - (new-next-vector (make-array new-size - :element-type '(unsigned-byte #.sb!vm:n-word-bits) - :initial-element 0)) - (new-hash-vector (when old-hash-vector - (make-array new-size - :element-type '(unsigned-byte #.sb!vm:n-word-bits) - :initial-element +magic-hash-vector-value+))) - (old-index-vector (hash-table-index-vector table)) - (new-length (almost-primify - (truncate (/ (float new-size) - (hash-table-rehash-threshold table))))) - (new-index-vector (make-array new-length - :element-type '(unsigned-byte #.sb!vm:n-word-bits) - :initial-element 0))) + (old-next-vector (hash-table-next-vector table)) + (old-hash-vector (hash-table-hash-vector table)) + (old-size (length old-next-vector)) + (new-size + (let ((rehash-size (hash-table-rehash-size table))) + (etypecase rehash-size + (fixnum + (+ rehash-size old-size)) + (float + (the index (truncate (* rehash-size old-size))))))) + (new-kv-vector (make-array (* 2 new-size) + :initial-element +empty-ht-slot+)) + (new-next-vector (make-array new-size + :element-type '(unsigned-byte #.sb!vm:n-word-bits) + :initial-element 0)) + (new-hash-vector (when old-hash-vector + (make-array new-size + :element-type '(unsigned-byte #.sb!vm:n-word-bits) + :initial-element +magic-hash-vector-value+))) + (old-index-vector (hash-table-index-vector table)) + (new-length (almost-primify + (truncate (/ (float new-size) + (hash-table-rehash-threshold table))))) + (new-index-vector (make-array new-length + :element-type '(unsigned-byte #.sb!vm:n-word-bits) + :initial-element 0))) (declare (type index new-size new-length old-size)) ;; Disable GC tricks on the OLD-KV-VECTOR. @@ -280,46 +280,46 @@ ;; Copy over the hash-vector. (when old-hash-vector (dotimes (i old-size) - (setf (aref new-hash-vector i) (aref old-hash-vector i)))) + (setf (aref new-hash-vector i) (aref old-hash-vector i)))) (setf (hash-table-next-free-kv table) 0) (setf (hash-table-needing-rehash table) 0) ;; Rehash all the entries; last to first so that after the pushes ;; the chains are first to last. (do ((i (1- new-size) (1- i))) - ((zerop i)) + ((zerop i)) (let ((key (aref new-kv-vector (* 2 i))) - (value (aref new-kv-vector (1+ (* 2 i))))) - (cond ((and (eq key +empty-ht-slot+) - (eq value +empty-ht-slot+)) - ;; Slot is empty, push it onto the free list. - (setf (aref new-next-vector i) - (hash-table-next-free-kv table)) - (setf (hash-table-next-free-kv table) i)) - ((and new-hash-vector - (not (= (aref new-hash-vector i) +magic-hash-vector-value+))) - ;; Can use the existing hash value (not EQ based) - (let* ((hashing (aref new-hash-vector i)) - (index (rem hashing new-length)) - (next (aref new-index-vector index))) - (declare (type index index) - (type hash hashing)) - ;; Push this slot into the next chain. - (setf (aref new-next-vector i) next) - (setf (aref new-index-vector index) i))) - (t - ;; EQ base hash. - ;; Enable GC tricks. - (set-header-data new-kv-vector - sb!vm:vector-valid-hashing-subtype) - (let* ((hashing (pointer-hash key)) - (index (rem hashing new-length)) - (next (aref new-index-vector index))) - (declare (type index index) - (type hash hashing)) - ;; Push this slot onto the next chain. - (setf (aref new-next-vector i) next) - (setf (aref new-index-vector index) i)))))) + (value (aref new-kv-vector (1+ (* 2 i))))) + (cond ((and (eq key +empty-ht-slot+) + (eq value +empty-ht-slot+)) + ;; Slot is empty, push it onto the free list. + (setf (aref new-next-vector i) + (hash-table-next-free-kv table)) + (setf (hash-table-next-free-kv table) i)) + ((and new-hash-vector + (not (= (aref new-hash-vector i) +magic-hash-vector-value+))) + ;; Can use the existing hash value (not EQ based) + (let* ((hashing (aref new-hash-vector i)) + (index (rem hashing new-length)) + (next (aref new-index-vector index))) + (declare (type index index) + (type hash hashing)) + ;; Push this slot into the next chain. + (setf (aref new-next-vector i) next) + (setf (aref new-index-vector index) i))) + (t + ;; EQ base hash. + ;; Enable GC tricks. + (set-header-data new-kv-vector + sb!vm:vector-valid-hashing-subtype) + (let* ((hashing (pointer-hash key)) + (index (rem hashing new-length)) + (next (aref new-index-vector index))) + (declare (type index index) + (type hash hashing)) + ;; Push this slot onto the next chain. + (setf (aref new-next-vector i) next) + (setf (aref new-index-vector index) i)))))) (setf (hash-table-table table) new-kv-vector) (setf (hash-table-index-vector table) new-index-vector) (setf (hash-table-next-vector table) new-next-vector) @@ -337,11 +337,11 @@ (defun rehash-without-growing (table) (declare (type hash-table table)) (let* ((kv-vector (hash-table-table table)) - (next-vector (hash-table-next-vector table)) - (hash-vector (hash-table-hash-vector table)) - (size (length next-vector)) - (index-vector (hash-table-index-vector table)) - (length (length index-vector))) + (next-vector (hash-table-next-vector table)) + (hash-vector (hash-table-hash-vector table)) + (size (length next-vector)) + (index-vector (hash-table-index-vector table)) + (length (length index-vector))) (declare (type index size length)) ;; Disable GC tricks, they will be re-enabled during the re-hash @@ -356,52 +356,52 @@ (dotimes (i length) (setf (aref index-vector i) 0)) (do ((i (1- size) (1- i))) - ((zerop i)) + ((zerop i)) (let ((key (aref kv-vector (* 2 i))) - (value (aref kv-vector (1+ (* 2 i))))) - (cond ((and (eq key +empty-ht-slot+) - (eq value +empty-ht-slot+)) - ;; Slot is empty, push it onto free list. - (setf (aref next-vector i) (hash-table-next-free-kv table)) - (setf (hash-table-next-free-kv table) i)) - ((and hash-vector (not (= (aref hash-vector i) +magic-hash-vector-value+))) - ;; Can use the existing hash value (not EQ based) - (let* ((hashing (aref hash-vector i)) - (index (rem hashing length)) - (next (aref index-vector index))) - (declare (type index index)) - ;; Push this slot into the next chain. - (setf (aref next-vector i) next) - (setf (aref index-vector index) i))) - (t - ;; EQ base hash. - ;; Enable GC tricks. - (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype) - (let* ((hashing (pointer-hash key)) - (index (rem hashing length)) - (next (aref index-vector index))) - (declare (type index index) - (type hash hashing)) - ;; Push this slot into the next chain. - (setf (aref next-vector i) next) - (setf (aref index-vector index) i))))))) + (value (aref kv-vector (1+ (* 2 i))))) + (cond ((and (eq key +empty-ht-slot+) + (eq value +empty-ht-slot+)) + ;; Slot is empty, push it onto free list. + (setf (aref next-vector i) (hash-table-next-free-kv table)) + (setf (hash-table-next-free-kv table) i)) + ((and hash-vector (not (= (aref hash-vector i) +magic-hash-vector-value+))) + ;; Can use the existing hash value (not EQ based) + (let* ((hashing (aref hash-vector i)) + (index (rem hashing length)) + (next (aref index-vector index))) + (declare (type index index)) + ;; Push this slot into the next chain. + (setf (aref next-vector i) next) + (setf (aref index-vector index) i))) + (t + ;; EQ base hash. + ;; Enable GC tricks. + (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype) + (let* ((hashing (pointer-hash key)) + (index (rem hashing length)) + (next (aref index-vector index))) + (declare (type index index) + (type hash hashing)) + ;; Push this slot into the next chain. + (setf (aref next-vector i) next) + (setf (aref index-vector index) i))))))) (values)) (defun flush-needing-rehash (table) (let* ((kv-vector (hash-table-table table)) - (index-vector (hash-table-index-vector table)) - (next-vector (hash-table-next-vector table)) - (length (length index-vector))) + (index-vector (hash-table-index-vector table)) + (next-vector (hash-table-next-vector table)) + (length (length index-vector))) (do ((next (hash-table-needing-rehash table))) - ((zerop next)) + ((zerop next)) (declare (type index next)) (let* ((key (aref kv-vector (* 2 next))) - (hashing (pointer-hash key)) - (index (rem hashing length)) - (temp (aref next-vector next))) - (setf (aref next-vector next) (aref index-vector index)) - (setf (aref index-vector index) next) - (setf next temp)))) + (hashing (pointer-hash key)) + (index (rem hashing length)) + (temp (aref next-vector next))) + (setf (aref next-vector next) (aref index-vector index)) + (setf (aref index-vector index) next) + (setf next temp)))) (setf (hash-table-needing-rehash table) 0) (values)) @@ -411,40 +411,40 @@ value and T as multiple values, or returns DEFAULT and NIL if there is no such entry. Entries can be added using SETF." (declare (type hash-table hash-table) - (values t (member t nil))) + (values t (member t nil))) (without-gcing (cond ((= (get-header-data (hash-table-table hash-table)) - sb!vm:vector-must-rehash-subtype) - (rehash-without-growing hash-table)) - ((not (zerop (hash-table-needing-rehash hash-table))) - (flush-needing-rehash hash-table))) + sb!vm:vector-must-rehash-subtype) + (rehash-without-growing hash-table)) + ((not (zerop (hash-table-needing-rehash hash-table))) + (flush-needing-rehash hash-table))) ;; Search for key in the hash table. (multiple-value-bind (hashing eq-based) (funcall (hash-table-hash-fun hash-table) key) (declare (type hash hashing)) (let* ((index-vector (hash-table-index-vector hash-table)) - (length (length index-vector)) - (index (rem hashing length)) - (next (aref index-vector index)) - (table (hash-table-table hash-table)) - (next-vector (hash-table-next-vector hash-table)) - (hash-vector (hash-table-hash-vector hash-table)) - (test-fun (hash-table-test-fun hash-table))) + (length (length index-vector)) + (index (rem hashing length)) + (next (aref index-vector index)) + (table (hash-table-table hash-table)) + (next-vector (hash-table-next-vector hash-table)) + (hash-vector (hash-table-hash-vector hash-table)) + (test-fun (hash-table-test-fun hash-table))) (declare (type index index)) ;; Search next-vector chain for a matching key. (if (or eq-based (not hash-vector)) - (do ((next next (aref next-vector next))) - ((zerop next) (values default nil)) - (declare (type index next)) - (when (eq key (aref table (* 2 next))) - (return (values (aref table (1+ (* 2 next))) t)))) - (do ((next next (aref next-vector next))) - ((zerop next) (values default nil)) - (declare (type index next)) - (when (and (= hashing (aref hash-vector next)) - (funcall test-fun key (aref table (* 2 next)))) - ;; Found. - (return (values (aref table (1+ (* 2 next))) t))))))))) + (do ((next next (aref next-vector next))) + ((zerop next) (values default nil)) + (declare (type index next)) + (when (eq key (aref table (* 2 next))) + (return (values (aref table (1+ (* 2 next))) t)))) + (do ((next next (aref next-vector next))) + ((zerop next) (values default nil)) + (declare (type index next)) + (when (and (= hashing (aref hash-vector next)) + (funcall test-fun key (aref table (* 2 next)))) + ;; Found. + (return (values (aref table (1+ (* 2 next))) t))))))))) ;;; so people can call #'(SETF GETHASH) (defun (setf gethash) (new-value key table &optional default) @@ -459,71 +459,71 @@ ;; exists. Check that there is room for one more entry. May not be ;; needed if the key is already present. (cond ((zerop (hash-table-next-free-kv hash-table)) - (rehash hash-table)) - ((= (get-header-data (hash-table-table hash-table)) - sb!vm:vector-must-rehash-subtype) - (rehash-without-growing hash-table)) - ((not (zerop (hash-table-needing-rehash hash-table))) - (flush-needing-rehash hash-table))) + (rehash hash-table)) + ((= (get-header-data (hash-table-table hash-table)) + sb!vm:vector-must-rehash-subtype) + (rehash-without-growing hash-table)) + ((not (zerop (hash-table-needing-rehash hash-table))) + (flush-needing-rehash hash-table))) ;; Search for key in the hash table. (multiple-value-bind (hashing eq-based) (funcall (hash-table-hash-fun hash-table) key) (declare (type hash hashing)) (let* ((index-vector (hash-table-index-vector hash-table)) - (length (length index-vector)) - (index (rem hashing length)) - (next (aref index-vector index)) - (kv-vector (hash-table-table hash-table)) - (next-vector (hash-table-next-vector hash-table)) - (hash-vector (hash-table-hash-vector hash-table)) - (test-fun (hash-table-test-fun hash-table))) + (length (length index-vector)) + (index (rem hashing length)) + (next (aref index-vector index)) + (kv-vector (hash-table-table hash-table)) + (next-vector (hash-table-next-vector hash-table)) + (hash-vector (hash-table-hash-vector hash-table)) + (test-fun (hash-table-test-fun hash-table))) (declare (type index index)) (cond ((or eq-based (not hash-vector)) - (when eq-based - (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype)) - - ;; Search next-vector chain for a matching key. - (do ((next next (aref next-vector next))) - ((zerop next)) - (declare (type index next)) - (when (eq key (aref kv-vector (* 2 next))) - ;; Found, just replace the value. - (setf (aref kv-vector (1+ (* 2 next))) value) - (return-from %puthash value)))) - (t - ;; Search next-vector chain for a matching key. - (do ((next next (aref next-vector next))) - ((zerop next)) - (declare (type index next)) - (when (and (= hashing (aref hash-vector next)) - (funcall test-fun key - (aref kv-vector (* 2 next)))) - ;; Found, just replace the value. - (setf (aref kv-vector (1+ (* 2 next))) value) - (return-from %puthash value))))) + (when eq-based + (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype)) + + ;; Search next-vector chain for a matching key. + (do ((next next (aref next-vector next))) + ((zerop next)) + (declare (type index next)) + (when (eq key (aref kv-vector (* 2 next))) + ;; Found, just replace the value. + (setf (aref kv-vector (1+ (* 2 next))) value) + (return-from %puthash value)))) + (t + ;; Search next-vector chain for a matching key. + (do ((next next (aref next-vector next))) + ((zerop next)) + (declare (type index next)) + (when (and (= hashing (aref hash-vector next)) + (funcall test-fun key + (aref kv-vector (* 2 next)))) + ;; Found, just replace the value. + (setf (aref kv-vector (1+ (* 2 next))) value) + (return-from %puthash value))))) ;; Pop a KV slot off the free list (let ((free-kv-slot (hash-table-next-free-kv hash-table))) - ;; Double-check for overflow. - (aver (not (zerop free-kv-slot))) - (setf (hash-table-next-free-kv hash-table) - (aref next-vector free-kv-slot)) - (incf (hash-table-number-entries hash-table)) - - (setf (aref kv-vector (* 2 free-kv-slot)) key) - (setf (aref kv-vector (1+ (* 2 free-kv-slot))) value) - - ;; Setup the hash-vector if necessary. - (when hash-vector - (if (not eq-based) - (setf (aref hash-vector free-kv-slot) hashing) - (aver (= (aref hash-vector free-kv-slot) +magic-hash-vector-value+)))) - - ;; Push this slot into the next chain. - (setf (aref next-vector free-kv-slot) next) - (setf (aref index-vector index) free-kv-slot))))) + ;; Double-check for overflow. + (aver (not (zerop free-kv-slot))) + (setf (hash-table-next-free-kv hash-table) + (aref next-vector free-kv-slot)) + (incf (hash-table-number-entries hash-table)) + + (setf (aref kv-vector (* 2 free-kv-slot)) key) + (setf (aref kv-vector (1+ (* 2 free-kv-slot))) value) + + ;; Setup the hash-vector if necessary. + (when hash-vector + (if (not eq-based) + (setf (aref hash-vector free-kv-slot) hashing) + (aver (= (aref hash-vector free-kv-slot) +magic-hash-vector-value+)))) + + ;; Push this slot into the next chain. + (setf (aref next-vector free-kv-slot) next) + (setf (aref index-vector index) free-kv-slot))))) value) (defun remhash (key hash-table) @@ -531,28 +531,28 @@ "Remove the entry in HASH-TABLE associated with KEY. Return T if there was such an entry, or NIL if not." (declare (type hash-table hash-table) - (values (member t nil))) + (values (member t nil))) (without-gcing ;; We need to rehash here so that a current key can be found if it ;; exists. (cond ((= (get-header-data (hash-table-table hash-table)) - sb!vm:vector-must-rehash-subtype) - (rehash-without-growing hash-table)) - ((not (zerop (hash-table-needing-rehash hash-table))) - (flush-needing-rehash hash-table))) + sb!vm:vector-must-rehash-subtype) + (rehash-without-growing hash-table)) + ((not (zerop (hash-table-needing-rehash hash-table))) + (flush-needing-rehash hash-table))) ;; Search for key in the hash table. (multiple-value-bind (hashing eq-based) (funcall (hash-table-hash-fun hash-table) key) (declare (type hash hashing)) (let* ((index-vector (hash-table-index-vector hash-table)) - (length (length index-vector)) - (index (rem hashing length)) - (next (aref index-vector index)) - (table (hash-table-table hash-table)) - (next-vector (hash-table-next-vector hash-table)) - (hash-vector (hash-table-hash-vector hash-table)) - (test-fun (hash-table-test-fun hash-table))) + (length (length index-vector)) + (index (rem hashing length)) + (next (aref index-vector index)) + (table (hash-table-table hash-table)) + (next-vector (hash-table-next-vector hash-table)) + (hash-vector (hash-table-hash-vector hash-table)) + (test-fun (hash-table-test-fun hash-table))) (declare (type index index next)) (flet ((clear-slot (chain-vector prior-slot-location slot-location) ;; Mark slot as empty. @@ -601,10 +601,10 @@ itself." (declare (optimize speed)) (let* ((kv-vector (hash-table-table hash-table)) - (next-vector (hash-table-next-vector hash-table)) - (hash-vector (hash-table-hash-vector hash-table)) - (size (length next-vector)) - (index-vector (hash-table-index-vector hash-table))) + (next-vector (hash-table-next-vector hash-table)) + (hash-vector (hash-table-hash-vector hash-table)) + (size (length next-vector)) + (index-vector (hash-table-index-vector hash-table))) ;; Disable GC tricks. (set-header-data kv-vector sb!vm:vector-normal-subtype) ;; Mark all slots as empty by setting all keys and values to magic @@ -613,7 +613,7 @@ (fill kv-vector +empty-ht-slot+ :start 2) ;; Set up the free list, all free. (do ((i 1 (1+ i))) - ((>= i (1- size))) + ((>= i (1- size))) (setf (aref next-vector i) (1+ i))) (setf (aref next-vector (1- size)) 0) (setf (hash-table-next-free-kv hash-table) 1) @@ -640,17 +640,17 @@ "For each entry in HASH-TABLE, call the designated two-argument function on the key and value of the entry. Return NIL." (let ((fun (%coerce-callable-to-fun function-designator)) - (size (length (hash-table-next-vector hash-table)))) + (size (length (hash-table-next-vector hash-table)))) (declare (type function fun)) (do ((i 1 (1+ i))) - ((>= i size)) + ((>= i size)) (declare (type index i)) (let* ((kv-vector (hash-table-table hash-table)) - (key (aref kv-vector (* 2 i))) - (value (aref kv-vector (1+ (* 2 i))))) - (unless (and (eq key +empty-ht-slot+) - (eq value +empty-ht-slot+)) - (funcall fun key value)))))) + (key (aref kv-vector (* 2 i))) + (value (aref kv-vector (1+ (* 2 i))))) + (unless (and (eq key +empty-ht-slot+) + (eq value +empty-ht-slot+)) + (funcall fun key value)))))) ;;;; methods on HASH-TABLE @@ -672,8 +672,8 @@ (defun %hash-table-alist (hash-table) (let ((result nil)) (maphash (lambda (key value) - (push (cons key value) result)) - hash-table) + (push (cons key value) result)) + hash-table) result)) ;;; Stuff an association list into HASH-TABLE. Return the hash table, @@ -688,22 +688,22 @@ (def!method print-object ((hash-table hash-table) stream) (declare (type stream stream)) (cond ((not *print-readably*) - (print-unreadable-object (hash-table stream :type t :identity t) - (format stream - ":TEST ~S :COUNT ~S" - (hash-table-test hash-table) - (hash-table-count hash-table)))) - ((not *read-eval*) - (error "can't print hash tables readably without *READ-EVAL*")) - (t - (with-standard-io-syntax - (format stream - "#.~W" - `(%stuff-hash-table (make-hash-table ,@(%hash-table-ctor-args - hash-table)) - ',(%hash-table-alist hash-table))))))) + (print-unreadable-object (hash-table stream :type t :identity t) + (format stream + ":TEST ~S :COUNT ~S" + (hash-table-test hash-table) + (hash-table-count hash-table)))) + ((not *read-eval*) + (error "can't print hash tables readably without *READ-EVAL*")) + (t + (with-standard-io-syntax + (format stream + "#.~W" + `(%stuff-hash-table (make-hash-table ,@(%hash-table-ctor-args + hash-table)) + ',(%hash-table-alist hash-table))))))) (def!method make-load-form ((hash-table hash-table) &optional environment) (declare (ignore environment)) (values `(make-hash-table ,@(%hash-table-ctor-args hash-table)) - `(%stuff-hash-table ,hash-table ',(%hash-table-alist hash-table)))) + `(%stuff-hash-table ,hash-table ',(%hash-table-alist hash-table)))) diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index 2aa6bef..9ae8a46 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -31,13 +31,13 @@ (defun load-as-source (stream verbose print) (maybe-announce-load stream verbose) (do ((sexpr (read stream nil *eof-object*) - (read stream nil *eof-object*))) + (read stream nil *eof-object*))) ((eq sexpr *eof-object*) t) (if print - (let ((results (multiple-value-list (eval sexpr)))) - (load-fresh-line) - (format t "~{~S~^, ~}~%" results)) + (let ((results (multiple-value-list (eval sexpr)))) + (load-fresh-line) + (format t "~{~S~^, ~}~%" results)) (eval sexpr)))) ;;;; LOAD itself @@ -48,9 +48,9 @@ (lambda (condition stream) (format stream "~@" - (invalid-fasl-stream condition) - (invalid-fasl-expected condition) - (invalid-fasl-fhsss condition))))) + (invalid-fasl-stream condition) + (invalid-fasl-expected condition) + (invalid-fasl-fhsss condition))))) ;;; a helper function for LOAD: Load the stuff in a file when we have ;;; the name. @@ -58,46 +58,46 @@ ;;; FIXME: with the addition of the EXTERNAL-FORMAT argument, this ;;; interface has become truly sucky. (defun internal-load (pathname truename if-does-not-exist verbose print - &optional contents external-format) + &optional contents external-format) (declare (type (member nil :error) if-does-not-exist)) (unless truename (if if-does-not-exist - (error 'simple-file-error - :pathname pathname - :format-control "~S does not exist." - :format-arguments (list (namestring pathname))) - (return-from internal-load nil))) + (error 'simple-file-error + :pathname pathname + :format-control "~S does not exist." + :format-arguments (list (namestring pathname))) + (return-from internal-load nil))) (let ((*load-truename* truename) - (*load-pathname* (merge-pathnames pathname))) + (*load-pathname* (merge-pathnames pathname))) (case contents (:source (with-open-file (stream truename - :direction :input - :if-does-not-exist if-does-not-exist + :direction :input + :if-does-not-exist if-does-not-exist :external-format external-format) - (load-as-source stream verbose print))) + (load-as-source stream verbose print))) (:binary (with-open-file (stream truename - :direction :input - :if-does-not-exist if-does-not-exist - :element-type '(unsigned-byte 8)) - (load-as-fasl stream verbose print))) + :direction :input + :if-does-not-exist if-does-not-exist + :element-type '(unsigned-byte 8)) + (load-as-fasl stream verbose print))) (t (let* ((fhsss *fasl-header-string-start-string*) - (first-line (make-array (length fhsss) - :element-type '(unsigned-byte 8))) - (read-length - (with-open-file (stream truename - :direction :input - :element-type '(unsigned-byte 8)) - (read-sequence first-line stream)))) - (cond - ((and (= read-length (length fhsss)) - (do ((i 0 (1+ i))) - ((= i read-length) t) - (when (/= (char-code (aref fhsss i)) (aref first-line i)) - (return)))) + (first-line (make-array (length fhsss) + :element-type '(unsigned-byte 8))) + (read-length + (with-open-file (stream truename + :direction :input + :element-type '(unsigned-byte 8)) + (read-sequence first-line stream)))) + (cond + ((and (= read-length (length fhsss)) + (do ((i 0 (1+ i))) + ((= i read-length) t) + (when (/= (char-code (aref fhsss i)) (aref first-line i)) + (return)))) (internal-load pathname truename if-does-not-exist verbose print :binary)) (t @@ -130,29 +130,29 @@ (multiple-value-bind (src-pn src-tn) (try-default-type pathname *load-source-default-type*) (multiple-value-bind (obj-pn obj-tn) - (try-default-type pathname *fasl-file-type*) + (try-default-type pathname *fasl-file-type*) (cond ((and obj-tn - src-tn - (> (file-write-date src-tn) (file-write-date obj-tn))) - (restart-case - (error "The object file ~A is~@ + src-tn + (> (file-write-date src-tn) (file-write-date obj-tn))) + (restart-case + (error "The object file ~A is~@ older than the presumed source:~% ~A." - (namestring obj-tn) - (namestring src-tn)) - (source () :report "load source file" - (internal-load src-pn src-tn if-does-not-exist verbose print - :source external-format)) - (object () :report "load object file" - (internal-load src-pn obj-tn if-does-not-exist verbose print - :binary)))) + (namestring obj-tn) + (namestring src-tn)) + (source () :report "load source file" + (internal-load src-pn src-tn if-does-not-exist verbose print + :source external-format)) + (object () :report "load object file" + (internal-load src-pn obj-tn if-does-not-exist verbose print + :binary)))) (obj-tn - (internal-load obj-pn obj-tn if-does-not-exist verbose print :binary)) + (internal-load obj-pn obj-tn if-does-not-exist verbose print :binary)) (src-pn - (internal-load src-pn src-tn if-does-not-exist + (internal-load src-pn src-tn if-does-not-exist verbose print :source external-format)) (t - (internal-load pathname nil if-does-not-exist + (internal-load pathname nil if-does-not-exist verbose print nil external-format)))))) ;;; This function mainly sets up special bindings and then calls @@ -166,51 +166,51 @@ ;;; CL does not correctly record source file information when LOADing a ;;; non-compiled file. Check whether this bug exists in SBCL and fix it if so. (defun load (filespec - &key - (verbose *load-verbose*) - (print *load-print*) - (if-does-not-exist t) - (external-format :default)) + &key + (verbose *load-verbose*) + (print *load-print*) + (if-does-not-exist t) + (external-format :default)) #!+sb-doc "Load the file given by FILESPEC into the Lisp environment, returning T on success." (let ((*load-depth* (1+ *load-depth*)) - ;; KLUDGE: I can't find in the ANSI spec where it says that - ;; DECLAIM/PROCLAIM of optimization policy should have file - ;; scope. CMU CL did this, and it seems reasonable, but it - ;; might not be right; after all, things like (PROCLAIM '(TYPE - ;; ..)) don't have file scope, and I can't find anything under - ;; PROCLAIM or COMPILE-FILE or LOAD or OPTIMIZE which - ;; justifies this behavior. Hmm. -- WHN 2001-04-06 - (sb!c::*policy* sb!c::*policy*) - ;; The ANSI spec for LOAD says "LOAD binds *READTABLE* and - ;; *PACKAGE* to the values they held before loading the file." - (*package* (sane-package)) - (*readtable* *readtable*) - ;; The old CMU CL LOAD function used an IF-DOES-NOT-EXIST - ;; argument of (MEMBER :ERROR NIL) type. ANSI constrains us to - ;; accept a generalized boolean argument value for this - ;; externally-visible function, but the internal functions - ;; still use the old convention. - (internal-if-does-not-exist (if if-does-not-exist :error nil))) + ;; KLUDGE: I can't find in the ANSI spec where it says that + ;; DECLAIM/PROCLAIM of optimization policy should have file + ;; scope. CMU CL did this, and it seems reasonable, but it + ;; might not be right; after all, things like (PROCLAIM '(TYPE + ;; ..)) don't have file scope, and I can't find anything under + ;; PROCLAIM or COMPILE-FILE or LOAD or OPTIMIZE which + ;; justifies this behavior. Hmm. -- WHN 2001-04-06 + (sb!c::*policy* sb!c::*policy*) + ;; The ANSI spec for LOAD says "LOAD binds *READTABLE* and + ;; *PACKAGE* to the values they held before loading the file." + (*package* (sane-package)) + (*readtable* *readtable*) + ;; The old CMU CL LOAD function used an IF-DOES-NOT-EXIST + ;; argument of (MEMBER :ERROR NIL) type. ANSI constrains us to + ;; accept a generalized boolean argument value for this + ;; externally-visible function, but the internal functions + ;; still use the old convention. + (internal-if-does-not-exist (if if-does-not-exist :error nil))) ;; FIXME: This VALUES wrapper is inherited from CMU CL. Once SBCL ;; gets function return type checking right, we can achieve a ;; similar effect better by adding FTYPE declarations. (values (if (streamp filespec) - (if (or (equal (stream-element-type filespec) - '(unsigned-byte 8))) - (load-as-fasl filespec verbose print) - (load-as-source filespec verbose print)) - (let* ((pathname (pathname filespec)) - (physical-pathname (translate-logical-pathname pathname)) - (probed-file (probe-file physical-pathname))) - (if (or probed-file - (pathname-type physical-pathname)) - (internal-load + (if (or (equal (stream-element-type filespec) + '(unsigned-byte 8))) + (load-as-fasl filespec verbose print) + (load-as-source filespec verbose print)) + (let* ((pathname (pathname filespec)) + (physical-pathname (translate-logical-pathname pathname)) + (probed-file (probe-file physical-pathname))) + (if (or probed-file + (pathname-type physical-pathname)) + (internal-load physical-pathname probed-file internal-if-does-not-exist verbose print nil external-format) - (internal-load-default-type + (internal-load-default-type pathname internal-if-does-not-exist verbose print external-format))))))) @@ -221,17 +221,17 @@ (declare (fixnum box-num code-length)) (with-fop-stack t (let ((code (%primitive sb!c:allocate-code-object box-num code-length)) - (index (+ sb!vm:code-trace-table-offset-slot box-num))) + (index (+ sb!vm:code-trace-table-offset-slot box-num))) (declare (type index index)) (setf (%code-debug-info code) (pop-stack)) (dotimes (i box-num) - (declare (fixnum i)) - (setf (code-header-ref code (decf index)) (pop-stack))) + (declare (fixnum i)) + (setf (code-header-ref code (decf index)) (pop-stack))) (sb!sys:without-gcing - (read-n-bytes *fasl-input-stream* - (code-instructions code) - 0 - code-length)) + (read-n-bytes *fasl-input-stream* + (code-instructions code) + 0 + code-length)) code))) ;;; Moving native code during a GC or purify is not so trivial on the @@ -248,43 +248,43 @@ (with-fop-stack t (let ((stuff (list (pop-stack)))) (dotimes (i box-num) - (declare (fixnum i)) - (push (pop-stack) stuff)) - (let* ((dbi (car (last stuff))) ; debug-info - (tto (first stuff))) ; trace-table-offset + (declare (fixnum i)) + (push (pop-stack) stuff)) + (let* ((dbi (car (last stuff))) ; debug-info + (tto (first stuff))) ; trace-table-offset - (setq stuff (nreverse stuff)) + (setq stuff (nreverse stuff)) - ;; FIXME: *LOAD-CODE-VERBOSE* should probably be #!+SB-SHOW. - (when *load-code-verbose* - (format t "stuff: ~S~%" stuff) - (format t - " : ~S ~S ~S ~S~%" - (sb!c::compiled-debug-info-p dbi) - (sb!c::debug-info-p dbi) - (sb!c::compiled-debug-info-name dbi) - tto) + ;; FIXME: *LOAD-CODE-VERBOSE* should probably be #!+SB-SHOW. + (when *load-code-verbose* + (format t "stuff: ~S~%" stuff) + (format t + " : ~S ~S ~S ~S~%" + (sb!c::compiled-debug-info-p dbi) + (sb!c::debug-info-p dbi) + (sb!c::compiled-debug-info-name dbi) + tto) (format t " loading to the dynamic space~%")) - (let ((code (%primitive sb!c:allocate-code-object + (let ((code (%primitive sb!c:allocate-code-object box-num code-length)) - (index (+ sb!vm:code-trace-table-offset-slot box-num))) - (declare (type index index)) - (when *load-code-verbose* - (format t - " obj addr=~X~%" - (sb!kernel::get-lisp-obj-address code))) - (setf (%code-debug-info code) (pop stuff)) - (dotimes (i box-num) - (declare (fixnum i)) - (setf (code-header-ref code (decf index)) (pop stuff))) - (sb!sys:without-gcing - (read-n-bytes *fasl-input-stream* - (code-instructions code) - 0 - code-length)) - code))))) + (index (+ sb!vm:code-trace-table-offset-slot box-num))) + (declare (type index index)) + (when *load-code-verbose* + (format t + " obj addr=~X~%" + (sb!kernel::get-lisp-obj-address code))) + (setf (%code-debug-info code) (pop stuff)) + (dotimes (i box-num) + (declare (fixnum i)) + (setf (code-header-ref code (decf index)) (pop stuff))) + (sb!sys:without-gcing + (read-n-bytes *fasl-input-stream* + (code-instructions code) + 0 + code-length)) + code))))) ;;;; linkage fixups diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp index 05386fd..8363d7f 100644 --- a/src/code/target-misc.lisp +++ b/src/code/target-misc.lisp @@ -25,16 +25,16 @@ NAME is some name (for debugging only) or NIL if there is no name." (declare (type function fun)) (let* ((fun (%simple-fun-self fun)) - (name (%fun-name fun)) - (code (sb!di::fun-code-header fun)) - (info (sb!kernel:%code-debug-info code))) + (name (%fun-name fun)) + (code (sb!di::fun-code-header fun)) + (info (sb!kernel:%code-debug-info code))) (if info (let ((source (sb!c::debug-info-source info))) (cond ((and (eq (sb!c::debug-source-from source) :lisp) (eq (sb!c::debug-source-function source) fun)) (values (svref (sb!c::debug-source-name source) 0) nil - name)) + name)) ((legal-fun-name-p name) (let ((exp (fun-name-inline-expansion name))) (values exp (not exp) name))) @@ -48,9 +48,9 @@ (defun %fun-fun (function) (declare (function function)) (case (widetag-of function) - (#.sb!vm:simple-fun-header-widetag + (#.sb!vm:simple-fun-header-widetag function) - (#.sb!vm:closure-header-widetag + (#.sb!vm:closure-header-widetag (%closure-fun function)) (#.sb!vm:funcallable-instance-header-widetag (funcallable-instance-fun function)))) @@ -92,7 +92,7 @@ ;; When/if weak hash tables become supported ;; again, it'll become easy to fix this, but for now there ;; seems to be no easy way (short of the ugly way of adding a - ;; slot to every single closure header), so we don't. + ;; slot to every single closure header), so we don't. ;; ;; Meanwhile, users might encounter this problem by doing DEFUN ;; in a non-null lexical environment, so we try to give a @@ -106,7 +106,7 @@ ;; user-level code, so we can give a implementor-level ;; "error" (warning) message. (warn "can't set function name ((~S function)=~S), leaving it unchanged" - 'widetag-of widetag)))) + 'widetag-of widetag)))) new-name) (defun %fun-doc (x) @@ -140,7 +140,7 @@ are running on, or NIL if we can't find any useful information." (unless (boundp '*machine-version*) (setf *machine-version* (get-machine-version))) *machine-version*) - + ;;; FIXME: Don't forget to set these in a sample site-init file. ;;; FIXME: Perhaps the functions could be SETFable instead of having the ;;; interface be through special variables? As far as I can tell @@ -172,10 +172,10 @@ until one of them returns non-NIL; these functions are responsible for signalling a FILE-ERROR to indicate failure to perform an operation on the file system." (dolist (fun *ed-functions* - (error 'extension-failure - :format-control "Don't know how to ~S ~A" - :format-arguments (list 'ed x) - :references (list '(:sbcl :variable *ed-functions*)))) + (error 'extension-failure + :format-control "Don't know how to ~S ~A" + :format-arguments (list 'ed x) + :references (list '(:sbcl :variable *ed-functions*)))) (when (funcall fun x) (return t)))) @@ -202,33 +202,33 @@ the file system." record of further I/O to that file. Without an argument, it closes the dribble file, and quits logging." (cond (pathname - (let* ((new-dribble-stream - (open pathname - :direction :output - :if-exists if-exists - :if-does-not-exist :create)) - (new-standard-output - (make-broadcast-stream *standard-output* new-dribble-stream)) - (new-error-output - (make-broadcast-stream *error-output* new-dribble-stream)) - (new-standard-input - (make-echo-stream *standard-input* new-dribble-stream))) - (push (list *dribble-stream* *standard-input* *standard-output* - *error-output*) - *previous-dribble-streams*) - (setf *dribble-stream* new-dribble-stream) - (setf *standard-input* new-standard-input) - (setf *standard-output* new-standard-output) - (setf *error-output* new-error-output))) - ((null *dribble-stream*) - (error "not currently dribbling")) - (t - (let ((old-streams (pop *previous-dribble-streams*))) - (close *dribble-stream*) - (setf *dribble-stream* (first old-streams)) - (setf *standard-input* (second old-streams)) - (setf *standard-output* (third old-streams)) - (setf *error-output* (fourth old-streams))))) + (let* ((new-dribble-stream + (open pathname + :direction :output + :if-exists if-exists + :if-does-not-exist :create)) + (new-standard-output + (make-broadcast-stream *standard-output* new-dribble-stream)) + (new-error-output + (make-broadcast-stream *error-output* new-dribble-stream)) + (new-standard-input + (make-echo-stream *standard-input* new-dribble-stream))) + (push (list *dribble-stream* *standard-input* *standard-output* + *error-output*) + *previous-dribble-streams*) + (setf *dribble-stream* new-dribble-stream) + (setf *standard-input* new-standard-input) + (setf *standard-output* new-standard-output) + (setf *error-output* new-error-output))) + ((null *dribble-stream*) + (error "not currently dribbling")) + (t + (let ((old-streams (pop *previous-dribble-streams*))) + (close *dribble-stream*) + (setf *dribble-stream* (first old-streams)) + (setf *standard-input* (second old-streams)) + (setf *standard-output* (third old-streams)) + (setf *error-output* (fourth old-streams))))) (values)) (defun %byte-blt (src src-start dst dst-start dst-end) diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 88b3cbf..673d170 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -34,10 +34,10 @@ (declare (type stream stream)) (print-unreadable-object (table stream :type t) (format stream - ":SIZE ~S :FREE ~S :DELETED ~S" - (package-hashtable-size table) - (package-hashtable-free table) - (package-hashtable-deleted table)))) + ":SIZE ~S :FREE ~S :DELETED ~S" + (package-hashtable-size table) + (package-hashtable-free table) + (package-hashtable-deleted table)))) ;;; the maximum density we allow in a package hashtable (defconstant package-rehash-threshold 0.75) @@ -48,7 +48,7 @@ ;;; useful when changing the size, since there are many pointers to ;;; the hashtable. (defun make-or-remake-package-hashtable (size - &optional + &optional res) (flet ((actual-package-hashtable-size (size) (loop for n of-type fixnum @@ -74,33 +74,33 @@ #!+sb-package-locks (progn -(defun package-locked-p (package) - #!+sb-doc +(defun package-locked-p (package) + #!+sb-doc "Returns T when PACKAGE is locked, NIL otherwise. Signals an error if PACKAGE doesn't designate a valid package." (package-lock (find-undeleted-package-or-lose package))) (defun lock-package (package) - #!+sb-doc + #!+sb-doc "Locks PACKAGE and returns T. Has no effect if PACKAGE was already locked. Signals an error if PACKAGE is not a valid package designator" (setf (package-lock (find-undeleted-package-or-lose package)) t)) (defun unlock-package (package) - #!+sb-doc + #!+sb-doc "Unlocks PACKAGE and returns T. Has no effect if PACKAGE was already unlocked. Signals an error if PACKAGE is not a valid package designator." (setf (package-lock (find-undeleted-package-or-lose package)) nil) t) (defun package-implemented-by-list (package) - #!+sb-doc + #!+sb-doc "Returns a list containing the implementation packages of PACKAGE. Signals an error if PACKAGE is not a valid package designator." (package-%implementation-packages (find-undeleted-package-or-lose package))) -(defun package-implements-list (package) - #!+sb-doc +(defun package-implements-list (package) + #!+sb-doc "Returns the packages that PACKAGE is an implementation package of. Signals an error if PACKAGE is not a valid package designator." (let ((package (find-undeleted-package-or-lose package))) @@ -108,28 +108,28 @@ of. Signals an error if PACKAGE is not a valid package designator." when (member package (package-%implementation-packages x)) collect x))) -(defun add-implementation-package (packages-to-add - &optional (package *package*)) - #!+sb-doc +(defun add-implementation-package (packages-to-add + &optional (package *package*)) + #!+sb-doc "Adds PACKAGES-TO-ADD as implementation packages of PACKAGE. Signals an error if PACKAGE or any of the PACKAGES-TO-ADD is not a valid package designator." (let ((package (find-undeleted-package-or-lose package)) - (packages-to-add (package-listify packages-to-add))) + (packages-to-add (package-listify packages-to-add))) (setf (package-%implementation-packages package) (union (package-%implementation-packages package) (mapcar #'find-undeleted-package-or-lose packages-to-add))))) -(defun remove-implementation-package (packages-to-remove - &optional (package *package*)) - #!+sb-doc +(defun remove-implementation-package (packages-to-remove + &optional (package *package*)) + #!+sb-doc "Removes PACKAGES-TO-REMOVE from the implementation packages of PACKAGE. Signals an error if PACKAGE or any of the PACKAGES-TO-REMOVE is not a valid package designator." (let ((package (find-undeleted-package-or-lose package)) - (packages-to-remove (package-listify packages-to-remove))) + (packages-to-remove (package-listify packages-to-remove))) (setf (package-%implementation-packages package) - (nset-difference + (nset-difference (package-%implementation-packages package) (mapcar #'find-undeleted-package-or-lose packages-to-remove))))) @@ -140,15 +140,15 @@ error if any of PACKAGES is not a valid package designator." (with-unique-names (unlocked-packages) `(let (,unlocked-packages) (unwind-protect - (progn + (progn (dolist (p ',packages) (when (package-locked-p p) (push p ,unlocked-packages) (unlock-package p))) ,@forms) (dolist (p ,unlocked-packages) - (when (find-package p) - (lock-package p))))))) + (when (find-package p) + (lock-package p))))))) (defun package-lock-violation (package &key (symbol nil symbol-p) format-control format-arguments) @@ -187,7 +187,7 @@ error if any of PACKAGES is not a valid package designator." ;; comparison to *package*, since during cold init this gets ;; called before *package* is bound -- but no package should ;; be locked at that point. - (and package + (and package (package-lock package) ;; In package or implementation package (not (or (eq package *package*) @@ -214,15 +214,15 @@ error if any of PACKAGES is not a valid package designator." ;;; ;;; Must be used inside the dynamic contour established by ;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR -(defun assert-package-unlocked (package &optional format-control - &rest format-arguments) - #!-sb-package-locks +(defun assert-package-unlocked (package &optional format-control + &rest format-arguments) + #!-sb-package-locks (declare (ignore format-control format-arguments)) #!+sb-package-locks (when (package-lock-violation-p package) - (package-lock-violation package - :format-control format-control - :format-arguments format-arguments)) + (package-lock-violation package + :format-control format-control + :format-arguments format-arguments)) package) ;;; Must be used inside the dynamic contour established by @@ -236,23 +236,23 @@ error if any of PACKAGES is not a valid package designator." (declare (ignore format)) #!+sb-package-locks (let* ((symbol (etypecase name - (symbol name) - (list (if (and (consp (cdr name)) - (eq 'setf (first name))) - (second name) - ;; Skip lists of length 1, single conses and - ;; (class-predicate foo), etc. - ;; FIXME: MOP and package-lock - ;; interaction needs to be thought about. - (return-from - assert-symbol-home-package-unlocked - name))))) - (package (symbol-package symbol))) + (symbol name) + (list (if (and (consp (cdr name)) + (eq 'setf (first name))) + (second name) + ;; Skip lists of length 1, single conses and + ;; (class-predicate foo), etc. + ;; FIXME: MOP and package-lock + ;; interaction needs to be thought about. + (return-from + assert-symbol-home-package-unlocked + name))))) + (package (symbol-package symbol))) (when (package-lock-violation-p package symbol) - (package-lock-violation package - :symbol symbol - :format-control format - :format-arguments (list name)))) + (package-lock-violation package + :symbol symbol + :format-control format + :format-arguments (list name)))) name) @@ -261,16 +261,16 @@ error if any of PACKAGES is not a valid package designator." (def!method print-object ((package package) stream) (let ((name (package-%name package))) (if name - (print-unreadable-object (package stream :type t) - (prin1 name stream)) - (print-unreadable-object (package stream :type t :identity t) - (write-string "(deleted)" stream))))) + (print-unreadable-object (package stream :type t) + (prin1 name stream)) + (print-unreadable-object (package stream :type t :identity t) + (write-string "(deleted)" stream))))) ;;; ANSI says (in the definition of DELETE-PACKAGE) that these, and ;;; most other operations, are unspecified for deleted packages. We ;;; just do the easy thing and signal errors in that case. (macrolet ((def (ext real) - `(defun ,ext (x) (,real (find-undeleted-package-or-lose x))))) + `(defun ,ext (x) (,real (find-undeleted-package-or-lose x))))) (def package-nicknames package-%nicknames) (def package-use-list package-%use-list) (def package-used-by-list package-%used-by-list) @@ -278,8 +278,8 @@ error if any of PACKAGES is not a valid package designator." (defun %package-hashtable-symbol-count (table) (let ((size (the fixnum - (- (package-hashtable-size table) - (package-hashtable-deleted table))))) + (- (package-hashtable-size table) + (package-hashtable-deleted table))))) (the fixnum (- size (package-hashtable-free table))))) @@ -289,7 +289,7 @@ error if any of PACKAGES is not a valid package designator." (defun package-external-symbol-count (package) (%package-hashtable-symbol-count (package-external-symbols package))) -(defvar *package* (error "*PACKAGE* should be initialized in cold load!") +(defvar *package* (error "*PACKAGE* should be initialized in cold load!") #!+sb-doc "the current package") ;;; FIXME: should be declared of type PACKAGE, with no NIL init form, ;;; after I get around to cleaning up DOCUMENTATION @@ -319,34 +319,34 @@ error if any of PACKAGES is not a valid package designator." (define-condition bootstrap-package-not-found (condition) ((name :initarg :name :reader bootstrap-package-name))) (defun debootstrap-package (&optional condition) - (invoke-restart + (invoke-restart (find-restart-or-control-error 'debootstrap-package condition))) - + (defun find-package (package-designator) (flet ((find-package-from-string (string) - (declare (type string string)) - (let ((packageoid (gethash string *package-names*))) - (when (and (null packageoid) - (not *in-package-init*) ; KLUDGE - (let ((mismatch (mismatch "SB!" string))) - (and mismatch (= mismatch 3)))) - (restart-case - (signal 'bootstrap-package-not-found :name string) - (debootstrap-package () - (return-from find-package - (if (string= string "SB!XC") - (find-package "COMMON-LISP") - (find-package - (substitute #\- #\! string :count 1))))))) - packageoid))) + (declare (type string string)) + (let ((packageoid (gethash string *package-names*))) + (when (and (null packageoid) + (not *in-package-init*) ; KLUDGE + (let ((mismatch (mismatch "SB!" string))) + (and mismatch (= mismatch 3)))) + (restart-case + (signal 'bootstrap-package-not-found :name string) + (debootstrap-package () + (return-from find-package + (if (string= string "SB!XC") + (find-package "COMMON-LISP") + (find-package + (substitute #\- #\! string :count 1))))))) + packageoid))) (typecase package-designator (package package-designator) (symbol (find-package-from-string (symbol-name package-designator))) (string (find-package-from-string package-designator)) (character (find-package-from-string (string package-designator))) (t (error 'type-error - :datum package-designator - :expected-type '(or character package string symbol)))))) + :datum package-designator + :expected-type '(or character package string symbol)))))) ;;; Return a list of packages given a package designator or list of ;;; package designators, or die trying. @@ -372,94 +372,94 @@ error if any of PACKAGES is not a valid package designator." ;;; must be between 2 and 255. (defmacro entry-hash (length sxhash) `(the fixnum - (+ (the fixnum - (rem (the fixnum - (logxor ,length - ,sxhash - (the fixnum (ash ,sxhash -8)) - (the fixnum (ash ,sxhash -16)) - (the fixnum (ash ,sxhash -19)))) - 254)) - 2))) + (+ (the fixnum + (rem (the fixnum + (logxor ,length + ,sxhash + (the fixnum (ash ,sxhash -8)) + (the fixnum (ash ,sxhash -16)) + (the fixnum (ash ,sxhash -19)))) + 254)) + 2))) ;;; FIXME: should be wrapped in EVAL-WHEN (COMPILE EXECUTE) ;;; Add a symbol to a package hashtable. The symbol is assumed ;;; not to be present. (defun add-symbol (table symbol) (let* ((vec (package-hashtable-table table)) - (hash (package-hashtable-hash table)) - (len (length vec)) - (sxhash (%sxhash-simple-string (symbol-name symbol))) - (h2 (the fixnum (1+ (the fixnum (rem sxhash - (the fixnum (- len 2)))))))) + (hash (package-hashtable-hash table)) + (len (length vec)) + (sxhash (%sxhash-simple-string (symbol-name symbol))) + (h2 (the fixnum (1+ (the fixnum (rem sxhash + (the fixnum (- len 2)))))))) (declare (fixnum len sxhash h2)) (cond ((zerop (the fixnum (package-hashtable-free table))) - (make-or-remake-package-hashtable (* (package-hashtable-size table) - 2) - table) - (add-symbol table symbol) - (dotimes (i len) - (declare (fixnum i)) - (when (> (the fixnum (aref hash i)) 1) - (add-symbol table (svref vec i))))) - (t - (do ((i (rem sxhash len) (rem (+ i h2) len))) - ((< (the fixnum (aref hash i)) 2) - (if (zerop (the fixnum (aref hash i))) - (decf (package-hashtable-free table)) - (decf (package-hashtable-deleted table))) - (setf (svref vec i) symbol) - (setf (aref hash i) - (entry-hash (length (symbol-name symbol)) - sxhash))) - (declare (fixnum i))))))) + (make-or-remake-package-hashtable (* (package-hashtable-size table) + 2) + table) + (add-symbol table symbol) + (dotimes (i len) + (declare (fixnum i)) + (when (> (the fixnum (aref hash i)) 1) + (add-symbol table (svref vec i))))) + (t + (do ((i (rem sxhash len) (rem (+ i h2) len))) + ((< (the fixnum (aref hash i)) 2) + (if (zerop (the fixnum (aref hash i))) + (decf (package-hashtable-free table)) + (decf (package-hashtable-deleted table))) + (setf (svref vec i) symbol) + (setf (aref hash i) + (entry-hash (length (symbol-name symbol)) + sxhash))) + (declare (fixnum i))))))) ;;; Find where the symbol named STRING is stored in TABLE. INDEX-VAR ;;; is bound to the index, or NIL if it is not present. SYMBOL-VAR ;;; is bound to the symbol. LENGTH and HASH are the length and sxhash ;;; of STRING. ENTRY-HASH is the entry-hash of the string and length. (defmacro with-symbol ((index-var symbol-var table string length sxhash - entry-hash) - &body forms) + entry-hash) + &body forms) (let ((vec (gensym)) (hash (gensym)) (len (gensym)) (h2 (gensym)) - (name (gensym)) (name-len (gensym)) (ehash (gensym))) + (name (gensym)) (name-len (gensym)) (ehash (gensym))) `(let* ((,vec (package-hashtable-table ,table)) - (,hash (package-hashtable-hash ,table)) - (,len (length ,vec)) - (,h2 (1+ (the index (rem (the index ,sxhash) - (the index (- ,len 2))))))) + (,hash (package-hashtable-hash ,table)) + (,len (length ,vec)) + (,h2 (1+ (the index (rem (the index ,sxhash) + (the index (- ,len 2))))))) (declare (type index ,len ,h2)) (prog ((,index-var (rem (the index ,sxhash) ,len)) - ,symbol-var ,ehash) - (declare (type (or index null) ,index-var)) - LOOP - (setq ,ehash (aref ,hash ,index-var)) - (cond ((eql ,ehash ,entry-hash) - (setq ,symbol-var (svref ,vec ,index-var)) - (let* ((,name (symbol-name ,symbol-var)) - (,name-len (length ,name))) - (declare (type index ,name-len)) - (when (and (= ,name-len ,length) - (string= ,string ,name - :end1 ,length - :end2 ,name-len)) - (go DOIT)))) - ((zerop ,ehash) - (setq ,index-var nil) - (go DOIT))) - (setq ,index-var (+ ,index-var ,h2)) - (when (>= ,index-var ,len) - (setq ,index-var (- ,index-var ,len))) - (go LOOP) - DOIT - (return (progn ,@forms)))))) + ,symbol-var ,ehash) + (declare (type (or index null) ,index-var)) + LOOP + (setq ,ehash (aref ,hash ,index-var)) + (cond ((eql ,ehash ,entry-hash) + (setq ,symbol-var (svref ,vec ,index-var)) + (let* ((,name (symbol-name ,symbol-var)) + (,name-len (length ,name))) + (declare (type index ,name-len)) + (when (and (= ,name-len ,length) + (string= ,string ,name + :end1 ,length + :end2 ,name-len)) + (go DOIT)))) + ((zerop ,ehash) + (setq ,index-var nil) + (go DOIT))) + (setq ,index-var (+ ,index-var ,h2)) + (when (>= ,index-var ,len) + (setq ,index-var (- ,index-var ,len))) + (go LOOP) + DOIT + (return (progn ,@forms)))))) ;;; Delete the entry for STRING in TABLE. The entry must exist. (defun nuke-symbol (table string) (declare (simple-string string)) (let* ((length (length string)) - (hash (%sxhash-simple-string string)) - (ehash (entry-hash length hash))) + (hash (%sxhash-simple-string string)) + (ehash (entry-hash length hash))) (declare (type index length hash)) (with-symbol (index symbol table string length hash ehash) (setf (aref (package-hashtable-hash table) index) 1) @@ -473,32 +473,32 @@ error if any of PACKAGES is not a valid package designator." (declare (type list nicknames)) (dolist (n nicknames) (let* ((n (package-namify n)) - (found (gethash n *package-names*))) + (found (gethash n *package-names*))) (cond ((not found) - (setf (gethash n *package-names*) package) - (push n (package-%nicknames package))) - ((eq found package)) - ((string= (the string (package-%name found)) n) + (setf (gethash n *package-names*) package) + (push n (package-%nicknames package))) + ((eq found package)) + ((string= (the string (package-%name found)) n) (cerror "Ignore this nickname." - 'simple-package-error - :package package - :format-control "~S is a package name, so it cannot be a nickname for ~S." - :format-arguments (list n (package-%name package)))) - (t + 'simple-package-error + :package package + :format-control "~S is a package name, so it cannot be a nickname for ~S." + :format-arguments (list n (package-%name package)))) + (t (cerror "Leave this nickname alone." - 'simple-package-error - :package package - :format-control "~S is already a nickname for ~S." - :format-arguments (list n (package-%name found)))))))) + 'simple-package-error + :package package + :format-control "~S is already a nickname for ~S." + :format-arguments (list n (package-%name found)))))))) (defun make-package (name &key - (use '#.*default-package-use-list*) - nicknames - (internal-symbols 10) - (external-symbols 10)) + (use '#.*default-package-use-list*) + nicknames + (internal-symbols 10) + (external-symbols 10)) #!+sb-doc #.(format nil - "Make a new package having the specified NAME, NICKNAMES, and + "Make a new package having the specified NAME, NICKNAMES, and USE list. :INTERNAL-SYMBOLS and :EXTERNAL-SYMBOLS are estimates for the number of internal and external symbols which will ultimately be present in the package. The default value of @@ -511,20 +511,20 @@ error if any of PACKAGES is not a valid package designator." (when (find-package name) ;; ANSI specifies that this error is correctable. (cerror "Leave existing package alone." - "A package named ~S already exists" name)) + "A package named ~S already exists" name)) (let* ((name (package-namify name)) - (package (internal-make-package - :%name name - :internal-symbols (make-or-remake-package-hashtable - internal-symbols) - :external-symbols (make-or-remake-package-hashtable - external-symbols)))) + (package (internal-make-package + :%name name + :internal-symbols (make-or-remake-package-hashtable + internal-symbols) + :external-symbols (make-or-remake-package-hashtable + external-symbols)))) ;; Do a USE-PACKAGE for each thing in the USE list so that checking for ;; conflicting exports among used packages is done. (if *in-package-init* - (push (list use package) *!deferred-use-packages*) - (use-package use package)) + (push (list use package) *!deferred-use-packages*) + (use-package use package)) ;; FIXME: ENTER-NEW-NICKNAMES can fail (ERROR) if nicknames are illegal, ;; which would leave us with possibly-bad side effects from the earlier @@ -549,28 +549,28 @@ error if any of PACKAGES is not a valid package designator." #!+sb-doc "Changes the name and nicknames for a package." (let* ((package (find-undeleted-package-or-lose package)) - (name (package-namify name)) - (found (find-package name)) - (nicks (mapcar #'string nicknames))) + (name (package-namify name)) + (found (find-package name)) + (nicks (mapcar #'string nicknames))) (unless (or (not found) (eq found package)) (error 'simple-package-error - :package name - :format-control "A package named ~S already exists." - :format-arguments (list name))) + :package name + :format-control "A package named ~S already exists." + :format-arguments (list name))) (with-single-package-locked-error () - (unless (and (string= name (package-name package)) - (null (set-difference nicks (package-nicknames package) - :test #'string=))) - (assert-package-unlocked package "rename as ~A~@[ with nickname~P ~ - ~{~A~^, ~}~]" - name (length nicks) nicks)) + (unless (and (string= name (package-name package)) + (null (set-difference nicks (package-nicknames package) + :test #'string=))) + (assert-package-unlocked package "rename as ~A~@[ with nickname~P ~ + ~{~A~^, ~}~]" + name (length nicks) nicks)) ;; do the renaming (remhash (package-%name package) *package-names*) (dolist (n (package-%nicknames package)) - (remhash n *package-names*)) + (remhash n *package-names*)) (setf (package-%name package) name - (gethash name *package-names*) package - (package-%nicknames package) ()) + (gethash name *package-names*) package + (package-%nicknames package) ()) (enter-new-nicknames package nicknames)) package)) @@ -579,10 +579,10 @@ error if any of PACKAGES is not a valid package designator." "Delete the package designated by PACKAGE-DESIGNATOR from the package system data structures." (let ((package (if (packagep package-designator) - package-designator - (find-package package-designator)))) + package-designator + (find-package package-designator)))) (cond ((not package) - ;; This continuable error is required by ANSI. + ;; This continuable error is required by ANSI. (cerror "Return ~S." (make-condition @@ -591,14 +591,14 @@ error if any of PACKAGES is not a valid package designator." :format-control "There is no package named ~S." :format-arguments (list package-designator)) nil)) - ((not (package-name package)) ; already deleted - nil) - (t - (with-single-package-locked-error - (:package package "deleting package ~A" package) - (let ((use-list (package-used-by-list package))) - (when use-list - ;; This continuable error is specified by ANSI. + ((not (package-name package)) ; already deleted + nil) + (t + (with-single-package-locked-error + (:package package "deleting package ~A" package) + (let ((use-list (package-used-by-list package))) + (when use-list + ;; This continuable error is specified by ANSI. (cerror "Remove dependency in other packages." (make-condition @@ -609,39 +609,39 @@ error if any of PACKAGES is not a valid package designator." :format-arguments (list (package-name package) (length use-list) (mapcar #'package-name use-list)))) - (dolist (p use-list) - (unuse-package package p)))) - (dolist (used (package-use-list package)) - (unuse-package used package)) - (do-symbols (sym package) - (unintern sym package)) - (remhash (package-name package) *package-names*) - (dolist (nick (package-nicknames package)) - (remhash nick *package-names*)) - (setf (package-%name package) nil - ;; Setting PACKAGE-%NAME to NIL is required in order to - ;; make PACKAGE-NAME return NIL for a deleted package as - ;; ANSI requires. Setting the other slots to NIL - ;; and blowing away the PACKAGE-HASHTABLES is just done - ;; for tidiness and to help the GC. - (package-%nicknames package) nil - (package-%use-list package) nil - (package-tables package) nil - (package-%shadowing-symbols package) nil - (package-internal-symbols package) - (make-or-remake-package-hashtable 0) - (package-external-symbols package) - (make-or-remake-package-hashtable 0)) - t))))) + (dolist (p use-list) + (unuse-package package p)))) + (dolist (used (package-use-list package)) + (unuse-package used package)) + (do-symbols (sym package) + (unintern sym package)) + (remhash (package-name package) *package-names*) + (dolist (nick (package-nicknames package)) + (remhash nick *package-names*)) + (setf (package-%name package) nil + ;; Setting PACKAGE-%NAME to NIL is required in order to + ;; make PACKAGE-NAME return NIL for a deleted package as + ;; ANSI requires. Setting the other slots to NIL + ;; and blowing away the PACKAGE-HASHTABLES is just done + ;; for tidiness and to help the GC. + (package-%nicknames package) nil + (package-%use-list package) nil + (package-tables package) nil + (package-%shadowing-symbols package) nil + (package-internal-symbols package) + (make-or-remake-package-hashtable 0) + (package-external-symbols package) + (make-or-remake-package-hashtable 0)) + t))))) (defun list-all-packages () #!+sb-doc "Return a list of all existing packages." (let ((res ())) (maphash (lambda (k v) - (declare (ignore k)) - (pushnew v res)) - *package-names*) + (declare (ignore k)) + (pushnew v res)) + *package-names*) res)) (defun intern (name &optional (package (sane-package))) @@ -651,13 +651,13 @@ error if any of PACKAGES is not a valid package designator." ;; We just simple-stringify the name and call INTERN*, where the real ;; logic is. (let ((name (if (simple-string-p name) - name - (coerce name 'simple-string))) - (package (find-undeleted-package-or-lose package))) + name + (coerce name 'simple-string))) + (package (find-undeleted-package-or-lose package))) (declare (simple-string name)) (intern* name - (length name) - package))) + (length name) + package))) (defun find-symbol (name &optional (package (sane-package))) #!+sb-doc @@ -670,8 +670,8 @@ error if any of PACKAGES is not a valid package designator." (let ((name (if (simple-string-p name) name (coerce name 'simple-string)))) (declare (simple-string name)) (find-symbol* name - (length name) - (find-undeleted-package-or-lose package)))) + (length name) + (find-undeleted-package-or-lose package)))) ;;; If the symbol named by the first LENGTH characters of NAME doesn't exist, ;;; then create it, special-casing the keyword package. @@ -679,46 +679,46 @@ error if any of PACKAGES is not a valid package designator." (declare (simple-string name)) (multiple-value-bind (symbol where) (find-symbol* name length package) (cond (where - (values symbol where)) - (t - (let ((symbol-name (subseq name 0 length))) - (with-single-package-locked-error - (:package package "interning ~A" symbol-name) - (let ((symbol (make-symbol symbol-name))) - (%set-symbol-package symbol package) - (cond ((eq package *keyword-package*) - (add-symbol (package-external-symbols package) symbol) - (%set-symbol-value symbol symbol)) - (t - (add-symbol (package-internal-symbols package) symbol))) - (values symbol nil)))))))) + (values symbol where)) + (t + (let ((symbol-name (subseq name 0 length))) + (with-single-package-locked-error + (:package package "interning ~A" symbol-name) + (let ((symbol (make-symbol symbol-name))) + (%set-symbol-package symbol package) + (cond ((eq package *keyword-package*) + (add-symbol (package-external-symbols package) symbol) + (%set-symbol-value symbol symbol)) + (t + (add-symbol (package-internal-symbols package) symbol))) + (values symbol nil)))))))) ;;; Check internal and external symbols, then scan down the list ;;; of hashtables for inherited symbols. When an inherited symbol ;;; is found pull that table to the beginning of the list. (defun find-symbol* (string length package) (declare (simple-string string) - (type index length)) + (type index length)) (let* ((hash (%sxhash-simple-substring string length)) - (ehash (entry-hash length hash))) + (ehash (entry-hash length hash))) (declare (type index hash ehash)) (with-symbol (found symbol (package-internal-symbols package) - string length hash ehash) + string length hash ehash) (when found - (return-from find-symbol* (values symbol :internal)))) + (return-from find-symbol* (values symbol :internal)))) (with-symbol (found symbol (package-external-symbols package) - string length hash ehash) + string length hash ehash) (when found - (return-from find-symbol* (values symbol :external)))) + (return-from find-symbol* (values symbol :external)))) (let ((head (package-tables package))) (do ((prev head table) - (table (cdr head) (cdr table))) - ((null table) (values nil nil)) - (with-symbol (found symbol (car table) string length hash ehash) - (when found - (unless (eq prev head) - (shiftf (cdr prev) (cdr table) (cdr head) table)) - (return-from find-symbol* (values symbol :inherited)))))))) + (table (cdr head) (cdr table))) + ((null table) (values nil nil)) + (with-symbol (found symbol (car table) string length hash ehash) + (when found + (unless (eq prev head) + (shiftf (cdr prev) (cdr table) (cdr head) table)) + (return-from find-symbol* (values symbol :inherited)))))))) ;;; Similar to FIND-SYMBOL, but only looks for an external symbol. ;;; This is used for fast name-conflict checking in this file and symbol @@ -726,11 +726,11 @@ error if any of PACKAGES is not a valid package designator." (defun find-external-symbol (string package) (declare (simple-string string)) (let* ((length (length string)) - (hash (%sxhash-simple-string string)) - (ehash (entry-hash length hash))) + (hash (%sxhash-simple-string string)) + (ehash (entry-hash length hash))) (declare (type index length hash)) (with-symbol (found symbol (package-external-symbols package) - string length hash ehash) + string length hash ehash) (values symbol found)))) (define-condition name-conflict (reference-condition package-error) @@ -874,53 +874,53 @@ error if any of PACKAGES is not a valid package designator." then T is returned, otherwise NIL. If PACKAGE is SYMBOL's home package, then it is made uninterned." (let* ((package (find-undeleted-package-or-lose package)) - (name (symbol-name symbol)) - (shadowing-symbols (package-%shadowing-symbols package))) + (name (symbol-name symbol)) + (shadowing-symbols (package-%shadowing-symbols package))) (declare (list shadowing-symbols)) (with-single-package-locked-error () (when (find-symbol name package) - (assert-package-unlocked package "uninterning ~A" name)) - + (assert-package-unlocked package "uninterning ~A" name)) + ;; If a name conflict is revealed, give us a chance to ;; shadowing-import one of the accessible symbols. (when (member symbol shadowing-symbols) - (let ((cset ())) - (dolist (p (package-%use-list package)) - (multiple-value-bind (s w) (find-external-symbol name p) - (when w (pushnew s cset)))) - (when (cdr cset) + (let ((cset ())) + (dolist (p (package-%use-list package)) + (multiple-value-bind (s w) (find-external-symbol name p) + (when w (pushnew s cset)))) + (when (cdr cset) (apply #'name-conflict package 'unintern symbol cset) (return-from unintern t))) - (setf (package-%shadowing-symbols package) - (remove symbol shadowing-symbols))) + (setf (package-%shadowing-symbols package) + (remove symbol shadowing-symbols))) (multiple-value-bind (s w) (find-symbol name package) - (declare (ignore s)) - (cond ((or (eq w :internal) (eq w :external)) - (nuke-symbol (if (eq w :internal) - (package-internal-symbols package) - (package-external-symbols package)) - name) - (if (eq (symbol-package symbol) package) - (%set-symbol-package symbol nil)) - t) - (t nil)))))) + (declare (ignore s)) + (cond ((or (eq w :internal) (eq w :external)) + (nuke-symbol (if (eq w :internal) + (package-internal-symbols package) + (package-external-symbols package)) + name) + (if (eq (symbol-package symbol) package) + (%set-symbol-package symbol nil)) + t) + (t nil)))))) ;;; Take a symbol-or-list-of-symbols and return a list, checking types. (defun symbol-listify (thing) (cond ((listp thing) - (dolist (s thing) - (unless (symbolp s) (error "~S is not a symbol." s))) - thing) - ((symbolp thing) (list thing)) - (t - (error "~S is neither a symbol nor a list of symbols." thing)))) + (dolist (s thing) + (unless (symbolp s) (error "~S is not a symbol." s))) + thing) + ((symbolp thing) (list thing)) + (t + (error "~S is neither a symbol nor a list of symbols." thing)))) (defun string-listify (thing) - (mapcar #'string (if (listp thing) - thing - (list thing)))) + (mapcar #'string (if (listp thing) + thing + (list thing)))) ;;; This is like UNINTERN, except if SYMBOL is inherited, it chases ;;; down the package it is inherited from and uninterns it there. Used @@ -929,59 +929,59 @@ error if any of PACKAGES is not a valid package designator." (defun moby-unintern (symbol package) (unless (member symbol (package-%shadowing-symbols package)) (or (unintern symbol package) - (let ((name (symbol-name symbol))) - (multiple-value-bind (s w) (find-symbol name package) - (declare (ignore s)) - (when (eq w :inherited) - (dolist (q (package-%use-list package)) - (multiple-value-bind (u x) (find-external-symbol name q) - (declare (ignore u)) - (when x - (unintern symbol q) - (return t)))))))))) + (let ((name (symbol-name symbol))) + (multiple-value-bind (s w) (find-symbol name package) + (declare (ignore s)) + (when (eq w :inherited) + (dolist (q (package-%use-list package)) + (multiple-value-bind (u x) (find-external-symbol name q) + (declare (ignore u)) + (when x + (unintern symbol q) + (return t)))))))))) (defun export (symbols &optional (package (sane-package))) #!+sb-doc "Exports SYMBOLS from PACKAGE, checking that no name conflicts result." (let ((package (find-undeleted-package-or-lose package)) - (syms ())) + (syms ())) ;; Punt any symbols that are already external. (dolist (sym (symbol-listify symbols)) (multiple-value-bind (s w) - (find-external-symbol (symbol-name sym) package) - (declare (ignore s)) - (unless (or w (member sym syms)) - (push sym syms)))) + (find-external-symbol (symbol-name sym) package) + (declare (ignore s)) + (unless (or w (member sym syms)) + (push sym syms)))) (with-single-package-locked-error () (when syms - (assert-package-unlocked package "exporting symbol~P ~{~A~^, ~}" - (length syms) syms)) + (assert-package-unlocked package "exporting symbol~P ~{~A~^, ~}" + (length syms) syms)) ;; Find symbols and packages with conflicts. (let ((used-by (package-%used-by-list package)) - (cset ())) - (dolist (sym syms) - (let ((name (symbol-name sym))) - (dolist (p used-by) - (multiple-value-bind (s w) (find-symbol name p) - (when (and w + (cset ())) + (dolist (sym syms) + (let ((name (symbol-name sym))) + (dolist (p used-by) + (multiple-value-bind (s w) (find-symbol name p) + (when (and w (not (eq s sym)) - (not (member s (package-%shadowing-symbols p)))) + (not (member s (package-%shadowing-symbols p)))) ;; Beware: the name conflict is in package P, not in ;; PACKAGE. (name-conflict p 'export sym sym s) (pushnew sym cset)))))) - (when cset + (when cset (setq syms (set-difference syms cset)))) ;; Check that all symbols are accessible. If not, ask to import them. (let ((missing ()) - (imports ())) - (dolist (sym syms) - (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) - (cond ((not (and w (eq s sym))) - (push sym missing)) - ((eq w :inherited) - (push sym imports))))) - (when missing + (imports ())) + (dolist (sym syms) + (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) + (cond ((not (and w (eq s sym))) + (push sym missing)) + ((eq w :inherited) + (push sym imports))))) + (when missing (cerror "~S these symbols into the ~A package." (make-condition @@ -991,15 +991,15 @@ error if any of PACKAGES is not a valid package designator." "~@" :format-arguments (list (package-%name package) missing)) 'import (package-%name package)) - (import missing package)) - (import imports package)) + (import missing package)) + (import imports package)) ;; And now, three pages later, we export the suckers. (let ((internal (package-internal-symbols package)) - (external (package-external-symbols package))) - (dolist (sym syms) - (nuke-symbol internal (symbol-name sym)) - (add-symbol external sym)))) + (external (package-external-symbols package))) + (dolist (sym syms) + (nuke-symbol internal (symbol-name sym)) + (add-symbol external sym)))) t)) ;;; Check that all symbols are accessible, then move from external to internal. @@ -1007,24 +1007,24 @@ error if any of PACKAGES is not a valid package designator." #!+sb-doc "Makes SYMBOLS no longer exported from PACKAGE." (let ((package (find-undeleted-package-or-lose package)) - (syms ())) + (syms ())) (dolist (sym (symbol-listify symbols)) (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) - (cond ((or (not w) (not (eq s sym))) - (error 'simple-package-error - :package package - :format-control "~S is not accessible in the ~A package." - :format-arguments (list sym (package-%name package)))) - ((eq w :external) (pushnew sym syms))))) + (cond ((or (not w) (not (eq s sym))) + (error 'simple-package-error + :package package + :format-control "~S is not accessible in the ~A package." + :format-arguments (list sym (package-%name package)))) + ((eq w :external) (pushnew sym syms))))) (with-single-package-locked-error () (when syms - (assert-package-unlocked package "unexporting symbol~P ~{~A~^, ~}" - (length syms) syms)) + (assert-package-unlocked package "unexporting symbol~P ~{~A~^, ~}" + (length syms) syms)) (let ((internal (package-internal-symbols package)) - (external (package-external-symbols package))) - (dolist (sym syms) - (add-symbol internal sym) - (nuke-symbol external (symbol-name sym))))) + (external (package-external-symbols package))) + (dolist (sym syms) + (add-symbol internal sym) + (nuke-symbol external (symbol-name sym))))) t)) ;;; Check for name conflict caused by the import and let the user @@ -1035,9 +1035,9 @@ error if any of PACKAGES is not a valid package designator." is already accessible then it has no effect. If a name conflict would result from the importation, then a correctable error is signalled." (let* ((package (find-undeleted-package-or-lose package)) - (symbols (symbol-listify symbols)) - (homeless (remove-if #'symbol-package symbols)) - (syms ())) + (symbols (symbol-listify symbols)) + (homeless (remove-if #'symbol-package symbols)) + (syms ())) (with-single-package-locked-error () (dolist (sym symbols) (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) @@ -1051,16 +1051,16 @@ error if any of PACKAGES is not a valid package designator." (name-conflict package 'import sym sym s)) ((eq w :inherited) (push sym syms))))) (when (or homeless syms) - (let ((union (delete-duplicates (append homeless syms)))) - (assert-package-unlocked package "importing symbol~P ~{~A~^, ~}" - (length union) union))) + (let ((union (delete-duplicates (append homeless syms)))) + (assert-package-unlocked package "importing symbol~P ~{~A~^, ~}" + (length union) union))) ;; Add the new symbols to the internal hashtable. (let ((internal (package-internal-symbols package))) - (dolist (sym syms) - (add-symbol internal sym))) + (dolist (sym syms) + (add-symbol internal sym))) ;; If any of the symbols are uninterned, make them be owned by PACKAGE. (dolist (sym homeless) - (%set-symbol-package sym package)) + (%set-symbol-package sym package)) t))) ;;; If a conflicting symbol is present, unintern it, otherwise just @@ -1070,26 +1070,26 @@ error if any of PACKAGES is not a valid package designator." "Import SYMBOLS into package, disregarding any name conflict. If a symbol of the same name is present, then it is uninterned." (let* ((package (find-undeleted-package-or-lose package)) - (internal (package-internal-symbols package)) - (symbols (symbol-listify symbols)) - (lock-asserted-p nil)) + (internal (package-internal-symbols package)) + (symbols (symbol-listify symbols)) + (lock-asserted-p nil)) (with-single-package-locked-error () (dolist (sym symbols) - (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) - (unless (or lock-asserted-p - (and (eq s sym) - (member s (package-shadowing-symbols package)))) - (assert-package-unlocked package "shadowing-importing symbol~P ~ + (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) + (unless (or lock-asserted-p + (and (eq s sym) + (member s (package-shadowing-symbols package)))) + (assert-package-unlocked package "shadowing-importing symbol~P ~ ~{~A~^, ~}" (length symbols) symbols) - (setf lock-asserted-p t)) - (unless (and w (not (eq w :inherited)) (eq s sym)) - (when (or (eq w :internal) (eq w :external)) - ;; If it was shadowed, we don't want UNINTERN to flame out... - (setf (package-%shadowing-symbols package) - (remove s (the list (package-%shadowing-symbols package)))) - (unintern s package)) - (add-symbol internal sym)) - (pushnew sym (package-%shadowing-symbols package)))))) + (setf lock-asserted-p t)) + (unless (and w (not (eq w :inherited)) (eq s sym)) + (when (or (eq w :internal) (eq w :external)) + ;; If it was shadowed, we don't want UNINTERN to flame out... + (setf (package-%shadowing-symbols package) + (remove s (the list (package-%shadowing-symbols package)))) + (unintern s package)) + (add-symbol internal sym)) + (pushnew sym (package-%shadowing-symbols package)))))) t) (defun shadow (symbols &optional (package (sane-package))) @@ -1099,25 +1099,25 @@ error if any of PACKAGES is not a valid package designator." present in PACKAGE, then the existing symbol is placed in the shadowing symbols list if it is not already present." (let* ((package (find-undeleted-package-or-lose package)) - (internal (package-internal-symbols package)) - (symbols (string-listify symbols)) - (lock-asserted-p nil)) + (internal (package-internal-symbols package)) + (symbols (string-listify symbols)) + (lock-asserted-p nil)) (flet ((present-p (w) - (and w (not (eq w :inherited))))) + (and w (not (eq w :inherited))))) (with-single-package-locked-error () - (dolist (name symbols) - (multiple-value-bind (s w) (find-symbol name package) - (unless (or lock-asserted-p - (and (present-p w) - (member s (package-shadowing-symbols package)))) - (assert-package-unlocked package "shadowing symbol~P ~{~A~^, ~}" - (length symbols) symbols) - (setf lock-asserted-p t)) - (unless (present-p w) - (setq s (make-symbol name)) - (%set-symbol-package s package) - (add-symbol internal s)) - (pushnew s (package-%shadowing-symbols package))))))) + (dolist (name symbols) + (multiple-value-bind (s w) (find-symbol name package) + (unless (or lock-asserted-p + (and (present-p w) + (member s (package-shadowing-symbols package)))) + (assert-package-unlocked package "shadowing symbol~P ~{~A~^, ~}" + (length symbols) symbols) + (setf lock-asserted-p t)) + (unless (present-p w) + (setq s (make-symbol name)) + (%set-symbol-package s package) + (add-symbol internal s)) + (pushnew s (package-%shadowing-symbols package))))))) t) ;;; Do stuff to use a package, with all kinds of fun name-conflict checking. @@ -1127,89 +1127,89 @@ error if any of PACKAGES is not a valid package designator." the external symbols of the used packages are accessible as internal symbols in PACKAGE." (let ((packages (package-listify packages-to-use)) - (package (find-undeleted-package-or-lose package))) + (package (find-undeleted-package-or-lose package))) ;; Loop over each package, USE'ing one at a time... (with-single-package-locked-error () (dolist (pkg packages) - (unless (member pkg (package-%use-list package)) - (assert-package-unlocked package "using package~P ~{~A~^, ~}" - (length packages) packages) - (let ((shadowing-symbols (package-%shadowing-symbols package)) - (use-list (package-%use-list package))) - - ;; If the number of symbols already accessible is less - ;; than the number to be inherited then it is faster to - ;; run the test the other way. This is particularly - ;; valuable in the case of a new package USEing - ;; COMMON-LISP. - (cond - ((< (+ (package-internal-symbol-count package) - (package-external-symbol-count package) - (let ((res 0)) - (dolist (p use-list res) - (incf res (package-external-symbol-count p))))) - (package-external-symbol-count pkg)) - (do-symbols (sym package) - (multiple-value-bind (s w) - (find-external-symbol (symbol-name sym) pkg) - (when (and w + (unless (member pkg (package-%use-list package)) + (assert-package-unlocked package "using package~P ~{~A~^, ~}" + (length packages) packages) + (let ((shadowing-symbols (package-%shadowing-symbols package)) + (use-list (package-%use-list package))) + + ;; If the number of symbols already accessible is less + ;; than the number to be inherited then it is faster to + ;; run the test the other way. This is particularly + ;; valuable in the case of a new package USEing + ;; COMMON-LISP. + (cond + ((< (+ (package-internal-symbol-count package) + (package-external-symbol-count package) + (let ((res 0)) + (dolist (p use-list res) + (incf res (package-external-symbol-count p))))) + (package-external-symbol-count pkg)) + (do-symbols (sym package) + (multiple-value-bind (s w) + (find-external-symbol (symbol-name sym) pkg) + (when (and w (not (eq s sym)) - (not (member sym shadowing-symbols))) + (not (member sym shadowing-symbols))) (name-conflict package 'use-package pkg sym s)))) - (dolist (p use-list) - (do-external-symbols (sym p) - (multiple-value-bind (s w) - (find-external-symbol (symbol-name sym) pkg) - (when (and w + (dolist (p use-list) + (do-external-symbols (sym p) + (multiple-value-bind (s w) + (find-external-symbol (symbol-name sym) pkg) + (when (and w (not (eq s sym)) - (not (member + (not (member (find-symbol (symbol-name sym) package) shadowing-symbols))) (name-conflict package 'use-package pkg sym s)))))) - (t - (do-external-symbols (sym pkg) - (multiple-value-bind (s w) - (find-symbol (symbol-name sym) package) - (when (and w + (t + (do-external-symbols (sym pkg) + (multiple-value-bind (s w) + (find-symbol (symbol-name sym) package) + (when (and w (not (eq s sym)) - (not (member s shadowing-symbols))) + (not (member s shadowing-symbols))) (name-conflict package 'use-package pkg sym s))))))) - - (push pkg (package-%use-list package)) - (push (package-external-symbols pkg) (cdr (package-tables package))) - (push package (package-%used-by-list pkg)))))) + + (push pkg (package-%use-list package)) + (push (package-external-symbols pkg) (cdr (package-tables package))) + (push package (package-%used-by-list pkg)))))) t) (defun unuse-package (packages-to-unuse &optional (package (sane-package))) #!+sb-doc "Remove PACKAGES-TO-UNUSE from the USE list for PACKAGE." (let ((package (find-undeleted-package-or-lose package)) - (packages (package-listify packages-to-unuse))) + (packages (package-listify packages-to-unuse))) (with-single-package-locked-error () (dolist (p packages) - (when (member p (package-use-list package)) - (assert-package-unlocked package "unusing package~P ~{~A~^, ~}" - (length packages) packages)) - (setf (package-%use-list package) - (remove p (the list (package-%use-list package)))) - (setf (package-tables package) - (delete (package-external-symbols p) - (the list (package-tables package)))) - (setf (package-%used-by-list p) - (remove package (the list (package-%used-by-list p)))))) + (when (member p (package-use-list package)) + (assert-package-unlocked package "unusing package~P ~{~A~^, ~}" + (length packages) packages)) + (setf (package-%use-list package) + (remove p (the list (package-%use-list package)))) + (setf (package-tables package) + (delete (package-external-symbols p) + (the list (package-tables package)))) + (setf (package-%used-by-list p) + (remove package (the list (package-%used-by-list p)))))) t)) (defun find-all-symbols (string-or-symbol) #!+sb-doc "Return a list of all symbols in the system having the specified name." (let ((string (string string-or-symbol)) - (res ())) + (res ())) (maphash (lambda (k v) - (declare (ignore k)) - (multiple-value-bind (s w) (find-symbol string v) - (when w (pushnew s res)))) - *package-names*) + (declare (ignore k)) + (multiple-value-bind (s w) (find-symbol string v) + (when w (pushnew s res)))) + *package-names*) res)) ;;;; APROPOS and APROPOS-LIST @@ -1223,28 +1223,28 @@ error if any of PACKAGES is not a valid package designator." (write-string " (fbound)"))) (defun apropos-list (string-designator - &optional - package-designator - external-only) + &optional + package-designator + external-only) #!+sb-doc "Like APROPOS, except that it returns a list of the symbols found instead of describing them." (if package-designator (let ((package (find-undeleted-package-or-lose package-designator)) - (string (stringify-name string-designator "APROPOS search")) - (result nil)) - (do-symbols (symbol package) - (when (and (eq (symbol-package symbol) package) - (or (not external-only) - (eq (nth-value 1 (find-symbol (symbol-name symbol) - package)) - :external)) - (search string (symbol-name symbol) :test #'char-equal)) - (push symbol result))) - result) + (string (stringify-name string-designator "APROPOS search")) + (result nil)) + (do-symbols (symbol package) + (when (and (eq (symbol-package symbol) package) + (or (not external-only) + (eq (nth-value 1 (find-symbol (symbol-name symbol) + package)) + :external)) + (search string (symbol-name symbol) :test #'char-equal)) + (push symbol result))) + result) (mapcan (lambda (package) - (apropos-list string-designator package external-only)) - (list-all-packages)))) + (apropos-list string-designator package external-only)) + (list-all-packages)))) (defun apropos (string-designator &optional package external-only) #!+sb-doc @@ -1276,26 +1276,26 @@ error if any of PACKAGES is not a valid package designator." (/show0 "about to loop over *!INITIAL-SYMBOLS* to make packages") (dolist (spec *!initial-symbols*) (let* ((pkg (apply #'make-package (first spec))) - (internal (package-internal-symbols pkg)) - (external (package-external-symbols pkg))) + (internal (package-internal-symbols pkg)) + (external (package-external-symbols pkg))) (/show0 "back from MAKE-PACKAGE, PACKAGE-NAME=..") (/primitive-print (package-name pkg)) ;; Put internal symbols in the internal hashtable and set package. (dolist (symbol (second spec)) - (add-symbol internal symbol) - (%set-symbol-package symbol pkg)) + (add-symbol internal symbol) + (%set-symbol-package symbol pkg)) ;; External symbols same, only go in external table. (dolist (symbol (third spec)) - (add-symbol external symbol) - (%set-symbol-package symbol pkg)) + (add-symbol external symbol) + (%set-symbol-package symbol pkg)) ;; Don't set package for imported symbols. (dolist (symbol (fourth spec)) - (add-symbol internal symbol)) + (add-symbol internal symbol)) (dolist (symbol (fifth spec)) - (add-symbol external symbol)) + (add-symbol external symbol)) ;; Put shadowing symbols in the shadowing symbols list. (setf (package-%shadowing-symbols pkg) (sixth spec)) @@ -1322,12 +1322,12 @@ error if any of PACKAGES is not a valid package designator." ;; ..but instead making our own from scratch here. (/show0 "about to MAKE-PACKAGE COMMON-LISP-USER") (make-package "COMMON-LISP-USER" - :nicknames '("CL-USER") - :use '("COMMON-LISP" - ;; ANSI encourages us to put extension packages - ;; in the USE list of COMMON-LISP-USER. - "SB!ALIEN" "SB!ALIEN" "SB!DEBUG" - "SB!EXT" "SB!GRAY" "SB!PROFILE")) + :nicknames '("CL-USER") + :use '("COMMON-LISP" + ;; ANSI encourages us to put extension packages + ;; in the USE list of COMMON-LISP-USER. + "SB!ALIEN" "SB!ALIEN" "SB!DEBUG" + "SB!EXT" "SB!GRAY" "SB!PROFILE")) ;; Now do the *!DEFERRED-USE-PACKAGES*. (/show0 "about to do *!DEFERRED-USE-PACKAGES*") diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 8c7d5e7..b11d04c 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -16,15 +16,15 @@ ;;;; UNIX-HOST stuff (def!struct (unix-host - (:make-load-form-fun make-unix-host-load-form) - (:include host - (parse #'parse-unix-namestring) - (unparse #'unparse-unix-namestring) - (unparse-host #'unparse-unix-host) - (unparse-directory #'unparse-unix-directory) - (unparse-file #'unparse-unix-file) - (unparse-enough #'unparse-unix-enough) - (customary-case :lower)))) + (:make-load-form-fun make-unix-host-load-form) + (:include host + (parse #'parse-unix-namestring) + (unparse #'unparse-unix-namestring) + (unparse-host #'unparse-unix-host) + (unparse-directory #'unparse-unix-directory) + (unparse-file #'unparse-unix-file) + (unparse-enough #'unparse-unix-enough) + (customary-case :lower)))) (defvar *unix-host* (make-unix-host)) @@ -42,19 +42,19 @@ (def!method print-object ((pathname pathname) stream) (let ((namestring (handler-case (namestring pathname) - (error nil)))) + (error nil)))) (if namestring - (format stream "#P~S" (coerce namestring '(simple-array character (*)))) - (print-unreadable-object (pathname stream :type t) - (format stream - "~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~ + (format stream "#P~S" (coerce namestring '(simple-array character (*)))) + (print-unreadable-object (pathname stream :type t) + (format stream + "~@<(with no namestring) ~_:HOST ~S ~_:DEVICE ~S ~_:DIRECTORY ~S ~ ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S~:>" - (%pathname-host pathname) - (%pathname-device pathname) - (%pathname-directory pathname) - (%pathname-name pathname) - (%pathname-type pathname) - (%pathname-version pathname)))))) + (%pathname-host pathname) + (%pathname-device pathname) + (%pathname-directory pathname) + (%pathname-name pathname) + (%pathname-type pathname) + (%pathname-version pathname)))))) (def!method make-load-form ((pathname pathname) &optional environment) (make-load-form-saving-slots pathname :environment environment)) @@ -70,15 +70,15 @@ ;; case, and uppercase is the ordinary way to do that. (flet ((upcase-maybe (x) (typecase x (string (logical-word-or-lose x)) (t x)))) (if (typep host 'logical-host) - (%make-logical-pathname host - :unspecific - (mapcar #'upcase-maybe directory) - (upcase-maybe name) - (upcase-maybe type) - version) - (progn - (aver (eq host *unix-host*)) - (%make-pathname host device directory name type version))))) + (%make-logical-pathname host + :unspecific + (mapcar #'upcase-maybe directory) + (upcase-maybe name) + (upcase-maybe type) + version) + (progn + (aver (eq host *unix-host*)) + (%make-pathname host device directory name type version))))) ;;; Hash table searching maps a logical pathname's host to its ;;; physical pathname translation. @@ -92,83 +92,83 @@ (def!method print-object ((pattern pattern) stream) (print-unreadable-object (pattern stream :type t) (if *print-pretty* - (let ((*print-escape* t)) - (pprint-fill stream (pattern-pieces pattern) nil)) - (prin1 (pattern-pieces pattern) stream)))) + (let ((*print-escape* t)) + (pprint-fill stream (pattern-pieces pattern) nil)) + (prin1 (pattern-pieces pattern) stream)))) (defun pattern= (pattern1 pattern2) (declare (type pattern pattern1 pattern2)) (let ((pieces1 (pattern-pieces pattern1)) - (pieces2 (pattern-pieces pattern2))) + (pieces2 (pattern-pieces pattern2))) (and (= (length pieces1) (length pieces2)) - (every (lambda (piece1 piece2) - (typecase piece1 - (simple-string - (and (simple-string-p piece2) - (string= piece1 piece2))) - (cons - (and (consp piece2) - (eq (car piece1) (car piece2)) - (string= (cdr piece1) (cdr piece2)))) - (t - (eq piece1 piece2)))) - pieces1 - pieces2)))) + (every (lambda (piece1 piece2) + (typecase piece1 + (simple-string + (and (simple-string-p piece2) + (string= piece1 piece2))) + (cons + (and (consp piece2) + (eq (car piece1) (car piece2)) + (string= (cdr piece1) (cdr piece2)))) + (t + (eq piece1 piece2)))) + pieces1 + pieces2)))) ;;; If the string matches the pattern returns the multiple values T ;;; and a list of the matched strings. (defun pattern-matches (pattern string) (declare (type pattern pattern) - (type simple-string string)) + (type simple-string string)) (let ((len (length string))) (labels ((maybe-prepend (subs cur-sub chars) - (if cur-sub - (let* ((len (length chars)) - (new (make-string len)) - (index len)) - (dolist (char chars) - (setf (schar new (decf index)) char)) - (cons new subs)) - subs)) - (matches (pieces start subs cur-sub chars) - (if (null pieces) - (if (= start len) - (values t (maybe-prepend subs cur-sub chars)) - (values nil nil)) - (let ((piece (car pieces))) - (etypecase piece - (simple-string - (let ((end (+ start (length piece)))) - (and (<= end len) - (string= piece string - :start2 start :end2 end) - (matches (cdr pieces) end - (maybe-prepend subs cur-sub chars) - nil nil)))) - (list - (ecase (car piece) - (:character-set - (and (< start len) - (let ((char (schar string start))) - (if (find char (cdr piece) :test #'char=) - (matches (cdr pieces) (1+ start) subs t - (cons char chars)))))))) - ((member :single-char-wild) - (and (< start len) - (matches (cdr pieces) (1+ start) subs t - (cons (schar string start) chars)))) - ((member :multi-char-wild) - (multiple-value-bind (won new-subs) - (matches (cdr pieces) start subs t chars) - (if won - (values t new-subs) - (and (< start len) - (matches pieces (1+ start) subs t - (cons (schar string start) - chars))))))))))) + (if cur-sub + (let* ((len (length chars)) + (new (make-string len)) + (index len)) + (dolist (char chars) + (setf (schar new (decf index)) char)) + (cons new subs)) + subs)) + (matches (pieces start subs cur-sub chars) + (if (null pieces) + (if (= start len) + (values t (maybe-prepend subs cur-sub chars)) + (values nil nil)) + (let ((piece (car pieces))) + (etypecase piece + (simple-string + (let ((end (+ start (length piece)))) + (and (<= end len) + (string= piece string + :start2 start :end2 end) + (matches (cdr pieces) end + (maybe-prepend subs cur-sub chars) + nil nil)))) + (list + (ecase (car piece) + (:character-set + (and (< start len) + (let ((char (schar string start))) + (if (find char (cdr piece) :test #'char=) + (matches (cdr pieces) (1+ start) subs t + (cons char chars)))))))) + ((member :single-char-wild) + (and (< start len) + (matches (cdr pieces) (1+ start) subs t + (cons (schar string start) chars)))) + ((member :multi-char-wild) + (multiple-value-bind (won new-subs) + (matches (cdr pieces) start subs t chars) + (if won + (values t new-subs) + (and (< start len) + (matches pieces (1+ start) subs t + (cons (schar string start) + chars))))))))))) (multiple-value-bind (won subs) - (matches (pattern-pieces pattern) 0 nil nil nil) - (values won (reverse subs)))))) + (matches (pattern-pieces pattern) 0 nil nil nil) + (values won (reverse subs)))))) ;;; PATHNAME-MATCH-P for directory components (defun directory-components-match (thing wild) @@ -177,23 +177,23 @@ ;; If THING has a null directory, assume that it matches ;; (:ABSOLUTE :WILD-INFERIORS) or (:RELATIVE :WILD-INFERIORS). (and (consp wild) - (null thing) - (member (first wild) '(:absolute :relative)) - (eq (second wild) :wild-inferiors)) + (null thing) + (member (first wild) '(:absolute :relative)) + (eq (second wild) :wild-inferiors)) (and (consp wild) - (let ((wild1 (first wild))) - (if (eq wild1 :wild-inferiors) - (let ((wild-subdirs (rest wild))) - (or (null wild-subdirs) - (loop - (when (directory-components-match thing wild-subdirs) - (return t)) - (pop thing) - (unless thing (return nil))))) - (and (consp thing) - (components-match (first thing) wild1) - (directory-components-match (rest thing) - (rest wild)))))))) + (let ((wild1 (first wild))) + (if (eq wild1 :wild-inferiors) + (let ((wild-subdirs (rest wild))) + (or (null wild-subdirs) + (loop + (when (directory-components-match thing wild-subdirs) + (return t)) + (pop thing) + (unless thing (return nil))))) + (and (consp thing) + (components-match (first thing) wild1) + (directory-components-match (rest thing) + (rest wild)))))))) ;;; Return true if pathname component THING is matched by WILD. (not ;;; commutative) @@ -202,55 +202,55 @@ (or (eq thing wild) (eq wild :wild) (typecase thing - (simple-string - ;; String is matched by itself, a matching pattern or :WILD. - (typecase wild - (pattern - (values (pattern-matches wild thing))) - (simple-string - (string= thing wild)))) - (pattern - ;; A pattern is only matched by an identical pattern. - (and (pattern-p wild) (pattern= thing wild))) - (integer - ;; An integer (version number) is matched by :WILD or the - ;; same integer. This branch will actually always be NIL as - ;; long as the version is a fixnum. - (eql thing wild))))) + (simple-string + ;; String is matched by itself, a matching pattern or :WILD. + (typecase wild + (pattern + (values (pattern-matches wild thing))) + (simple-string + (string= thing wild)))) + (pattern + ;; A pattern is only matched by an identical pattern. + (and (pattern-p wild) (pattern= thing wild))) + (integer + ;; An integer (version number) is matched by :WILD or the + ;; same integer. This branch will actually always be NIL as + ;; long as the version is a fixnum. + (eql thing wild))))) ;;; a predicate for comparing two pathname slot component sub-entries (defun compare-component (this that) (or (eql this that) (typecase this - (simple-string - (and (simple-string-p that) - (string= this that))) - (pattern - (and (pattern-p that) - (pattern= this that))) - (cons - (and (consp that) - (compare-component (car this) (car that)) - (compare-component (cdr this) (cdr that))))))) + (simple-string + (and (simple-string-p that) + (string= this that))) + (pattern + (and (pattern-p that) + (pattern= this that))) + (cons + (and (consp that) + (compare-component (car this) (car that)) + (compare-component (cdr this) (cdr that))))))) ;;;; pathname functions (defun pathname= (pathname1 pathname2) (declare (type pathname pathname1) - (type pathname pathname2)) + (type pathname pathname2)) (and (eq (%pathname-host pathname1) - (%pathname-host pathname2)) + (%pathname-host pathname2)) (compare-component (%pathname-device pathname1) - (%pathname-device pathname2)) + (%pathname-device pathname2)) (compare-component (%pathname-directory pathname1) - (%pathname-directory pathname2)) + (%pathname-directory pathname2)) (compare-component (%pathname-name pathname1) - (%pathname-name pathname2)) + (%pathname-name pathname2)) (compare-component (%pathname-type pathname1) - (%pathname-type pathname2)) + (%pathname-type pathname2)) (or (eq (%pathname-host pathname1) *unix-host*) - (compare-component (%pathname-version pathname1) - (%pathname-version pathname2))))) + (compare-component (%pathname-version pathname1) + (%pathname-version pathname2))))) ;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or ;;; stream), into a pathname in pathname. @@ -261,10 +261,10 @@ (defmacro with-pathname ((pathname pathname-designator) &body body) (let ((pd0 (gensym))) `(let* ((,pd0 ,pathname-designator) - (,pathname (etypecase ,pd0 - (pathname ,pd0) - (string (parse-namestring ,pd0)) - (file-stream (file-name ,pd0))))) + (,pathname (etypecase ,pd0 + (pathname ,pd0) + (string (parse-namestring ,pd0)) + (file-stream (file-name ,pd0))))) ,@body))) ;;; Convert the var, a host or string name for a host, into a @@ -275,10 +275,10 @@ #| (defmacro with-host ((var expr) &body body) `(let ((,var (let ((,var ,expr)) - (typecase ,var - (logical-host ,var) - (string (find-logical-host ,var nil)) - (t nil))))) + (typecase ,var + (logical-host ,var) + (string (find-logical-host ,var nil)) + (t nil))))) ,@body)) |# @@ -293,124 +293,124 @@ (defun maybe-diddle-case (thing diddle-p) (if (and diddle-p (not (or (symbolp thing) (integerp thing)))) (labels ((check-for (pred in) - (typecase in - (pattern - (dolist (piece (pattern-pieces in)) - (when (typecase piece - (simple-string - (check-for pred piece)) - (cons - (case (car piece) - (:character-set - (check-for pred (cdr piece)))))) - (return t)))) - (list - (dolist (x in) - (when (check-for pred x) - (return t)))) - (simple-string - (dotimes (i (length in)) - (when (funcall pred (schar in i)) - (return t)))) - (t nil))) - (diddle-with (fun thing) - (typecase thing - (pattern - (make-pattern - (mapcar (lambda (piece) - (typecase piece - (simple-string - (funcall fun piece)) - (cons - (case (car piece) - (:character-set - (cons :character-set - (funcall fun (cdr piece)))) - (t - piece))) - (t - piece))) - (pattern-pieces thing)))) - (list - (mapcar fun thing)) - (simple-string - (funcall fun thing)) - (t - thing)))) - (let ((any-uppers (check-for #'upper-case-p thing)) - (any-lowers (check-for #'lower-case-p thing))) - (cond ((and any-uppers any-lowers) - ;; mixed case, stays the same - thing) - (any-uppers - ;; all uppercase, becomes all lower case - (diddle-with (lambda (x) (if (stringp x) - (string-downcase x) - x)) thing)) - (any-lowers - ;; all lowercase, becomes all upper case - (diddle-with (lambda (x) (if (stringp x) - (string-upcase x) - x)) thing)) - (t - ;; no letters? I guess just leave it. - thing)))) + (typecase in + (pattern + (dolist (piece (pattern-pieces in)) + (when (typecase piece + (simple-string + (check-for pred piece)) + (cons + (case (car piece) + (:character-set + (check-for pred (cdr piece)))))) + (return t)))) + (list + (dolist (x in) + (when (check-for pred x) + (return t)))) + (simple-string + (dotimes (i (length in)) + (when (funcall pred (schar in i)) + (return t)))) + (t nil))) + (diddle-with (fun thing) + (typecase thing + (pattern + (make-pattern + (mapcar (lambda (piece) + (typecase piece + (simple-string + (funcall fun piece)) + (cons + (case (car piece) + (:character-set + (cons :character-set + (funcall fun (cdr piece)))) + (t + piece))) + (t + piece))) + (pattern-pieces thing)))) + (list + (mapcar fun thing)) + (simple-string + (funcall fun thing)) + (t + thing)))) + (let ((any-uppers (check-for #'upper-case-p thing)) + (any-lowers (check-for #'lower-case-p thing))) + (cond ((and any-uppers any-lowers) + ;; mixed case, stays the same + thing) + (any-uppers + ;; all uppercase, becomes all lower case + (diddle-with (lambda (x) (if (stringp x) + (string-downcase x) + x)) thing)) + (any-lowers + ;; all lowercase, becomes all upper case + (diddle-with (lambda (x) (if (stringp x) + (string-upcase x) + x)) thing)) + (t + ;; no letters? I guess just leave it. + thing)))) thing)) (defun merge-directories (dir1 dir2 diddle-case) (if (or (eq (car dir1) :absolute) - (null dir2)) + (null dir2)) dir1 (let ((results nil)) - (flet ((add (dir) - (if (and (eq dir :back) - results - (not (member (car results) - '(:back :wild-inferiors)))) - (pop results) - (push dir results)))) - (dolist (dir (maybe-diddle-case dir2 diddle-case)) - (add dir)) - (dolist (dir (cdr dir1)) - (add dir))) - (reverse results)))) + (flet ((add (dir) + (if (and (eq dir :back) + results + (not (member (car results) + '(:back :wild-inferiors)))) + (pop results) + (push dir results)))) + (dolist (dir (maybe-diddle-case dir2 diddle-case)) + (add dir)) + (dolist (dir (cdr dir1)) + (add dir))) + (reverse results)))) (defun merge-pathnames (pathname - &optional - (defaults *default-pathname-defaults*) - (default-version :newest)) + &optional + (defaults *default-pathname-defaults*) + (default-version :newest)) #!+sb-doc "Construct a filled in pathname by completing the unspecified components from the defaults." (declare (type pathname-designator pathname) - (type pathname-designator defaults) - (values pathname)) + (type pathname-designator defaults) + (values pathname)) (with-pathname (defaults defaults) (let ((pathname (let ((*default-pathname-defaults* defaults)) - (pathname pathname)))) + (pathname pathname)))) (let* ((default-host (%pathname-host defaults)) - (pathname-host (%pathname-host pathname)) - (diddle-case - (and default-host pathname-host - (not (eq (host-customary-case default-host) - (host-customary-case pathname-host)))))) - (%make-maybe-logical-pathname - (or pathname-host default-host) - (or (%pathname-device pathname) - (maybe-diddle-case (%pathname-device defaults) - diddle-case)) - (merge-directories (%pathname-directory pathname) - (%pathname-directory defaults) - diddle-case) - (or (%pathname-name pathname) - (maybe-diddle-case (%pathname-name defaults) - diddle-case)) - (or (%pathname-type pathname) - (maybe-diddle-case (%pathname-type defaults) - diddle-case)) - (or (%pathname-version pathname) - (and (not (%pathname-name pathname)) (%pathname-version defaults)) - default-version)))))) + (pathname-host (%pathname-host pathname)) + (diddle-case + (and default-host pathname-host + (not (eq (host-customary-case default-host) + (host-customary-case pathname-host)))))) + (%make-maybe-logical-pathname + (or pathname-host default-host) + (or (%pathname-device pathname) + (maybe-diddle-case (%pathname-device defaults) + diddle-case)) + (merge-directories (%pathname-directory pathname) + (%pathname-directory defaults) + diddle-case) + (or (%pathname-name pathname) + (maybe-diddle-case (%pathname-name defaults) + diddle-case)) + (or (%pathname-type pathname) + (maybe-diddle-case (%pathname-type defaults) + diddle-case)) + (or (%pathname-version pathname) + (and (not (%pathname-name pathname)) (%pathname-version defaults)) + default-version)))))) (defun import-directory (directory diddle-case) (etypecase directory @@ -421,15 +421,15 @@ (collect ((results)) (results (pop directory)) (dolist (piece directory) - (cond ((member piece '(:wild :wild-inferiors :up :back)) - (results piece)) - ((or (simple-string-p piece) (pattern-p piece)) - (results (maybe-diddle-case piece diddle-case))) - ((stringp piece) - (results (maybe-diddle-case (coerce piece 'simple-string) - diddle-case))) - (t - (error "~S is not allowed as a directory component." piece)))) + (cond ((member piece '(:wild :wild-inferiors :up :back)) + (results piece)) + ((or (simple-string-p piece) (pattern-p piece)) + (results (maybe-diddle-case piece diddle-case))) + ((stringp piece) + (results (maybe-diddle-case (coerce piece 'simple-string) + diddle-case))) + (t + (error "~S is not allowed as a directory component." piece)))) (results))) (simple-string `(:absolute @@ -437,100 +437,100 @@ (string `(:absolute ,(maybe-diddle-case (coerce directory 'simple-string) - diddle-case))))) + diddle-case))))) (defun make-pathname (&key host - (device nil devp) - (directory nil dirp) - (name nil namep) - (type nil typep) - (version nil versionp) - defaults - (case :local)) + (device nil devp) + (directory nil dirp) + (name nil namep) + (type nil typep) + (version nil versionp) + defaults + (case :local)) #!+sb-doc "Makes a new pathname from the component arguments. Note that host is a host-structure or string." (declare (type (or string host pathname-component-tokens) host) - (type (or string pathname-component-tokens) device) - (type (or list string pattern pathname-component-tokens) directory) - (type (or string pattern pathname-component-tokens) name type) - (type (or integer pathname-component-tokens (member :newest)) - version) - (type (or pathname-designator null) defaults) - (type (member :common :local) case)) + (type (or string pathname-component-tokens) device) + (type (or list string pattern pathname-component-tokens) directory) + (type (or string pattern pathname-component-tokens) name type) + (type (or integer pathname-component-tokens (member :newest)) + version) + (type (or pathname-designator null) defaults) + (type (member :common :local) case)) (let* ((defaults (when defaults - (with-pathname (defaults defaults) defaults))) - (default-host (if defaults - (%pathname-host defaults) - (pathname-host *default-pathname-defaults*))) - ;; Raymond Toy writes: CLHS says make-pathname can take a - ;; string (as a logical-host) for the host part. We map that - ;; string into the corresponding logical host structure. - ;; - ;; Paul Werkowski writes: - ;; HyperSpec says for the arg to MAKE-PATHNAME; - ;; "host---a valid physical pathname host. ..." - ;; where it probably means -- a valid pathname host. - ;; "valid pathname host n. a valid physical pathname host or - ;; a valid logical pathname host." - ;; and defines - ;; "valid physical pathname host n. any of a string, - ;; a list of strings, or the symbol :unspecific, - ;; that is recognized by the implementation as the name of a host." - ;; "valid logical pathname host n. a string that has been defined - ;; as the name of a logical host. ..." - ;; HS is silent on what happens if the :HOST arg is NOT one of these. - ;; It seems an error message is appropriate. - (host (typecase host - (host host) ; A valid host, use it. - ((string 0) *unix-host*) ; "" cannot be a logical host - (string (find-logical-host host t)) ; logical-host or lose. - (t default-host))) ; unix-host - (diddle-args (and (eq (host-customary-case host) :lower) - (eq case :common))) - (diddle-defaults - (not (eq (host-customary-case host) - (host-customary-case default-host)))) - (dev (if devp device (if defaults (%pathname-device defaults)))) - (dir (import-directory directory diddle-args)) - (ver (cond - (versionp version) - (defaults (%pathname-version defaults)) - (t nil)))) + (with-pathname (defaults defaults) defaults))) + (default-host (if defaults + (%pathname-host defaults) + (pathname-host *default-pathname-defaults*))) + ;; Raymond Toy writes: CLHS says make-pathname can take a + ;; string (as a logical-host) for the host part. We map that + ;; string into the corresponding logical host structure. + ;; + ;; Paul Werkowski writes: + ;; HyperSpec says for the arg to MAKE-PATHNAME; + ;; "host---a valid physical pathname host. ..." + ;; where it probably means -- a valid pathname host. + ;; "valid pathname host n. a valid physical pathname host or + ;; a valid logical pathname host." + ;; and defines + ;; "valid physical pathname host n. any of a string, + ;; a list of strings, or the symbol :unspecific, + ;; that is recognized by the implementation as the name of a host." + ;; "valid logical pathname host n. a string that has been defined + ;; as the name of a logical host. ..." + ;; HS is silent on what happens if the :HOST arg is NOT one of these. + ;; It seems an error message is appropriate. + (host (typecase host + (host host) ; A valid host, use it. + ((string 0) *unix-host*) ; "" cannot be a logical host + (string (find-logical-host host t)) ; logical-host or lose. + (t default-host))) ; unix-host + (diddle-args (and (eq (host-customary-case host) :lower) + (eq case :common))) + (diddle-defaults + (not (eq (host-customary-case host) + (host-customary-case default-host)))) + (dev (if devp device (if defaults (%pathname-device defaults)))) + (dir (import-directory directory diddle-args)) + (ver (cond + (versionp version) + (defaults (%pathname-version defaults)) + (t nil)))) (when (and defaults (not dirp)) (setf dir - (merge-directories dir - (%pathname-directory defaults) - diddle-defaults))) + (merge-directories dir + (%pathname-directory defaults) + diddle-defaults))) (macrolet ((pick (var varp field) - `(cond ((or (simple-string-p ,var) - (pattern-p ,var)) - (maybe-diddle-case ,var diddle-args)) - ((stringp ,var) - (maybe-diddle-case (coerce ,var 'simple-string) - diddle-args)) - (,varp - (maybe-diddle-case ,var diddle-args)) - (defaults - (maybe-diddle-case (,field defaults) - diddle-defaults)) - (t - nil)))) + `(cond ((or (simple-string-p ,var) + (pattern-p ,var)) + (maybe-diddle-case ,var diddle-args)) + ((stringp ,var) + (maybe-diddle-case (coerce ,var 'simple-string) + diddle-args)) + (,varp + (maybe-diddle-case ,var diddle-args)) + (defaults + (maybe-diddle-case (,field defaults) + diddle-defaults)) + (t + nil)))) (%make-maybe-logical-pathname host - dev ; forced to :UNSPECIFIC when logical - dir - (pick name namep %pathname-name) - (pick type typep %pathname-type) - ver)))) + dev ; forced to :UNSPECIFIC when logical + dir + (pick name namep %pathname-name) + (pick type typep %pathname-type) + ver)))) (defun pathname-host (pathname &key (case :local)) #!+sb-doc "Return PATHNAME's host." (declare (type pathname-designator pathname) - (type (member :local :common) case) - (values host) - (ignore case)) + (type (member :local :common) case) + (values host) + (ignore case)) (with-pathname (pathname pathname) (%pathname-host pathname))) @@ -538,48 +538,48 @@ a host-structure or string." #!+sb-doc "Return PATHNAME's device." (declare (type pathname-designator pathname) - (type (member :local :common) case)) + (type (member :local :common) case)) (with-pathname (pathname pathname) (maybe-diddle-case (%pathname-device pathname) - (and (eq case :common) - (eq (host-customary-case - (%pathname-host pathname)) - :lower))))) + (and (eq case :common) + (eq (host-customary-case + (%pathname-host pathname)) + :lower))))) (defun pathname-directory (pathname &key (case :local)) #!+sb-doc "Return PATHNAME's directory." (declare (type pathname-designator pathname) - (type (member :local :common) case)) + (type (member :local :common) case)) (with-pathname (pathname pathname) (maybe-diddle-case (%pathname-directory pathname) - (and (eq case :common) - (eq (host-customary-case - (%pathname-host pathname)) - :lower))))) + (and (eq case :common) + (eq (host-customary-case + (%pathname-host pathname)) + :lower))))) (defun pathname-name (pathname &key (case :local)) #!+sb-doc "Return PATHNAME's name." (declare (type pathname-designator pathname) - (type (member :local :common) case)) + (type (member :local :common) case)) (with-pathname (pathname pathname) (maybe-diddle-case (%pathname-name pathname) - (and (eq case :common) - (eq (host-customary-case - (%pathname-host pathname)) - :lower))))) + (and (eq case :common) + (eq (host-customary-case + (%pathname-host pathname)) + :lower))))) (defun pathname-type (pathname &key (case :local)) #!+sb-doc "Return PATHNAME's type." (declare (type pathname-designator pathname) - (type (member :local :common) case)) + (type (member :local :common) case)) (with-pathname (pathname pathname) (maybe-diddle-case (%pathname-type pathname) - (and (eq case :common) - (eq (host-customary-case - (%pathname-host pathname)) - :lower))))) + (and (eq case :common) + (eq (host-customary-case + (%pathname-host pathname)) + :lower))))) (defun pathname-version (pathname) #!+sb-doc @@ -601,211 +601,211 @@ a host-structure or string." (defun parseable-logical-namestring-p (namestr start end) (catch 'exit (handler-bind - ((namestring-parse-error (lambda (c) - (declare (ignore c)) - (throw 'exit nil)))) + ((namestring-parse-error (lambda (c) + (declare (ignore c)) + (throw 'exit nil)))) (let ((colon (position #\: namestr :start start :end end))) - (when colon - (let ((potential-host - (logical-word-or-lose (subseq namestr start colon)))) - ;; depending on the outcome of CSR comp.lang.lisp post - ;; "can PARSE-NAMESTRING create logical hosts", we may need - ;; to do things with potential-host (create it - ;; temporarily, parse the namestring and unintern the - ;; logical host potential-host on failure. - (declare (ignore potential-host)) - (let ((result - (handler-bind - ((simple-type-error (lambda (c) - (declare (ignore c)) - (throw 'exit nil)))) - (parse-logical-namestring namestr start end)))) - ;; if we got this far, we should have an explicit host - ;; (first return value of parse-logical-namestring) - (aver result) - result))))))) + (when colon + (let ((potential-host + (logical-word-or-lose (subseq namestr start colon)))) + ;; depending on the outcome of CSR comp.lang.lisp post + ;; "can PARSE-NAMESTRING create logical hosts", we may need + ;; to do things with potential-host (create it + ;; temporarily, parse the namestring and unintern the + ;; logical host potential-host on failure. + (declare (ignore potential-host)) + (let ((result + (handler-bind + ((simple-type-error (lambda (c) + (declare (ignore c)) + (throw 'exit nil)))) + (parse-logical-namestring namestr start end)))) + ;; if we got this far, we should have an explicit host + ;; (first return value of parse-logical-namestring) + (aver result) + result))))))) ;;; Handle the case where PARSE-NAMESTRING is actually parsing a ;;; namestring. We pick off the :JUNK-ALLOWED case then find a host to ;;; use for parsing, call the parser, then check whether the host matches. (defun %parse-namestring (namestr host defaults start end junk-allowed) (declare (type (or host null) host) - (type string namestr) - (type index start) - (type (or index null) end)) + (type string namestr) + (type index start) + (type (or index null) end)) (cond (junk-allowed (handler-case - (%parse-namestring namestr host defaults start end nil) + (%parse-namestring namestr host defaults start end nil) (namestring-parse-error (condition) - (values nil (namestring-parse-error-offset condition))))) + (values nil (namestring-parse-error-offset condition))))) (t (let* ((end (%check-vector-sequence-bounds namestr start end))) (multiple-value-bind (new-host device directory file type version) - ;; Comments below are quotes from the HyperSpec - ;; PARSE-NAMESTRING entry, reproduced here to demonstrate - ;; that we actually have to do things this way rather than - ;; some possibly more logical way. - CSR, 2002-04-18 - (cond - ;; "If host is a logical host then thing is parsed as a - ;; logical pathname namestring on the host." - (host (funcall (host-parse host) namestr start end)) - ;; "If host is nil and thing is a syntactically valid - ;; logical pathname namestring containing an explicit - ;; host, then it is parsed as a logical pathname - ;; namestring." - ((parseable-logical-namestring-p namestr start end) - (parse-logical-namestring namestr start end)) - ;; "If host is nil, default-pathname is a logical - ;; pathname, and thing is a syntactically valid logical - ;; pathname namestring without an explicit host, then it - ;; is parsed as a logical pathname namestring on the - ;; host that is the host component of default-pathname." - ;; - ;; "Otherwise, the parsing of thing is - ;; implementation-defined." - ;; - ;; Both clauses are handled here, as the default - ;; *DEFAULT-PATHNAME-DEFAULTS has a SB-IMPL::UNIX-HOST - ;; for a host. - ((pathname-host defaults) - (funcall (host-parse (pathname-host defaults)) - namestr - start - end)) - ;; I don't think we should ever get here, as the default - ;; host will always have a non-null HOST, given that we - ;; can't create a new pathname without going through - ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null - ;; host... - (t (bug "Fallen through COND in %PARSE-NAMESTRING"))) - (when (and host new-host (not (eq new-host host))) - (error 'simple-type-error - :datum new-host - ;; Note: ANSI requires that this be a TYPE-ERROR, - ;; but there seems to be no completely correct - ;; value to use for TYPE-ERROR-EXPECTED-TYPE. - ;; Instead, we return a sort of "type error allowed - ;; type", trying to say "it would be OK if you - ;; passed NIL as the host value" but not mentioning - ;; that a matching string would be OK too. - :expected-type 'null - :format-control - "The host in the namestring, ~S,~@ + ;; Comments below are quotes from the HyperSpec + ;; PARSE-NAMESTRING entry, reproduced here to demonstrate + ;; that we actually have to do things this way rather than + ;; some possibly more logical way. - CSR, 2002-04-18 + (cond + ;; "If host is a logical host then thing is parsed as a + ;; logical pathname namestring on the host." + (host (funcall (host-parse host) namestr start end)) + ;; "If host is nil and thing is a syntactically valid + ;; logical pathname namestring containing an explicit + ;; host, then it is parsed as a logical pathname + ;; namestring." + ((parseable-logical-namestring-p namestr start end) + (parse-logical-namestring namestr start end)) + ;; "If host is nil, default-pathname is a logical + ;; pathname, and thing is a syntactically valid logical + ;; pathname namestring without an explicit host, then it + ;; is parsed as a logical pathname namestring on the + ;; host that is the host component of default-pathname." + ;; + ;; "Otherwise, the parsing of thing is + ;; implementation-defined." + ;; + ;; Both clauses are handled here, as the default + ;; *DEFAULT-PATHNAME-DEFAULTS has a SB-IMPL::UNIX-HOST + ;; for a host. + ((pathname-host defaults) + (funcall (host-parse (pathname-host defaults)) + namestr + start + end)) + ;; I don't think we should ever get here, as the default + ;; host will always have a non-null HOST, given that we + ;; can't create a new pathname without going through + ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null + ;; host... + (t (bug "Fallen through COND in %PARSE-NAMESTRING"))) + (when (and host new-host (not (eq new-host host))) + (error 'simple-type-error + :datum new-host + ;; Note: ANSI requires that this be a TYPE-ERROR, + ;; but there seems to be no completely correct + ;; value to use for TYPE-ERROR-EXPECTED-TYPE. + ;; Instead, we return a sort of "type error allowed + ;; type", trying to say "it would be OK if you + ;; passed NIL as the host value" but not mentioning + ;; that a matching string would be OK too. + :expected-type 'null + :format-control + "The host in the namestring, ~S,~@ does not match the explicit HOST argument, ~S." - :format-arguments (list new-host host))) - (let ((pn-host (or new-host host (pathname-host defaults)))) - (values (%make-maybe-logical-pathname - pn-host device directory file type version) - end))))))) + :format-arguments (list new-host host))) + (let ((pn-host (or new-host host (pathname-host defaults)))) + (values (%make-maybe-logical-pathname + pn-host device directory file type version) + end))))))) ;;; If NAMESTR begins with a colon-terminated, defined, logical host, ;;; then return that host, otherwise return NIL. (defun extract-logical-host-prefix (namestr start end) (declare (type simple-string namestr) - (type index start end) - (values (or logical-host null))) + (type index start end) + (values (or logical-host null))) (let ((colon-pos (position #\: namestr :start start :end end))) (if colon-pos - (values (gethash (nstring-upcase (subseq namestr start colon-pos)) - *logical-hosts*)) - nil))) + (values (gethash (nstring-upcase (subseq namestr start colon-pos)) + *logical-hosts*)) + nil))) (defun parse-namestring (thing - &optional - host - (defaults *default-pathname-defaults*) - &key (start 0) end junk-allowed) + &optional + host + (defaults *default-pathname-defaults*) + &key (start 0) end junk-allowed) (declare (type pathname-designator thing defaults) - (type (or list host string (member :unspecific)) host) - (type index start) - (type (or index null) end) - (type (or t null) junk-allowed) - (values (or null pathname) (or null index))) + (type (or list host string (member :unspecific)) host) + (type index start) + (type (or index null) end) + (type (or t null) junk-allowed) + (values (or null pathname) (or null index))) ;; Generally, redundant specification of information in software, ;; whether in code or in comments, is bad. However, the ANSI spec ;; for this is messy enough that it's hard to hold in short-term ;; memory, so I've recorded these redundant notes on the ;; implications of the ANSI spec. - ;; + ;; ;; According to the ANSI spec, HOST can be a valid pathname host, or ;; a logical host, or NIL. ;; ;; A valid pathname host can be a valid physical pathname host or a ;; valid logical pathname host. - ;; + ;; ;; A valid physical pathname host is "any of a string, a list of ;; strings, or the symbol :UNSPECIFIC, that is recognized by the ;; implementation as the name of a host". In SBCL as of 0.6.9.8, ;; that means :UNSPECIFIC: though someday we might want to ;; generalize it to allow strings like "RTFM.MIT.EDU" or lists like ;; '("RTFM" "MIT" "EDU"), that's not supported now. - ;; + ;; ;; A valid logical pathname host is a string which has been defined as ;; the name of a logical host, as with LOAD-LOGICAL-PATHNAME-TRANSLATIONS. - ;; + ;; ;; A logical host is an object of implementation-dependent nature. In ;; SBCL, it's a member of the HOST class (a subclass of STRUCTURE-OBJECT). (let ((found-host (etypecase host - ((string 0) - ;; This is a special host. It's not valid as a - ;; logical host, so it is a sensible thing to - ;; designate the physical Unix host object. So - ;; we do that. - *unix-host*) - (string - ;; In general ANSI-compliant Common Lisps, a - ;; string might also be a physical pathname host, - ;; but ANSI leaves this up to the implementor, - ;; and in SBCL we don't do it, so it must be a - ;; logical host. - (find-logical-host host)) - ((or null (member :unspecific)) - ;; CLHS says that HOST=:UNSPECIFIC has - ;; implementation-defined behavior. We - ;; just turn it into NIL. - nil) - (list - ;; ANSI also allows LISTs to designate hosts, - ;; but leaves its interpretation - ;; implementation-defined. Our interpretation - ;; is that it's unsupported.:-| - (error "A LIST representing a pathname host is not ~ + ((string 0) + ;; This is a special host. It's not valid as a + ;; logical host, so it is a sensible thing to + ;; designate the physical Unix host object. So + ;; we do that. + *unix-host*) + (string + ;; In general ANSI-compliant Common Lisps, a + ;; string might also be a physical pathname host, + ;; but ANSI leaves this up to the implementor, + ;; and in SBCL we don't do it, so it must be a + ;; logical host. + (find-logical-host host)) + ((or null (member :unspecific)) + ;; CLHS says that HOST=:UNSPECIFIC has + ;; implementation-defined behavior. We + ;; just turn it into NIL. + nil) + (list + ;; ANSI also allows LISTs to designate hosts, + ;; but leaves its interpretation + ;; implementation-defined. Our interpretation + ;; is that it's unsupported.:-| + (error "A LIST representing a pathname host is not ~ supported in this implementation:~% ~S" - host)) - (host - host))) - ;; According to ANSI defaults may be any valid pathname designator - (defaults (etypecase defaults - (pathname - defaults) - (string - (aver (pathnamep *default-pathname-defaults*)) - (parse-namestring defaults)) - (stream - (truename defaults))))) + host)) + (host + host))) + ;; According to ANSI defaults may be any valid pathname designator + (defaults (etypecase defaults + (pathname + defaults) + (string + (aver (pathnamep *default-pathname-defaults*)) + (parse-namestring defaults)) + (stream + (truename defaults))))) (declare (type (or null host) found-host) - (type pathname defaults)) + (type pathname defaults)) (etypecase thing (simple-string (%parse-namestring thing found-host defaults start end junk-allowed)) (string (%parse-namestring (coerce thing 'simple-string) - found-host defaults start end junk-allowed)) + found-host defaults start end junk-allowed)) (pathname (let ((defaulted-host (or found-host (%pathname-host defaults)))) - (declare (type host defaulted-host)) - (unless (eq defaulted-host (%pathname-host thing)) - (error "The HOST argument doesn't match the pathname host:~% ~ + (declare (type host defaulted-host)) + (unless (eq defaulted-host (%pathname-host thing)) + (error "The HOST argument doesn't match the pathname host:~% ~ ~S and ~S." - defaulted-host (%pathname-host thing)))) + defaulted-host (%pathname-host thing)))) (values thing start)) (stream (let ((name (file-name thing))) - (unless name - (error "can't figure out the file associated with stream:~% ~S" - thing)) - (values name nil)))))) + (unless name + (error "can't figure out the file associated with stream:~% ~S" + thing)) + (values name nil)))))) (defun namestring (pathname) #!+sb-doc @@ -814,10 +814,10 @@ a host-structure or string." (with-pathname (pathname pathname) (when pathname (let ((host (%pathname-host pathname))) - (unless host - (error "can't determine the namestring for pathnames with no ~ + (unless host + (error "can't determine the namestring for pathnames with no ~ host:~% ~S" pathname)) - (funcall (host-unparse host) pathname))))) + (funcall (host-unparse host) pathname))))) (defun host-namestring (pathname) #!+sb-doc @@ -826,10 +826,10 @@ a host-structure or string." (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host - (funcall (host-unparse-host host) pathname) - (error - "can't determine the namestring for pathnames with no host:~% ~S" - pathname))))) + (funcall (host-unparse-host host) pathname) + (error + "can't determine the namestring for pathnames with no host:~% ~S" + pathname))))) (defun directory-namestring (pathname) #!+sb-doc @@ -838,10 +838,10 @@ a host-structure or string." (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host - (funcall (host-unparse-directory host) pathname) - (error - "can't determine the namestring for pathnames with no host:~% ~S" - pathname))))) + (funcall (host-unparse-directory host) pathname) + (error + "can't determine the namestring for pathnames with no host:~% ~S" + pathname))))) (defun file-namestring (pathname) #!+sb-doc @@ -850,14 +850,14 @@ a host-structure or string." (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host - (funcall (host-unparse-file host) pathname) - (error - "can't determine the namestring for pathnames with no host:~% ~S" - pathname))))) + (funcall (host-unparse-file host) pathname) + (error + "can't determine the namestring for pathnames with no host:~% ~S" + pathname))))) (defun enough-namestring (pathname - &optional - (defaults *default-pathname-defaults*)) + &optional + (defaults *default-pathname-defaults*)) #!+sb-doc "Return an abbreviated pathname sufficent to identify the pathname relative to the defaults." @@ -865,11 +865,11 @@ a host-structure or string." (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host - (with-pathname (defaults defaults) - (funcall (host-unparse-enough host) pathname defaults)) - (error - "can't determine the namestring for pathnames with no host:~% ~S" - pathname))))) + (with-pathname (defaults defaults) + (funcall (host-unparse-enough host) pathname defaults)) + (error + "can't determine the namestring for pathnames with no host:~% ~S" + pathname))))) ;;;; wild pathnames @@ -877,25 +877,25 @@ a host-structure or string." #!+sb-doc "Predicate for determining whether pathname contains any wildcards." (declare (type pathname-designator pathname) - (type (member nil :host :device :directory :name :type :version) - field-key)) + (type (member nil :host :device :directory :name :type :version) + field-key)) (with-pathname (pathname pathname) (flet ((frob (x) - (or (pattern-p x) (member x '(:wild :wild-inferiors))))) + (or (pattern-p x) (member x '(:wild :wild-inferiors))))) (ecase field-key - ((nil) - (or (wild-pathname-p pathname :host) - (wild-pathname-p pathname :device) - (wild-pathname-p pathname :directory) - (wild-pathname-p pathname :name) - (wild-pathname-p pathname :type) - (wild-pathname-p pathname :version))) - (:host (frob (%pathname-host pathname))) - (:device (frob (%pathname-host pathname))) - (:directory (some #'frob (%pathname-directory pathname))) - (:name (frob (%pathname-name pathname))) - (:type (frob (%pathname-type pathname))) - (:version (frob (%pathname-version pathname))))))) + ((nil) + (or (wild-pathname-p pathname :host) + (wild-pathname-p pathname :device) + (wild-pathname-p pathname :directory) + (wild-pathname-p pathname :name) + (wild-pathname-p pathname :type) + (wild-pathname-p pathname :version))) + (:host (frob (%pathname-host pathname))) + (:device (frob (%pathname-host pathname))) + (:directory (some #'frob (%pathname-directory pathname))) + (:name (frob (%pathname-name pathname))) + (:type (frob (%pathname-type pathname))) + (:version (frob (%pathname-version pathname))))))) (defun pathname-match-p (in-pathname in-wildname) #!+sb-doc @@ -904,16 +904,16 @@ a host-structure or string." (with-pathname (pathname in-pathname) (with-pathname (wildname in-wildname) (macrolet ((frob (field &optional (op 'components-match)) - `(or (null (,field wildname)) - (,op (,field pathname) (,field wildname))))) - (and (or (null (%pathname-host wildname)) - (eq (%pathname-host wildname) (%pathname-host pathname))) - (frob %pathname-device) - (frob %pathname-directory directory-components-match) - (frob %pathname-name) - (frob %pathname-type) - (or (eq (%pathname-host wildname) *unix-host*) - (frob %pathname-version))))))) + `(or (null (,field wildname)) + (,op (,field pathname) (,field wildname))))) + (and (or (null (%pathname-host wildname)) + (eq (%pathname-host wildname) (%pathname-host pathname))) + (frob %pathname-device) + (frob %pathname-directory directory-components-match) + (frob %pathname-name) + (frob %pathname-type) + (or (eq (%pathname-host wildname) *unix-host*) + (frob %pathname-version))))))) ;;; Place the substitutions into the pattern and return the string or pattern ;;; that results. If DIDDLE-CASE is true, we diddle the result case as well, @@ -923,46 +923,46 @@ a host-structure or string." ;;; as a single string, so we ignore subsequent contiguous wildcards. (defun substitute-into (pattern subs diddle-case) (declare (type pattern pattern) - (type list subs) - (values (or simple-string pattern) list)) + (type list subs) + (values (or simple-string pattern) list)) (let ((in-wildcard nil) - (pieces nil) - (strings nil)) + (pieces nil) + (strings nil)) (dolist (piece (pattern-pieces pattern)) (cond ((simple-string-p piece) - (push piece strings) - (setf in-wildcard nil)) - (in-wildcard) - (t - (setf in-wildcard t) - (unless subs - (error "not enough wildcards in FROM pattern to match ~ + (push piece strings) + (setf in-wildcard nil)) + (in-wildcard) + (t + (setf in-wildcard t) + (unless subs + (error "not enough wildcards in FROM pattern to match ~ TO pattern:~% ~S" - pattern)) - (let ((sub (pop subs))) - (typecase sub - (pattern - (when strings - (push (apply #'concatenate 'simple-string - (nreverse strings)) - pieces)) - (dolist (piece (pattern-pieces sub)) - (push piece pieces))) - (simple-string - (push sub strings)) - (t - (error "can't substitute this into the middle of a word:~ + pattern)) + (let ((sub (pop subs))) + (typecase sub + (pattern + (when strings + (push (apply #'concatenate 'simple-string + (nreverse strings)) + pieces)) + (dolist (piece (pattern-pieces sub)) + (push piece pieces))) + (simple-string + (push sub strings)) + (t + (error "can't substitute this into the middle of a word:~ ~% ~S" - sub))))))) + sub))))))) (when strings (push (apply #'concatenate 'simple-string (nreverse strings)) - pieces)) + pieces)) (values (maybe-diddle-case (if (and pieces (simple-string-p (car pieces)) (null (cdr pieces))) - (car pieces) - (make-pattern (nreverse pieces))) + (car pieces) + (make-pattern (nreverse pieces))) diddle-case) subs))) @@ -970,7 +970,7 @@ a host-structure or string." (defun didnt-match-error (source from) (error "Pathname components from SOURCE and FROM args to TRANSLATE-PATHNAME~@ did not match:~% ~S ~S" - source from)) + source from)) ;;; Do TRANSLATE-COMPONENT for all components except host, directory ;;; and version. @@ -979,30 +979,30 @@ a host-structure or string." (pattern (typecase from (pattern - (typecase source - (pattern - (if (pattern= from source) - source - (didnt-match-error source from))) - (simple-string - (multiple-value-bind (won subs) (pattern-matches from source) - (if won - (values (substitute-into to subs diddle-case)) - (didnt-match-error source from)))) - (t - (maybe-diddle-case source diddle-case)))) + (typecase source + (pattern + (if (pattern= from source) + source + (didnt-match-error source from))) + (simple-string + (multiple-value-bind (won subs) (pattern-matches from source) + (if won + (values (substitute-into to subs diddle-case)) + (didnt-match-error source from)))) + (t + (maybe-diddle-case source diddle-case)))) ((member :wild) - (values (substitute-into to (list source) diddle-case))) + (values (substitute-into to (list source) diddle-case))) (t - (if (components-match source from) - (maybe-diddle-case source diddle-case) - (didnt-match-error source from))))) + (if (components-match source from) + (maybe-diddle-case source diddle-case) + (didnt-match-error source from))))) ((member nil :wild) (maybe-diddle-case source diddle-case)) (t (if (components-match source from) - to - (didnt-match-error source from))))) + to + (didnt-match-error source from))))) ;;; Return a list of all the things that we want to substitute into the TO ;;; pattern (the things matched by from on source.) When From contains @@ -1010,52 +1010,52 @@ a host-structure or string." ;;; subdirectories. (defun compute-directory-substitutions (orig-source orig-from) (let ((source orig-source) - (from orig-from)) + (from orig-from)) (collect ((subs)) (loop - (unless source - (unless (every (lambda (x) (eq x :wild-inferiors)) from) - (didnt-match-error orig-source orig-from)) - (subs ()) - (return)) - (unless from (didnt-match-error orig-source orig-from)) - (let ((from-part (pop from)) - (source-part (pop source))) - (typecase from-part - (pattern - (typecase source-part - (pattern - (if (pattern= from-part source-part) - (subs source-part) - (didnt-match-error orig-source orig-from))) - (simple-string - (multiple-value-bind (won new-subs) - (pattern-matches from-part source-part) - (if won - (dolist (sub new-subs) - (subs sub)) - (didnt-match-error orig-source orig-from)))) - (t - (didnt-match-error orig-source orig-from)))) - ((member :wild) - (subs source-part)) - ((member :wild-inferiors) - (let ((remaining-source (cons source-part source))) - (collect ((res)) - (loop - (when (directory-components-match remaining-source from) - (return)) - (unless remaining-source - (didnt-match-error orig-source orig-from)) - (res (pop remaining-source))) - (subs (res)) - (setq source remaining-source)))) - (simple-string - (unless (and (simple-string-p source-part) - (string= from-part source-part)) - (didnt-match-error orig-source orig-from))) - (t - (didnt-match-error orig-source orig-from))))) + (unless source + (unless (every (lambda (x) (eq x :wild-inferiors)) from) + (didnt-match-error orig-source orig-from)) + (subs ()) + (return)) + (unless from (didnt-match-error orig-source orig-from)) + (let ((from-part (pop from)) + (source-part (pop source))) + (typecase from-part + (pattern + (typecase source-part + (pattern + (if (pattern= from-part source-part) + (subs source-part) + (didnt-match-error orig-source orig-from))) + (simple-string + (multiple-value-bind (won new-subs) + (pattern-matches from-part source-part) + (if won + (dolist (sub new-subs) + (subs sub)) + (didnt-match-error orig-source orig-from)))) + (t + (didnt-match-error orig-source orig-from)))) + ((member :wild) + (subs source-part)) + ((member :wild-inferiors) + (let ((remaining-source (cons source-part source))) + (collect ((res)) + (loop + (when (directory-components-match remaining-source from) + (return)) + (unless remaining-source + (didnt-match-error orig-source orig-from)) + (res (pop remaining-source))) + (subs (res)) + (setq source remaining-source)))) + (simple-string + (unless (and (simple-string-p source-part) + (string= from-part source-part)) + (didnt-match-error orig-source orig-from))) + (t + (didnt-match-error orig-source orig-from))))) (subs)))) ;;; This is called by TRANSLATE-PATHNAME on the directory components @@ -1067,39 +1067,39 @@ a host-structure or string." (defun translate-directories (source from to diddle-case) (if (not (and source to from)) (or (and to (null source) (remove :wild-inferiors to)) - (mapcar (lambda (x) (maybe-diddle-case x diddle-case)) source)) + (mapcar (lambda (x) (maybe-diddle-case x diddle-case)) source)) (collect ((res)) - ;; If TO is :ABSOLUTE, the result should still be :ABSOLUTE. - (res (if (eq (first to) :absolute) - :absolute - (first source))) - (let ((subs-left (compute-directory-substitutions (rest source) - (rest from)))) - (dolist (to-part (rest to)) - (typecase to-part - ((member :wild) - (aver subs-left) - (let ((match (pop subs-left))) - (when (listp match) - (error ":WILD-INFERIORS is not paired in from and to ~ + ;; If TO is :ABSOLUTE, the result should still be :ABSOLUTE. + (res (if (eq (first to) :absolute) + :absolute + (first source))) + (let ((subs-left (compute-directory-substitutions (rest source) + (rest from)))) + (dolist (to-part (rest to)) + (typecase to-part + ((member :wild) + (aver subs-left) + (let ((match (pop subs-left))) + (when (listp match) + (error ":WILD-INFERIORS is not paired in from and to ~ patterns:~% ~S ~S" from to)) - (res (maybe-diddle-case match diddle-case)))) - ((member :wild-inferiors) - (aver subs-left) - (let ((match (pop subs-left))) - (unless (listp match) - (error ":WILD-INFERIORS not paired in from and to ~ + (res (maybe-diddle-case match diddle-case)))) + ((member :wild-inferiors) + (aver subs-left) + (let ((match (pop subs-left))) + (unless (listp match) + (error ":WILD-INFERIORS not paired in from and to ~ patterns:~% ~S ~S" from to)) - (dolist (x match) - (res (maybe-diddle-case x diddle-case))))) - (pattern - (multiple-value-bind - (new new-subs-left) - (substitute-into to-part subs-left diddle-case) - (setf subs-left new-subs-left) - (res new))) - (t (res to-part))))) - (res)))) + (dolist (x match) + (res (maybe-diddle-case x diddle-case))))) + (pattern + (multiple-value-bind + (new new-subs-left) + (substitute-into to-part subs-left diddle-case) + (setf subs-left new-subs-left) + (res new))) + (t (res to-part))))) + (res)))) (defun translate-pathname (source from-wildname to-wildname &key) #!+sb-doc @@ -1109,32 +1109,32 @@ a host-structure or string." (with-pathname (source source) (with-pathname (from from-wildname) (with-pathname (to to-wildname) - (let* ((source-host (%pathname-host source)) - (from-host (%pathname-host from)) - (to-host (%pathname-host to)) - (diddle-case - (and source-host to-host - (not (eq (host-customary-case source-host) - (host-customary-case to-host)))))) - (macrolet ((frob (field &optional (op 'translate-component)) - `(let ((result (,op (,field source) - (,field from) - (,field to) - diddle-case))) - (if (eq result :error) - (error "~S doesn't match ~S." source from) - result)))) - (%make-maybe-logical-pathname - (or to-host source-host) - (frob %pathname-device) - (frob %pathname-directory translate-directories) - (frob %pathname-name) - (frob %pathname-type) - (if (eq from-host *unix-host*) - (if (eq (%pathname-version to) :wild) - (%pathname-version from) - (%pathname-version to)) - (frob %pathname-version))))))))) + (let* ((source-host (%pathname-host source)) + (from-host (%pathname-host from)) + (to-host (%pathname-host to)) + (diddle-case + (and source-host to-host + (not (eq (host-customary-case source-host) + (host-customary-case to-host)))))) + (macrolet ((frob (field &optional (op 'translate-component)) + `(let ((result (,op (,field source) + (,field from) + (,field to) + diddle-case))) + (if (eq result :error) + (error "~S doesn't match ~S." source from) + result)))) + (%make-maybe-logical-pathname + (or to-host source-host) + (frob %pathname-device) + (frob %pathname-directory translate-directories) + (frob %pathname-name) + (frob %pathname-type) + (if (eq from-host *unix-host*) + (if (eq (%pathname-version to) :wild) + (%pathname-version from) + (%pathname-version to)) + (frob %pathname-version))))))))) ;;;; logical pathname support. ANSI 92-102 specification. ;;;; @@ -1150,20 +1150,20 @@ a host-structure or string." (declare (string word)) (when (string= word "") (error 'namestring-parse-error - :complaint "Attempted to treat invalid logical hostname ~ + :complaint "Attempted to treat invalid logical hostname ~ as a logical host:~% ~S" - :args (list word) - :namestring word :offset 0)) + :args (list word) + :namestring word :offset 0)) (let ((word (string-upcase word))) (dotimes (i (length word)) (let ((ch (schar word i))) - (unless (and (typep ch 'standard-char) - (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))) - (error 'namestring-parse-error - :complaint "logical namestring character which ~ + (unless (and (typep ch 'standard-char) + (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))) + (error 'namestring-parse-error + :complaint "logical namestring character which ~ is not alphanumeric or hyphen:~% ~S" - :args (list ch) - :namestring word :offset i)))) + :args (list ch) + :namestring word :offset i)))) (coerce word 'base-string))) ;;; Given a logical host or string, return a logical host. If ERROR-P @@ -1172,20 +1172,20 @@ a host-structure or string." (etypecase thing (string (let ((found (gethash (logical-word-or-lose thing) - *logical-hosts*))) + *logical-hosts*))) (if (or found (not errorp)) - found - ;; This is the error signalled from e.g. - ;; LOGICAL-PATHNAME-TRANSLATIONS when host is not a defined - ;; host, and ANSI specifies that that's a TYPE-ERROR. - (error 'simple-type-error - :datum thing - ;; God only knows what ANSI expects us to use for - ;; the EXPECTED-TYPE here. Maybe this will be OK.. - :expected-type - '(and string (satisfies logical-pathname-translations)) - :format-control "logical host not yet defined: ~S" - :format-arguments (list thing))))) + found + ;; This is the error signalled from e.g. + ;; LOGICAL-PATHNAME-TRANSLATIONS when host is not a defined + ;; host, and ANSI specifies that that's a TYPE-ERROR. + (error 'simple-type-error + :datum thing + ;; God only knows what ANSI expects us to use for + ;; the EXPECTED-TYPE here. Maybe this will be OK.. + :expected-type + '(and string (satisfies logical-pathname-translations)) + :format-control "logical host not yet defined: ~S" + :format-arguments (list thing))))) (logical-host thing))) ;;; Given a logical host name or host, return a logical host, creating @@ -1194,9 +1194,9 @@ a host-structure or string." (declare (values logical-host)) (or (find-logical-host thing nil) (let* ((name (logical-word-or-lose thing)) - (new (make-logical-host :name name))) - (setf (gethash name *logical-hosts*) new) - new))) + (new (make-logical-host :name name))) + (setf (gethash name *logical-hosts*) new) + new))) ;;;; logical pathname parsing @@ -1205,145 +1205,145 @@ a host-structure or string." (let ((chunk (caar chunks))) (collect ((pattern)) (let ((last-pos 0) - (len (length chunk))) - (declare (fixnum last-pos)) - (loop - (when (= last-pos len) (return)) - (let ((pos (or (position #\* chunk :start last-pos) len))) - (if (= pos last-pos) - (when (pattern) - (error 'namestring-parse-error - :complaint "double asterisk inside of logical ~ + (len (length chunk))) + (declare (fixnum last-pos)) + (loop + (when (= last-pos len) (return)) + (let ((pos (or (position #\* chunk :start last-pos) len))) + (if (= pos last-pos) + (when (pattern) + (error 'namestring-parse-error + :complaint "double asterisk inside of logical ~ word: ~S" - :args (list chunk) - :namestring namestring - :offset (+ (cdar chunks) pos))) - (pattern (subseq chunk last-pos pos))) - (if (= pos len) - (return) - (pattern :multi-char-wild)) - (setq last-pos (1+ pos))))) - (aver (pattern)) - (if (cdr (pattern)) - (make-pattern (pattern)) - (let ((x (car (pattern)))) - (if (eq x :multi-char-wild) - :wild - x)))))) + :args (list chunk) + :namestring namestring + :offset (+ (cdar chunks) pos))) + (pattern (subseq chunk last-pos pos))) + (if (= pos len) + (return) + (pattern :multi-char-wild)) + (setq last-pos (1+ pos))))) + (aver (pattern)) + (if (cdr (pattern)) + (make-pattern (pattern)) + (let ((x (car (pattern)))) + (if (eq x :multi-char-wild) + :wild + x)))))) ;;; Return a list of conses where the CDR is the start position and ;;; the CAR is a string (token) or character (punctuation.) (defun logical-chunkify (namestr start end) (collect ((chunks)) (do ((i start (1+ i)) - (prev 0)) - ((= i end) - (when (> end prev) - (chunks (cons (nstring-upcase (subseq namestr prev end)) prev)))) + (prev 0)) + ((= i end) + (when (> end prev) + (chunks (cons (nstring-upcase (subseq namestr prev end)) prev)))) (let ((ch (schar namestr i))) - (unless (or (alpha-char-p ch) (digit-char-p ch) - (member ch '(#\- #\*))) - (when (> i prev) - (chunks (cons (nstring-upcase (subseq namestr prev i)) prev))) - (setq prev (1+ i)) - (unless (member ch '(#\; #\: #\.)) - (error 'namestring-parse-error - :complaint "illegal character for logical pathname:~% ~S" - :args (list ch) - :namestring namestr - :offset i)) - (chunks (cons ch i))))) + (unless (or (alpha-char-p ch) (digit-char-p ch) + (member ch '(#\- #\*))) + (when (> i prev) + (chunks (cons (nstring-upcase (subseq namestr prev i)) prev))) + (setq prev (1+ i)) + (unless (member ch '(#\; #\: #\.)) + (error 'namestring-parse-error + :complaint "illegal character for logical pathname:~% ~S" + :args (list ch) + :namestring namestr + :offset i)) + (chunks (cons ch i))))) (chunks))) ;;; Break up a logical-namestring, always a string, into its ;;; constituent parts. (defun parse-logical-namestring (namestr start end) (declare (type simple-string namestr) - (type index start end)) + (type index start end)) (collect ((directory)) (let ((host nil) - (name nil) - (type nil) - (version nil)) + (name nil) + (type nil) + (version nil)) (labels ((expecting (what chunks) - (unless (and chunks (simple-string-p (caar chunks))) - (error 'namestring-parse-error - :complaint "expecting ~A, got ~:[nothing~;~S~]." - :args (list what (caar chunks) (caar chunks)) - :namestring namestr - :offset (if chunks (cdar chunks) end))) - (caar chunks)) - (parse-host (chunks) - (case (caadr chunks) - (#\: - (setq host - (find-logical-host (expecting "a host name" chunks))) - (parse-relative (cddr chunks))) - (t - (parse-relative chunks)))) - (parse-relative (chunks) - (case (caar chunks) - (#\; - (directory :relative) - (parse-directory (cdr chunks))) - (t - (directory :absolute) ; Assumption! Maybe revoked later. - (parse-directory chunks)))) - (parse-directory (chunks) - (case (caadr chunks) - (#\; - (directory - (let ((res (expecting "a directory name" chunks))) - (cond ((string= res "..") :up) - ((string= res "**") :wild-inferiors) - (t - (maybe-make-logical-pattern namestr chunks))))) - (parse-directory (cddr chunks))) - (t - (parse-name chunks)))) - (parse-name (chunks) - (when chunks - (expecting "a file name" chunks) - (setq name (maybe-make-logical-pattern namestr chunks)) - (expecting-dot (cdr chunks)))) - (expecting-dot (chunks) - (when chunks - (unless (eql (caar chunks) #\.) - (error 'namestring-parse-error - :complaint "expecting a dot, got ~S." - :args (list (caar chunks)) - :namestring namestr - :offset (cdar chunks))) - (if type - (parse-version (cdr chunks)) - (parse-type (cdr chunks))))) - (parse-type (chunks) - (expecting "a file type" chunks) - (setq type (maybe-make-logical-pattern namestr chunks)) - (expecting-dot (cdr chunks))) - (parse-version (chunks) - (let ((str (expecting "a positive integer, * or NEWEST" - chunks))) - (cond - ((string= str "*") (setq version :wild)) - ((string= str "NEWEST") (setq version :newest)) - (t - (multiple-value-bind (res pos) - (parse-integer str :junk-allowed t) - (unless (and res (plusp res)) - (error 'namestring-parse-error - :complaint "expected a positive integer, ~ + (unless (and chunks (simple-string-p (caar chunks))) + (error 'namestring-parse-error + :complaint "expecting ~A, got ~:[nothing~;~S~]." + :args (list what (caar chunks) (caar chunks)) + :namestring namestr + :offset (if chunks (cdar chunks) end))) + (caar chunks)) + (parse-host (chunks) + (case (caadr chunks) + (#\: + (setq host + (find-logical-host (expecting "a host name" chunks))) + (parse-relative (cddr chunks))) + (t + (parse-relative chunks)))) + (parse-relative (chunks) + (case (caar chunks) + (#\; + (directory :relative) + (parse-directory (cdr chunks))) + (t + (directory :absolute) ; Assumption! Maybe revoked later. + (parse-directory chunks)))) + (parse-directory (chunks) + (case (caadr chunks) + (#\; + (directory + (let ((res (expecting "a directory name" chunks))) + (cond ((string= res "..") :up) + ((string= res "**") :wild-inferiors) + (t + (maybe-make-logical-pattern namestr chunks))))) + (parse-directory (cddr chunks))) + (t + (parse-name chunks)))) + (parse-name (chunks) + (when chunks + (expecting "a file name" chunks) + (setq name (maybe-make-logical-pattern namestr chunks)) + (expecting-dot (cdr chunks)))) + (expecting-dot (chunks) + (when chunks + (unless (eql (caar chunks) #\.) + (error 'namestring-parse-error + :complaint "expecting a dot, got ~S." + :args (list (caar chunks)) + :namestring namestr + :offset (cdar chunks))) + (if type + (parse-version (cdr chunks)) + (parse-type (cdr chunks))))) + (parse-type (chunks) + (expecting "a file type" chunks) + (setq type (maybe-make-logical-pattern namestr chunks)) + (expecting-dot (cdr chunks))) + (parse-version (chunks) + (let ((str (expecting "a positive integer, * or NEWEST" + chunks))) + (cond + ((string= str "*") (setq version :wild)) + ((string= str "NEWEST") (setq version :newest)) + (t + (multiple-value-bind (res pos) + (parse-integer str :junk-allowed t) + (unless (and res (plusp res)) + (error 'namestring-parse-error + :complaint "expected a positive integer, ~ got ~S" - :args (list str) - :namestring namestr - :offset (+ pos (cdar chunks)))) - (setq version res))))) - (when (cdr chunks) - (error 'namestring-parse-error - :complaint "extra stuff after end of file name" - :namestring namestr - :offset (cdadr chunks))))) - (parse-host (logical-chunkify namestr start end))) + :args (list str) + :namestring namestr + :offset (+ pos (cdar chunks)))) + (setq version res))))) + (when (cdr chunks) + (error 'namestring-parse-error + :complaint "extra stuff after end of file name" + :namestring namestr + :offset (cdadr chunks))))) + (parse-host (logical-chunkify namestr start end))) (values host :unspecific (directory) name type version)))) ;;; We can't initialize this yet because not all host methods are @@ -1354,15 +1354,15 @@ a host-structure or string." #!+sb-doc "Converts the pathspec argument to a logical-pathname and returns it." (declare (type (or logical-pathname string stream) pathspec) - (values logical-pathname)) + (values logical-pathname)) (if (typep pathspec 'logical-pathname) pathspec (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*))) - (when (eq (%pathname-host res) - (%pathname-host *logical-pathname-defaults*)) - (error "This logical namestring does not specify a host:~% ~S" - pathspec)) - res))) + (when (eq (%pathname-host res) + (%pathname-host *logical-pathname-defaults*)) + (error "This logical namestring does not specify a host:~% ~S" + pathspec)) + res))) ;;;; logical pathname unparsing @@ -1371,19 +1371,19 @@ a host-structure or string." (collect ((pieces)) (let ((directory (%pathname-directory pathname))) (when directory - (ecase (pop directory) - (:absolute) ; nothing special - (:relative (pieces ";"))) - (dolist (dir directory) - (cond ((or (stringp dir) (pattern-p dir)) - (pieces (unparse-logical-piece dir)) - (pieces ";")) - ((eq dir :wild) - (pieces "*;")) - ((eq dir :wild-inferiors) - (pieces "**;")) - (t - (error "invalid directory component: ~S" dir)))))) + (ecase (pop directory) + (:absolute) ; nothing special + (:relative (pieces ";"))) + (dolist (dir directory) + (cond ((or (stringp dir) (pattern-p dir)) + (pieces (unparse-logical-piece dir)) + (pieces ";")) + ((eq dir :wild) + (pieces "*;")) + ((eq dir :wild-inferiors) + (pieces "**;")) + (t + (error "invalid directory component: ~S" dir)))))) (apply #'concatenate 'simple-string (pieces)))) (defun unparse-logical-piece (thing) @@ -1393,44 +1393,44 @@ a host-structure or string." (pattern (collect ((strings)) (dolist (piece (pattern-pieces thing)) - (etypecase piece - (simple-string (strings piece)) - (keyword - (cond ((eq piece :wild-inferiors) - (strings "**")) - ((eq piece :multi-char-wild) - (strings "*")) - (t (error "invalid keyword: ~S" piece)))))) + (etypecase piece + (simple-string (strings piece)) + (keyword + (cond ((eq piece :wild-inferiors) + (strings "**")) + ((eq piece :multi-char-wild) + (strings "*")) + (t (error "invalid keyword: ~S" piece)))))) (apply #'concatenate 'simple-string (strings)))))) (defun unparse-logical-file (pathname) (declare (type pathname pathname)) (collect ((strings)) (let* ((name (%pathname-name pathname)) - (type (%pathname-type pathname)) - (version (%pathname-version pathname)) - (type-supplied (not (or (null type) (eq type :unspecific)))) - (version-supplied (not (or (null version) - (eq version :unspecific))))) + (type (%pathname-type pathname)) + (version (%pathname-version pathname)) + (type-supplied (not (or (null type) (eq type :unspecific)))) + (version-supplied (not (or (null version) + (eq version :unspecific))))) (when name - (when (and (null type) (position #\. name :start 1)) - (error "too many dots in the name: ~S" pathname)) - (strings (unparse-logical-piece name))) + (when (and (null type) (position #\. name :start 1)) + (error "too many dots in the name: ~S" pathname)) + (strings (unparse-logical-piece name))) (when type-supplied - (unless name - (error "cannot specify the type without a file: ~S" pathname)) - (when (typep type 'simple-string) - (when (position #\. type) - (error "type component can't have a #\. inside: ~S" pathname))) - (strings ".") - (strings (unparse-logical-piece type))) + (unless name + (error "cannot specify the type without a file: ~S" pathname)) + (when (typep type 'simple-string) + (when (position #\. type) + (error "type component can't have a #\. inside: ~S" pathname))) + (strings ".") + (strings (unparse-logical-piece type))) (when version-supplied - (unless type-supplied - (error "cannot specify the version without a type: ~S" pathname)) - (etypecase version - ((member :newest) (strings ".NEWEST")) - ((member :wild) (strings ".*")) - (fixnum (strings ".") (strings (format nil "~D" version)))))) + (unless type-supplied + (error "cannot specify the version without a type: ~S" pathname)) + (etypecase version + ((member :newest) (strings ".NEWEST")) + ((member :wild) (strings ".*")) + (fixnum (strings ".") (strings (format nil "~D" version)))))) (apply #'concatenate 'simple-string (strings)))) ;;; Unparse a logical pathname string. @@ -1467,9 +1467,9 @@ a host-structure or string." (defun unparse-logical-namestring (pathname) (declare (type logical-pathname pathname)) (concatenate 'simple-string - (logical-host-name (%pathname-host pathname)) ":" - (unparse-logical-directory pathname) - (unparse-logical-file pathname))) + (logical-host-name (%pathname-host pathname)) ":" + (unparse-logical-directory pathname) + (unparse-logical-file pathname))) ;;;; logical pathname translations @@ -1478,49 +1478,49 @@ a host-structure or string." ;;; into patterns.) (defun canonicalize-logical-pathname-translations (translation-list host) (declare (type list translation-list) (type host host) - (values list)) + (values list)) (mapcar (lambda (translation) - (destructuring-bind (from to) translation - (list (if (typep from 'logical-pathname) - from - (parse-namestring from host)) - (pathname to)))) - translation-list)) + (destructuring-bind (from to) translation + (list (if (typep from 'logical-pathname) + from + (parse-namestring from host)) + (pathname to)))) + translation-list)) (defun logical-pathname-translations (host) #!+sb-doc "Return the (logical) host object argument's list of translations." (declare (type (or string logical-host) host) - (values list)) + (values list)) (logical-host-translations (find-logical-host host))) (defun (setf logical-pathname-translations) (translations host) #!+sb-doc "Set the translations list for the logical host argument." (declare (type (or string logical-host) host) - (type list translations) - (values list)) + (type list translations) + (values list)) (let ((host (intern-logical-host host))) (setf (logical-host-canon-transls host) - (canonicalize-logical-pathname-translations translations host)) + (canonicalize-logical-pathname-translations translations host)) (setf (logical-host-translations host) translations))) (defun translate-logical-pathname (pathname &key) #!+sb-doc "Translate PATHNAME to a physical pathname, which is returned." (declare (type pathname-designator pathname) - (values (or null pathname))) + (values (or null pathname))) (typecase pathname (logical-pathname (dolist (x (logical-host-canon-transls (%pathname-host pathname)) - (error 'simple-file-error - :pathname pathname - :format-control "no translation for ~S" - :format-arguments (list pathname))) + (error 'simple-file-error + :pathname pathname + :format-control "no translation for ~S" + :format-arguments (list pathname))) (destructuring-bind (from to) x - (when (pathname-match-p pathname from) - (return (translate-logical-pathname - (translate-pathname pathname from to))))))) + (when (pathname-match-p pathname from) + (return (translate-logical-pathname + (translate-pathname pathname from to))))))) (pathname pathname) (t (translate-logical-pathname (pathname pathname))))) @@ -1532,7 +1532,7 @@ a host-structure or string." (defun load-logical-pathname-translations (host) #!+sb-doc (declare (type string host) - (values (member t nil))) + (values (member t nil))) (if (find-logical-host host nil) ;; This host is already defined, all is well and good. nil diff --git a/src/code/target-random.lisp b/src/code/target-random.lisp index 3e35382..f0b740f 100644 --- a/src/code/target-random.lisp +++ b/src/code/target-random.lisp @@ -18,20 +18,20 @@ ;;;; RANDOM-STATEs -(def!method make-load-form ((random-state random-state) &optional environment) +(def!method make-load-form ((random-state random-state) &optional environment) (make-load-form-saving-slots random-state :environment environment)) (def!method print-object ((state random-state) stream) (if (and *print-readably* (not *read-eval*)) (error 'print-not-readable :object state) (format stream "#S(~S ~S #.~S)" - 'random-state - ':state - `(make-array 627 - :element-type - '(unsigned-byte 32) - :initial-contents - ',(coerce (random-state-state state) 'list))))) + 'random-state + ':state + `(make-array 627 + :element-type + '(unsigned-byte 32) + :initial-contents + ',(coerce (random-state-state state) 'list))))) ;;; The state is stored in a (simple-array (unsigned-byte 32) (627)) ;;; wrapped in a random-state structure: @@ -55,10 +55,10 @@ (setf (aref state 2) 1) (setf (aref state 3) seed) (do ((k 1 (1+ k))) - ((>= k 624)) + ((>= k 624)) (declare (type (mod 625) k)) (setf (aref state (+ 3 k)) - (logand (* 69069 (aref state (+ 3 (1- k)))) #xffffffff))) + (logand (* 69069 (aref state (+ 3 (1- k)))) #xffffffff))) state)) (defvar *random-state*) @@ -75,15 +75,15 @@ the universal time." (/show0 "entering MAKE-RANDOM-STATE") (flet ((copy-random-state (state) - (/show0 "entering COPY-RANDOM-STATE") - (let ((state (random-state-state state)) - (new-state - (make-array 627 :element-type '(unsigned-byte 32)))) - (/show0 "made NEW-STATE, about to DOTIMES") - (dotimes (i 627) - (setf (aref new-state i) (aref state i))) - (/show0 "falling through to %MAKE-RANDOM-STATE") - (%make-random-state :state new-state)))) + (/show0 "entering COPY-RANDOM-STATE") + (let ((state (random-state-state state)) + (new-state + (make-array 627 :element-type '(unsigned-byte 32)))) + (/show0 "made NEW-STATE, about to DOTIMES") + (dotimes (i 627) + (setf (aref new-state i) (aref state i))) + (/show0 "falling through to %MAKE-RANDOM-STATE") + (%make-random-state :state new-state)))) (/show0 "at head of ETYPECASE in MAKE-RANDOM-STATE") (etypecase state (null @@ -95,8 +95,8 @@ ((member t) (/show0 "T clause") (%make-random-state :state (init-random-state - (logand (get-universal-time) - #xffffffff))))))) + (logand (get-universal-time) + #xffffffff))))))) ;;;; random entries @@ -113,35 +113,35 @@ #!-x86 (defun random-mt19937-update (state) (declare (type (simple-array (unsigned-byte 32) (627)) state) - (optimize (speed 3) (safety 0))) + (optimize (speed 3) (safety 0))) (let ((y 0)) (declare (type (unsigned-byte 32) y)) (do ((kk 3 (1+ kk))) - ((>= kk (+ 3 (- mt19937-n mt19937-m)))) + ((>= kk (+ 3 (- mt19937-n mt19937-m)))) (declare (type (mod 628) kk)) (setf y (logior (logand (aref state kk) mt19937-upper-mask) - (logand (aref state (1+ kk)) mt19937-lower-mask))) + (logand (aref state (1+ kk)) mt19937-lower-mask))) (setf (aref state kk) (logxor (aref state (+ kk mt19937-m)) - (ash y -1) (aref state (logand y 1))))) + (ash y -1) (aref state (logand y 1))))) (do ((kk (+ (- mt19937-n mt19937-m) 3) (1+ kk))) - ((>= kk (+ (1- mt19937-n) 3))) + ((>= kk (+ (1- mt19937-n) 3))) (declare (type (mod 628) kk)) (setf y (logior (logand (aref state kk) mt19937-upper-mask) - (logand (aref state (1+ kk)) mt19937-lower-mask))) + (logand (aref state (1+ kk)) mt19937-lower-mask))) (setf (aref state kk) (logxor (aref state (+ kk (- mt19937-m mt19937-n))) - (ash y -1) (aref state (logand y 1))))) + (ash y -1) (aref state (logand y 1))))) (setf y (logior (logand (aref state (+ 3 (1- mt19937-n))) - mt19937-upper-mask) - (logand (aref state 3) mt19937-lower-mask))) + mt19937-upper-mask) + (logand (aref state 3) mt19937-lower-mask))) (setf (aref state (+ 3 (1- mt19937-n))) - (logxor (aref state (+ 3 (1- mt19937-m))) - (ash y -1) (aref state (logand y 1))))) + (logxor (aref state (+ 3 (1- mt19937-m))) + (ash y -1) (aref state (logand y 1))))) (values)) #!-x86 (defun random-chunk (state) (declare (type random-state state)) (let* ((state (random-state-state state)) - (k (aref state 2))) + (k (aref state 2))) (declare (type (mod 628) k)) (when (= k mt19937-n) (random-mt19937-update state) @@ -169,8 +169,8 @@ (defun big-random-chunk (state) (declare (type random-state state)) (logand (1- (expt 2 64)) - (logior (ash (random-chunk state) 32) - (random-chunk state)))) + (logior (ash (random-chunk state) 32) + (random-chunk state)))) ;;; Handle the single or double float case of RANDOM. We generate a ;;; float between 0.0 and 1.0 by clobbering the significand of 1.0 @@ -178,58 +178,58 @@ ;;; we have a hidden bit. #!-sb-fluid (declaim (inline %random-single-float %random-double-float)) (declaim (ftype (function ((single-float (0f0)) random-state) - (single-float 0f0)) - %random-single-float)) + (single-float 0f0)) + %random-single-float)) (defun %random-single-float (arg state) (declare (type (single-float (0f0)) arg) - (type random-state state)) + (type random-state state)) (* arg (- (make-single-float - (dpb (ash (random-chunk state) - (- sb!vm:single-float-digits random-chunk-length)) - sb!vm:single-float-significand-byte - (single-float-bits 1.0))) - 1.0))) + (dpb (ash (random-chunk state) + (- sb!vm:single-float-digits random-chunk-length)) + sb!vm:single-float-significand-byte + (single-float-bits 1.0))) + 1.0))) (declaim (ftype (function ((double-float (0d0)) random-state) - (double-float 0d0)) - %random-double-float)) + (double-float 0d0)) + %random-double-float)) ;;; 32-bit version #!+nil (defun %random-double-float (arg state) (declare (type (double-float (0d0)) arg) - (type random-state state)) + (type random-state state)) (* (float (random-chunk state) 1d0) (/ 1d0 (expt 2 32)))) ;;; 53-bit version #!-x86 (defun %random-double-float (arg state) (declare (type (double-float (0d0)) arg) - (type random-state state)) + (type random-state state)) (* arg (- (sb!impl::make-double-float - (dpb (ash (random-chunk state) - (- sb!vm:double-float-digits random-chunk-length 32)) - sb!vm:double-float-significand-byte - (sb!impl::double-float-high-bits 1d0)) - (random-chunk state)) - 1d0))) + (dpb (ash (random-chunk state) + (- sb!vm:double-float-digits random-chunk-length 32)) + sb!vm:double-float-significand-byte + (sb!impl::double-float-high-bits 1d0)) + (random-chunk state)) + 1d0))) ;;; using a faster inline VOP #!+x86 (defun %random-double-float (arg state) (declare (type (double-float (0d0)) arg) - (type random-state state)) + (type random-state state)) (let ((state-vector (random-state-state state))) (* arg (- (sb!impl::make-double-float - (dpb (ash (sb!vm::random-mt19937 state-vector) - (- sb!vm:double-float-digits random-chunk-length - sb!vm:n-word-bits)) - sb!vm:double-float-significand-byte - (sb!impl::double-float-high-bits 1d0)) - (sb!vm::random-mt19937 state-vector)) - 1d0)))) + (dpb (ash (sb!vm::random-mt19937 state-vector) + (- sb!vm:double-float-digits random-chunk-length + sb!vm:n-word-bits)) + sb!vm:double-float-significand-byte + (sb!impl::double-float-high-bits 1d0)) + (sb!vm::random-mt19937 state-vector)) + 1d0)))) ;;;; random integers @@ -238,17 +238,17 @@ (declare (type (integer 1) arg) (type random-state state)) (let ((shift (- random-chunk-length random-integer-overlap))) (do ((bits (random-chunk state) - (logxor (ash bits shift) (random-chunk state))) - (count (+ (integer-length arg) - (- random-integer-extra-bits shift)) - (- count shift))) - ((minusp count) - (rem bits arg)) + (logxor (ash bits shift) (random-chunk state))) + (count (+ (integer-length arg) + (- random-integer-extra-bits shift)) + (- count shift))) + ((minusp count) + (rem bits arg)) (declare (fixnum count))))) (defun random (arg &optional (state *random-state*)) (declare (inline %random-single-float %random-double-float - #!+long-float %random-long-float)) + #!+long-float %random-long-float)) (cond ((and (fixnump arg) (<= arg random-fixnum-max) (> arg 0)) (rem (random-chunk state) arg)) @@ -263,7 +263,7 @@ (%random-integer arg state)) (t (error 'simple-type-error - :expected-type '(or (integer 1) (float (0))) :datum arg - :format-control "~@" - :format-arguments (list arg))))) + :format-arguments (list arg))))) diff --git a/src/code/target-sap.lisp b/src/code/target-sap.lisp index d49334a..13b5037 100644 --- a/src/code/target-sap.lisp +++ b/src/code/target-sap.lisp @@ -41,7 +41,7 @@ ;;; Return a new SAP, OFFSET bytes from SAP. (defun sap+ (sap offset) (declare (type system-area-pointer sap) - (fixnum offset)) + (fixnum offset)) (sap+ sap offset)) ;;; Return the byte offset between SAP1 and SAP2. @@ -62,168 +62,168 @@ ;;; Return the 8-bit byte at OFFSET bytes from SAP. (defun sap-ref-8 (sap offset) (declare (type system-area-pointer sap) - (fixnum offset)) + (fixnum offset)) (sap-ref-8 sap offset)) ;;; Return the 16-bit word at OFFSET bytes from SAP. (defun sap-ref-16 (sap offset) (declare (type system-area-pointer sap) - (fixnum offset)) + (fixnum offset)) (sap-ref-16 sap offset)) ;;; Returns the 32-bit dualword at OFFSET bytes from SAP. (defun sap-ref-32 (sap offset) (declare (type system-area-pointer sap) - (fixnum offset)) + (fixnum offset)) (sap-ref-32 sap offset)) ;;; Return the 64-bit quadword at OFFSET bytes from SAP. (defun sap-ref-64 (sap offset) (declare (type system-area-pointer sap) - (fixnum offset)) + (fixnum offset)) (sap-ref-64 sap offset)) ;;; Return the unsigned word of natural size OFFSET bytes from SAP. (defun sap-ref-word (sap offset) (declare (type system-area-pointer sap) - (fixnum offset)) + (fixnum offset)) (sap-ref-word sap offset)) ;;; Return the 32-bit SAP at OFFSET bytes from SAP. (defun sap-ref-sap (sap offset) (declare (type system-area-pointer sap) - (fixnum offset)) + (fixnum offset)) (sap-ref-sap sap offset)) ;;; Return the 32-bit SINGLE-FLOAT at OFFSET bytes from SAP. (defun sap-ref-single (sap offset) (declare (type system-area-pointer sap) - (fixnum offset)) + (fixnum offset)) (sap-ref-single sap offset)) ;;; Return the 64-bit DOUBLE-FLOAT at OFFSET bytes from SAP. (defun sap-ref-double (sap offset) (declare (type system-area-pointer sap) - (fixnum offset)) + (fixnum offset)) (sap-ref-double sap offset)) ;;; Return the LONG-FLOAT at OFFSET bytes from SAP. #!+(or x86 long-float) (defun sap-ref-long (sap offset) (declare (type system-area-pointer sap) - (fixnum offset)) + (fixnum offset)) (sap-ref-long sap offset)) ;;; Return the signed 8-bit byte at OFFSET bytes from SAP. (defun signed-sap-ref-8 (sap offset) (declare (type system-area-pointer sap) - (fixnum offset)) + (fixnum offset)) (signed-sap-ref-8 sap offset)) ;;; Return the signed 16-bit word at OFFSET bytes from SAP. (defun signed-sap-ref-16 (sap offset) (declare (type system-area-pointer sap) - (fixnum offset)) + (fixnum offset)) (signed-sap-ref-16 sap offset)) ;;; Return the signed 32-bit dualword at OFFSET bytes from SAP. (defun signed-sap-ref-32 (sap offset) (declare (type system-area-pointer sap) - (fixnum offset)) + (fixnum offset)) (signed-sap-ref-32 sap offset)) ;;; Return the signed 64-bit quadword at OFFSET bytes from SAP. (defun signed-sap-ref-64 (sap offset) (declare (type system-area-pointer sap) - (fixnum offset)) + (fixnum offset)) (signed-sap-ref-64 sap offset)) ;;; Return the signed word of natural size OFFSET bytes from SAP. (defun signed-sap-ref-word (sap offset) (declare (type system-area-pointer sap) - (fixnum offset)) + (fixnum offset)) (signed-sap-ref-word sap offset)) (defun %set-sap-ref-8 (sap offset new-value) (declare (type system-area-pointer sap) - (fixnum offset) - (type (unsigned-byte 8) new-value)) + (fixnum offset) + (type (unsigned-byte 8) new-value)) (setf (sap-ref-8 sap offset) new-value)) (defun %set-sap-ref-16 (sap offset new-value) (declare (type system-area-pointer sap) - (fixnum offset) - (type (unsigned-byte 16) new-value)) + (fixnum offset) + (type (unsigned-byte 16) new-value)) (setf (sap-ref-16 sap offset) new-value)) (defun %set-sap-ref-32 (sap offset new-value) (declare (type system-area-pointer sap) - (fixnum offset) - (type (unsigned-byte 32) new-value)) + (fixnum offset) + (type (unsigned-byte 32) new-value)) (setf (sap-ref-32 sap offset) new-value)) (defun %set-sap-ref-64 (sap offset new-value) (declare (type system-area-pointer sap) - (fixnum offset) - (type (unsigned-byte 64) new-value)) + (fixnum offset) + (type (unsigned-byte 64) new-value)) (setf (sap-ref-64 sap offset) new-value)) (defun %set-sap-ref-word (sap offset new-value) (declare (type system-area-pointer sap) - (fixnum offset) - (type (unsigned-byte #.sb!vm:n-machine-word-bits) new-value)) + (fixnum offset) + (type (unsigned-byte #.sb!vm:n-machine-word-bits) new-value)) (setf (sap-ref-word sap offset) new-value)) (defun %set-signed-sap-ref-8 (sap offset new-value) (declare (type system-area-pointer sap) - (fixnum offset) - (type (signed-byte 8) new-value)) + (fixnum offset) + (type (signed-byte 8) new-value)) (setf (signed-sap-ref-8 sap offset) new-value)) (defun %set-signed-sap-ref-16 (sap offset new-value) (declare (type system-area-pointer sap) - (fixnum offset) - (type (signed-byte 16) new-value)) + (fixnum offset) + (type (signed-byte 16) new-value)) (setf (signed-sap-ref-16 sap offset) new-value)) (defun %set-signed-sap-ref-32 (sap offset new-value) (declare (type system-area-pointer sap) - (fixnum offset) - (type (signed-byte 32) new-value)) + (fixnum offset) + (type (signed-byte 32) new-value)) (setf (signed-sap-ref-32 sap offset) new-value)) (defun %set-signed-sap-ref-64 (sap offset new-value) (declare (type system-area-pointer sap) - (fixnum offset) - (type (signed-byte 64) new-value)) + (fixnum offset) + (type (signed-byte 64) new-value)) (setf (signed-sap-ref-64 sap offset) new-value)) (defun %set-signed-sap-ref-word (sap offset new-value) (declare (type system-area-pointer sap) - (fixnum offset) - (type (signed-byte #.sb!vm:n-machine-word-bits) new-value)) + (fixnum offset) + (type (signed-byte #.sb!vm:n-machine-word-bits) new-value)) (setf (signed-sap-ref-word sap offset) new-value)) (defun %set-sap-ref-sap (sap offset new-value) (declare (type system-area-pointer sap new-value) - (fixnum offset)) + (fixnum offset)) (setf (sap-ref-sap sap offset) new-value)) (defun %set-sap-ref-single (sap offset new-value) (declare (type system-area-pointer sap) - (fixnum offset) - (type single-float new-value)) + (fixnum offset) + (type single-float new-value)) (setf (sap-ref-single sap offset) new-value)) (defun %set-sap-ref-double (sap offset new-value) (declare (type system-area-pointer sap) - (fixnum offset) - (type double-float new-value)) + (fixnum offset) + (type double-float new-value)) (setf (sap-ref-double sap offset) new-value)) #!+long-float (defun %set-sap-ref-long (sap offset new-value) (declare (type system-area-pointer sap) - (fixnum offset) - (type long-float new-value)) + (fixnum offset) + (type long-float new-value)) (setf (sap-ref-long sap offset) new-value)) diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index b627bd9..0d754e5 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -49,7 +49,7 @@ ;;;; C routines that actually do all the work of establishing signal handlers (sb!alien:define-alien-routine ("install_handler" install-handler) - sb!alien:unsigned-long + sb!alien:unsigned-long (signal sb!alien:int) (handler sb!alien:unsigned-long)) @@ -60,15 +60,15 @@ (/show0 "enable-interrupt") (without-gcing (let ((result (install-handler signal - (case handler - (:default sig_dfl) - (:ignore sig_ign) - (t - (sb!kernel:get-lisp-obj-address - handler)))))) + (case handler + (:default sig_dfl) + (:ignore sig_ign) + (t + (sb!kernel:get-lisp-obj-address + handler)))))) (cond ((= result sig_dfl) :default) - ((= result sig_ign) :ignore) - (t (the (or function fixnum) (sb!kernel:make-lisp-obj result))))))) + ((= result sig_ign) :ignore) + (t (the (or function fixnum) (sb!kernel:make-lisp-obj result))))))) (defun default-interrupt (signal) (enable-interrupt signal :default)) @@ -97,15 +97,15 @@ (eval-when (:compile-toplevel :execute) (sb!xc:defmacro define-signal-handler (name - what - &optional (function 'error)) + what + &optional (function 'error)) `(defun ,name (signal info context) (declare (ignore signal info)) (declare (type system-area-pointer context)) (/show "in Lisp-level signal handler" ,(symbol-name name) (sap-int context)) (,function ,(concatenate 'simple-string what " at #X~X") - (with-alien ((context (* os-context-t) context)) - (sap-int (sb!vm:context-pc context))))))) + (with-alien ((context (* os-context-t) context)) + (sap-int (sb!vm:context-pc context))))))) (define-signal-handler sigint-handler "interrupted" sigint-%break) (define-signal-handler sigill-handler "illegal instruction") @@ -164,20 +164,20 @@ Establish function as a handler for the Unix signal interrupt which should be a number between 1 and 31 inclusive." (let ((il (gensym)) - (it (gensym))) + (it (gensym))) `(let ((,il NIL)) (unwind-protect - (progn - ,@(do* ((item interrupt-list (cdr item)) - (intr (caar item) (caar item)) - (ifcn (cadar item) (cadar item)) - (forms NIL)) - ((null item) (nreverse forms)) - (when (symbolp intr) - (setq intr (symbol-value intr))) - (push `(push `(,,intr ,(enable-interrupt ,intr ,ifcn)) ,il) - forms)) - ,@body) - (dolist (,it (nreverse ,il)) - (enable-interrupt (car ,it) (cadr ,it))))))) + (progn + ,@(do* ((item interrupt-list (cdr item)) + (intr (caar item) (caar item)) + (ifcn (cadar item) (cadar item)) + (forms NIL)) + ((null item) (nreverse forms)) + (when (symbolp intr) + (setq intr (symbol-value intr))) + (push `(push `(,,intr ,(enable-interrupt ,intr ,ifcn)) ,il) + forms)) + ,@body) + (dolist (,it (nreverse ,il)) + (enable-interrupt (car ,it) (cadr ,it))))))) |# diff --git a/src/code/target-stream.lisp b/src/code/target-stream.lisp index 3144550..4da3db1 100644 --- a/src/code/target-stream.lisp +++ b/src/code/target-stream.lisp @@ -36,7 +36,7 @@ eof-value)) ((characterp ,peek-type) (do ((,char-var ,char-var ,read-form)) - ((or (eql ,char-var ,read-eof) + ((or (eql ,char-var ,read-eof) (char= ,char-var ,peek-type)) (cond ((eql ,char-var ,read-eof) ,(if eof-detected-form @@ -78,14 +78,14 @@ (generalized-peeking-mechanism peek-type eof-value char (ansi-stream-read-char stream eof-error-p :eof recursive-p) - :eof + :eof (ansi-stream-unread-char char stream))))) (defun peek-char (&optional (peek-type nil) - (stream *standard-input*) - (eof-error-p t) - eof-value - recursive-p) + (stream *standard-input*) + (eof-error-p t) + eof-value + recursive-p) (the (or character boolean) peek-type) (let ((stream (in-synonym-of stream))) (if (ansi-stream-p stream) @@ -97,7 +97,7 @@ (if (null peek-type) (stream-peek-char stream) (stream-read-char stream)) - :eof + :eof (if (null peek-type) () (stream-unread-char stream char)) @@ -106,21 +106,21 @@ (defun echo-misc (stream operation &optional arg1 arg2) (let* ((in (two-way-stream-input-stream stream)) - (out (two-way-stream-output-stream stream))) + (out (two-way-stream-output-stream stream))) (case operation (:listen (or (not (null (echo-stream-unread-stuff stream))) - (if (ansi-stream-p in) - (or (/= (the fixnum (ansi-stream-in-index in)) - +ansi-stream-in-buffer-length+) - (funcall (ansi-stream-misc in) in :listen)) - (stream-misc-dispatch in :listen)))) + (if (ansi-stream-p in) + (or (/= (the fixnum (ansi-stream-in-index in)) + +ansi-stream-in-buffer-length+) + (funcall (ansi-stream-misc in) in :listen)) + (stream-misc-dispatch in :listen)))) (:unread (push arg1 (echo-stream-unread-stuff stream))) (:element-type (let ((in-type (stream-element-type in)) - (out-type (stream-element-type out))) - (if (equal in-type out-type) - in-type `(and ,in-type ,out-type)))) + (out-type (stream-element-type out))) + (if (equal in-type out-type) + in-type `(and ,in-type ,out-type)))) (:close (set-closed-flame stream)) (:peek-char @@ -138,32 +138,32 @@ ;; the semantics for UNREAD-CHAR are held; the character should ;; not be echoed again. (let ((unread-char-p nil)) - (flet ((outfn (c) - (unless unread-char-p - (if (ansi-stream-p out) - (funcall (ansi-stream-out out) out c) - ;; gray-stream - (stream-write-char out c)))) - (infn () - ;; Obtain input from unread buffer or input stream, - ;; and set the flag appropriately. - (cond ((not (null (echo-stream-unread-stuff stream))) - (setf unread-char-p t) - (pop (echo-stream-unread-stuff stream))) - (t - (setf unread-char-p nil) - (read-char in (first arg2) :eof))))) - (generalized-peeking-mechanism - arg1 (second arg2) char - (infn) - :eof - (unread-char char in) - (outfn char))))) + (flet ((outfn (c) + (unless unread-char-p + (if (ansi-stream-p out) + (funcall (ansi-stream-out out) out c) + ;; gray-stream + (stream-write-char out c)))) + (infn () + ;; Obtain input from unread buffer or input stream, + ;; and set the flag appropriately. + (cond ((not (null (echo-stream-unread-stuff stream))) + (setf unread-char-p t) + (pop (echo-stream-unread-stuff stream))) + (t + (setf unread-char-p nil) + (read-char in (first arg2) :eof))))) + (generalized-peeking-mechanism + arg1 (second arg2) char + (infn) + :eof + (unread-char char in) + (outfn char))))) (t (or (if (ansi-stream-p in) - (funcall (ansi-stream-misc in) in operation arg1 arg2) - (stream-misc-dispatch in operation arg1 arg2)) - (if (ansi-stream-p out) - (funcall (ansi-stream-misc out) out operation arg1 arg2) - (stream-misc-dispatch out operation arg1 arg2))))))) + (funcall (ansi-stream-misc in) in operation arg1 arg2) + (stream-misc-dispatch in operation arg1 arg2)) + (if (ansi-stream-p out) + (funcall (ansi-stream-misc out) out operation arg1 arg2) + (stream-misc-dispatch out operation arg1 arg2))))))) diff --git a/src/code/target-sxhash.lisp b/src/code/target-sxhash.lisp index cbc2267..635bf491 100644 --- a/src/code/target-sxhash.lisp +++ b/src/code/target-sxhash.lisp @@ -26,7 +26,7 @@ ;;; desiderata: ;;; * Non-commutativity keeps us from hashing e.g. #(1 5) to the ;;; same value as #(5 1), and ending up in real trouble in some -;;; special cases like bit vectors the way that CMUCL 18b SXHASH +;;; special cases like bit vectors the way that CMUCL 18b SXHASH ;;; does. (Under CMUCL 18b, SXHASH of any bit vector is 1..) ;;; * We'd like to scatter our hash values over the entire possible range ;;; of values instead of hashing small or common key values (like @@ -90,15 +90,15 @@ (declare (type string string)) (declare (type index count)) (macrolet ((set-result (form) - `(setf result (ldb (byte #.sb!vm:n-word-bits 0) ,form)))) + `(setf result (ldb (byte #.sb!vm:n-word-bits 0) ,form)))) (let ((result 0)) (declare (type (unsigned-byte #.sb!vm:n-word-bits) result)) (unless (typep string '(vector nil)) - (dotimes (i count) - (declare (type index i)) - (set-result (+ result (char-code (aref string i)))) - (set-result (+ result (ash result 10))) - (set-result (logxor result (ash result -6))))) + (dotimes (i count) + (declare (type index i)) + (set-result (+ result (char-code (aref string i)))) + (set-result (+ result (ash result 10))) + (set-result (logxor result (ash result -6))))) (set-result (+ result (ash result 3))) (set-result (logxor result (ash result -11))) (set-result (logxor result (ash result 15))) @@ -107,11 +107,11 @@ ;;; (let ((ht (make-hash-table :test 'equal))) ;;; (do-all-symbols (symbol) ;;; (let* ((string (symbol-name symbol)) -;;; (hash (%sxhash-substring string))) -;;; (if (gethash hash ht) -;;; (unless (string= (gethash hash ht) string) -;;; (format t "collision: ~S ~S~%" string (gethash hash ht))) -;;; (setf (gethash hash ht) string)))) +;;; (hash (%sxhash-substring string))) +;;; (if (gethash hash ht) +;;; (unless (string= (gethash hash ht) string) +;;; (format t "collision: ~S ~S~%" string (gethash hash ht))) +;;; (setf (gethash hash ht) string)))) ;;; (format t "final count=~W~%" (hash-table-count ht))) (defun %sxhash-simple-string (x) @@ -131,7 +131,7 @@ (declare (type index count)) ;; see comment in %SXHASH-SIMPLE-STRING (flet ((trick (x count) - (%sxhash-substring x count))) + (%sxhash-substring x count))) (declare (notinline trick)) (trick x count))) @@ -148,67 +148,67 @@ ;; fast, in case it is the bottleneck somwhere. -- CSR, 2003-03-14 (declare (optimize speed)) (labels ((sxhash-number (x) - (etypecase x - (fixnum (sxhash x)) ; through DEFTRANSFORM - (integer (sb!bignum:sxhash-bignum x)) - (single-float (sxhash x)) ; through DEFTRANSFORM - (double-float (sxhash x)) ; through DEFTRANSFORM - #!+long-float (long-float (error "stub: no LONG-FLOAT")) - (ratio (let ((result 127810327)) - (declare (type fixnum result)) - (mixf result (sxhash-number (numerator x))) - (mixf result (sxhash-number (denominator x))) - result)) - (complex (let ((result 535698211)) - (declare (type fixnum result)) - (mixf result (sxhash-number (realpart x))) - (mixf result (sxhash-number (imagpart x))) - result)))) - (sxhash-recurse (x depthoid) - (declare (type index depthoid)) - (typecase x - ;; we test for LIST here, rather than CONS, because the - ;; type test for CONS is in fact the test for - ;; LIST-POINTER-LOWTAG followed by a negated test for - ;; NIL. If we're going to have to test for NIL anyway, - ;; we might as well do it explicitly and pick off the - ;; answer. -- CSR, 2004-07-14 - (list - (if (null x) - (sxhash x) ; through DEFTRANSFORM - (if (plusp depthoid) - (mix (sxhash-recurse (car x) (1- depthoid)) - (sxhash-recurse (cdr x) (1- depthoid))) - 261835505))) - (instance - (if (or (typep x 'structure-object) (typep x 'condition)) - (logxor 422371266 - (sxhash ; through DEFTRANSFORM - (classoid-name - (layout-classoid (%instance-layout x))))) - (sxhash-instance x))) - (symbol (sxhash x)) ; through DEFTRANSFORM - (array - (typecase x - (simple-string (sxhash x)) ; through DEFTRANSFORM - (string (%sxhash-substring x)) - (simple-bit-vector (sxhash x)) ; through DEFTRANSFORM - (bit-vector - ;; FIXME: It must surely be possible to do better - ;; than this. The problem is that a non-SIMPLE - ;; BIT-VECTOR could be displaced to another, with a - ;; non-zero offset -- so that significantly more - ;; work needs to be done using the %RAW-BITS - ;; approach. This will probably do for now. - (sxhash-recurse (copy-seq x) depthoid)) - (t (logxor 191020317 (sxhash (array-rank x)))))) - (character - (logxor 72185131 - (sxhash (char-code x)))) ; through DEFTRANSFORM - ;; general, inefficient case of NUMBER - (number (sxhash-number x)) - (generic-function (sxhash-instance x)) - (t 42)))) + (etypecase x + (fixnum (sxhash x)) ; through DEFTRANSFORM + (integer (sb!bignum:sxhash-bignum x)) + (single-float (sxhash x)) ; through DEFTRANSFORM + (double-float (sxhash x)) ; through DEFTRANSFORM + #!+long-float (long-float (error "stub: no LONG-FLOAT")) + (ratio (let ((result 127810327)) + (declare (type fixnum result)) + (mixf result (sxhash-number (numerator x))) + (mixf result (sxhash-number (denominator x))) + result)) + (complex (let ((result 535698211)) + (declare (type fixnum result)) + (mixf result (sxhash-number (realpart x))) + (mixf result (sxhash-number (imagpart x))) + result)))) + (sxhash-recurse (x depthoid) + (declare (type index depthoid)) + (typecase x + ;; we test for LIST here, rather than CONS, because the + ;; type test for CONS is in fact the test for + ;; LIST-POINTER-LOWTAG followed by a negated test for + ;; NIL. If we're going to have to test for NIL anyway, + ;; we might as well do it explicitly and pick off the + ;; answer. -- CSR, 2004-07-14 + (list + (if (null x) + (sxhash x) ; through DEFTRANSFORM + (if (plusp depthoid) + (mix (sxhash-recurse (car x) (1- depthoid)) + (sxhash-recurse (cdr x) (1- depthoid))) + 261835505))) + (instance + (if (or (typep x 'structure-object) (typep x 'condition)) + (logxor 422371266 + (sxhash ; through DEFTRANSFORM + (classoid-name + (layout-classoid (%instance-layout x))))) + (sxhash-instance x))) + (symbol (sxhash x)) ; through DEFTRANSFORM + (array + (typecase x + (simple-string (sxhash x)) ; through DEFTRANSFORM + (string (%sxhash-substring x)) + (simple-bit-vector (sxhash x)) ; through DEFTRANSFORM + (bit-vector + ;; FIXME: It must surely be possible to do better + ;; than this. The problem is that a non-SIMPLE + ;; BIT-VECTOR could be displaced to another, with a + ;; non-zero offset -- so that significantly more + ;; work needs to be done using the %RAW-BITS + ;; approach. This will probably do for now. + (sxhash-recurse (copy-seq x) depthoid)) + (t (logxor 191020317 (sxhash (array-rank x)))))) + (character + (logxor 72185131 + (sxhash (char-code x)))) ; through DEFTRANSFORM + ;; general, inefficient case of NUMBER + (number (sxhash-number x)) + (generic-function (sxhash-instance x)) + (t 42)))) (sxhash-recurse x +max-hash-depthoid+))) ;;;; the PSXHASH function @@ -246,37 +246,37 @@ ;; that we must respect fill pointers. (vector (macrolet ((frob () - '(let ((result 572539)) - (declare (type fixnum result)) - (mixf result (length key)) - (dotimes (i (min depthoid (length key))) - (declare (type fixnum i)) - (mixf result - (psxhash (aref key i) - (- depthoid 1 i)))) - result))) + '(let ((result 572539)) + (declare (type fixnum result)) + (mixf result (length key)) + (dotimes (i (min depthoid (length key))) + (declare (type fixnum i)) + (mixf result + (psxhash (aref key i) + (- depthoid 1 i)))) + result))) ;; CMU can compile SIMPLE-ARRAY operations so much more efficiently ;; than the general case that it's probably worth picking off the ;; common special cases. (typecase key - (simple-string - ;;(format t "~&SIMPLE-STRING special case~%") - (frob)) - (simple-vector - ;;(format t "~&SIMPLE-VECTOR special case~%") - (frob)) - (t (frob))))) + (simple-string + ;;(format t "~&SIMPLE-STRING special case~%") + (frob)) + (simple-vector + ;;(format t "~&SIMPLE-VECTOR special case~%") + (frob)) + (t (frob))))) ;; Any other array can be hashed by working with its underlying ;; one-dimensional physical representation. (t (let ((result 60828)) (declare (type fixnum result)) (dotimes (i (min depthoid (array-rank key))) - (mixf result (array-dimension key i))) + (mixf result (array-dimension key i))) (dotimes (i (min depthoid (array-total-size key))) - (mixf result - (psxhash (row-major-aref key i) - (- depthoid 1 i)))) + (mixf result + (psxhash (row-major-aref key i) + (- depthoid 1 i)))) result)))) (defun structure-object-psxhash (key depthoid) @@ -284,18 +284,18 @@ (declare (type structure-object key)) (declare (type (integer 0 #.+max-hash-depthoid+) depthoid)) (let* ((layout (%instance-layout key)) ; i.e. slot #0 - (length (layout-length layout)) - (classoid (layout-classoid layout)) - (name (classoid-name classoid)) - (result (mix (sxhash name) (the fixnum 79867)))) + (length (layout-length layout)) + (classoid (layout-classoid layout)) + (name (classoid-name classoid)) + (result (mix (sxhash name) (the fixnum 79867)))) (declare (type fixnum result)) (dotimes (i (min depthoid (- length 1 (layout-n-untagged-slots layout)))) (declare (type fixnum i)) (let ((j (1+ i))) ; skipping slot #0, which is for LAYOUT - (declare (type fixnum j)) - (mixf result - (psxhash (%instance-ref key j) - (1- depthoid))))) + (declare (type fixnum j)) + (mixf result + (psxhash (%instance-ref key j) + (1- depthoid))))) ;; KLUDGE: Should hash untagged slots, too. (Although +max-hash-depthoid+ ;; is pretty low currently, so they might not make it into the hash ;; value anyway.) @@ -306,12 +306,12 @@ (declare (type list key)) (declare (type (integer 0 #.+max-hash-depthoid+) depthoid)) (cond ((null key) - (the fixnum 480929)) - ((zerop depthoid) - (the fixnum 779578)) - (t - (mix (psxhash (car key) (1- depthoid)) - (psxhash (cdr key) (1- depthoid)))))) + (the fixnum 480929)) + ((zerop depthoid) + (the fixnum 779578)) + (t + (mix (psxhash (car key) (1- depthoid)) + (psxhash (cdr key) (1- depthoid)))))) (defun hash-table-psxhash (key) (declare (optimize speed)) @@ -326,46 +326,46 @@ (declare (optimize speed)) (declare (type number key)) (flet ((sxhash-double-float (val) - (declare (type double-float val)) - ;; FIXME: Check to make sure that the DEFTRANSFORM kicks in and the - ;; resulting code works without consing. (In Debian cmucl 2.4.17, - ;; it didn't.) - (sxhash val))) + (declare (type double-float val)) + ;; FIXME: Check to make sure that the DEFTRANSFORM kicks in and the + ;; resulting code works without consing. (In Debian cmucl 2.4.17, + ;; it didn't.) + (sxhash val))) (etypecase key (integer (sxhash key)) (float (macrolet ((frob (type) - (let ((lo (coerce most-negative-fixnum type)) - (hi (coerce most-positive-fixnum type))) - `(cond (;; This clause allows FIXNUM-sized integer - ;; values to be handled without consing. - (<= ,lo key ,hi) - (multiple-value-bind (q r) - (floor (the (,type ,lo ,hi) key)) - (if (zerop (the ,type r)) - (sxhash q) - (sxhash-double-float - (coerce key 'double-float))))) - (t - (multiple-value-bind (q r) (floor key) - (if (zerop (the ,type r)) - (sxhash q) - (sxhash-double-float - (coerce key 'double-float))))))))) - (etypecase key - (single-float (frob single-float)) - (double-float (frob double-float)) - #!+long-float - (long-float (error "LONG-FLOAT not currently supported"))))) + (let ((lo (coerce most-negative-fixnum type)) + (hi (coerce most-positive-fixnum type))) + `(cond (;; This clause allows FIXNUM-sized integer + ;; values to be handled without consing. + (<= ,lo key ,hi) + (multiple-value-bind (q r) + (floor (the (,type ,lo ,hi) key)) + (if (zerop (the ,type r)) + (sxhash q) + (sxhash-double-float + (coerce key 'double-float))))) + (t + (multiple-value-bind (q r) (floor key) + (if (zerop (the ,type r)) + (sxhash q) + (sxhash-double-float + (coerce key 'double-float))))))))) + (etypecase key + (single-float (frob single-float)) + (double-float (frob double-float)) + #!+long-float + (long-float (error "LONG-FLOAT not currently supported"))))) (rational (if (and (<= most-negative-double-float - key - most-positive-double-float) - (= (coerce key 'double-float) key)) - (sxhash-double-float (coerce key 'double-float)) - (sxhash key))) + key + most-positive-double-float) + (= (coerce key 'double-float) key)) + (sxhash-double-float (coerce key 'double-float)) + (sxhash key))) (complex (if (zerop (imagpart key)) - (number-psxhash (realpart key)) - (let ((result 330231)) - (declare (type fixnum result)) - (mixf result (number-psxhash (realpart key))) - (mixf result (number-psxhash (imagpart key))) - result)))))) + (number-psxhash (realpart key)) + (let ((result 330231)) + (declare (type fixnum result)) + (mixf result (number-psxhash (realpart key))) + (mixf result (number-psxhash (imagpart key))) + result)))))) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 67ef209..81e7130 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -40,10 +40,10 @@ in future versions." (defun thread-state (thread) (let ((state - (sb!sys:sap-int - (sb!sys:sap-ref-sap (thread-%sap thread) - (* sb!vm::thread-state-slot - sb!vm::n-word-bytes))))) + (sb!sys:sap-int + (sb!sys:sap-ref-sap (thread-%sap thread) + (* sb!vm::thread-state-slot + sb!vm::n-word-bytes))))) (ecase state (#.(sb!vm:fixnumize 0) :starting) (#.(sb!vm:fixnumize 1) :running) @@ -55,11 +55,11 @@ in future versions." (* sb!vm::thread-state-slot sb!vm::n-word-bytes)) (sb!sys:int-sap - (ecase state - (:starting #.(sb!vm:fixnumize 0)) - (:running #.(sb!vm:fixnumize 1)) - (:suspended #.(sb!vm:fixnumize 2)) - (:dead #.(sb!vm:fixnumize 3)))))) + (ecase state + (:starting #.(sb!vm:fixnumize 0)) + (:running #.(sb!vm:fixnumize 1)) + (:suspended #.(sb!vm:fixnumize 2)) + (:dead #.(sb!vm:fixnumize 3)))))) (defun thread-alive-p (thread) #!+sb-doc @@ -130,7 +130,7 @@ in future versions." "Spinlock type." (name nil :type (or null simple-string)) (value 0)) - + (declaim (inline get-spinlock release-spinlock)) ;;; The bare 2 here and below are offsets of the slots in the struct. diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index 5639b78..aa7b7a1 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -30,29 +30,29 @@ (declare (type ctype type)) (etypecase type ((or numeric-type - named-type - member-type - array-type + named-type + member-type + array-type character-set-type - built-in-classoid - cons-type) + built-in-classoid + cons-type) (values (%typep obj type) t)) (classoid (if (if (csubtypep type (specifier-type 'funcallable-instance)) - (funcallable-instance-p obj) - (typep obj 'instance)) - (if (eq (classoid-layout type) - (info :type :compiler-layout (classoid-name type))) - (values (sb!xc:typep obj type) t) - (values nil nil)) - (values nil t))) + (funcallable-instance-p obj) + (typep obj 'instance)) + (if (eq (classoid-layout type) + (info :type :compiler-layout (classoid-name type))) + (values (sb!xc:typep obj type) t) + (values nil nil)) + (values nil t))) (compound-type (funcall (etypecase type - (intersection-type #'every/type) - (union-type #'any/type)) - #'ctypep - obj - (compound-type-types type))) + (intersection-type #'every/type) + (union-type #'any/type)) + #'ctypep + obj + (compound-type-types type))) (fun-type (values (functionp obj) t)) (unknown-type @@ -61,54 +61,54 @@ (values (alien-typep obj (alien-type-type-alien-type type)) t)) (negation-type (multiple-value-bind (res win) - (ctypep obj (negation-type-type type)) + (ctypep obj (negation-type-type type)) (if win - (values (not res) t) - (values nil nil)))) + (values (not res) t) + (values nil nil)))) (hairy-type ;; Now the tricky stuff. (let* ((hairy-spec (hairy-type-specifier type)) - (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) + (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) (ecase symbol - (and - (if (atom hairy-spec) - (values t t) - (dolist (spec (cdr hairy-spec) (values t t)) - (multiple-value-bind (res win) - (ctypep obj (specifier-type spec)) - (unless win (return (values nil nil))) - (unless res (return (values nil t))))))) - (not - (multiple-value-bind (res win) - (ctypep obj (specifier-type (cadr hairy-spec))) - (if win - (values (not res) t) - (values nil nil)))) - (satisfies - (let ((predicate-name (second hairy-spec))) - (declare (type symbol predicate-name)) ; by ANSI spec of SATISFIES - (if (fboundp predicate-name) - (let* (;; "Is OBJ of the SATISFIES type?" represented - ;; as a generalized boolean. - ;; - ;; (Why IGNORE-ERRORS? This code is used to try to - ;; check type relationships at compile time. - ;; Passing only-slightly-twisted types like - ;; (AND INTEGER (SATISFIES ODDP)) into the - ;; rather-significantly-twisted type dispatch - ;; system can easily give rise to oddities like - ;; calling predicates like ODDP on values they - ;; don't like. (E.g. on OBJ=#\NEWLINE when the - ;; above type is tested for TYPE= against - ;; STANDARD-CHAR, represented as a - ;; MEMBER-TYPE.) In such cases, NIL seems to be - ;; an appropriate answer to "is OBJ of the - ;; SATISFIES type?") - (gbool (ignore-errors (funcall predicate-name obj))) - ;; RAW coerced to a pure BOOLEAN value - (bool (not (not gbool)))) - (values bool t)) - (values nil nil))))))))) + (and + (if (atom hairy-spec) + (values t t) + (dolist (spec (cdr hairy-spec) (values t t)) + (multiple-value-bind (res win) + (ctypep obj (specifier-type spec)) + (unless win (return (values nil nil))) + (unless res (return (values nil t))))))) + (not + (multiple-value-bind (res win) + (ctypep obj (specifier-type (cadr hairy-spec))) + (if win + (values (not res) t) + (values nil nil)))) + (satisfies + (let ((predicate-name (second hairy-spec))) + (declare (type symbol predicate-name)) ; by ANSI spec of SATISFIES + (if (fboundp predicate-name) + (let* (;; "Is OBJ of the SATISFIES type?" represented + ;; as a generalized boolean. + ;; + ;; (Why IGNORE-ERRORS? This code is used to try to + ;; check type relationships at compile time. + ;; Passing only-slightly-twisted types like + ;; (AND INTEGER (SATISFIES ODDP)) into the + ;; rather-significantly-twisted type dispatch + ;; system can easily give rise to oddities like + ;; calling predicates like ODDP on values they + ;; don't like. (E.g. on OBJ=#\NEWLINE when the + ;; above type is tested for TYPE= against + ;; STANDARD-CHAR, represented as a + ;; MEMBER-TYPE.) In such cases, NIL seems to be + ;; an appropriate answer to "is OBJ of the + ;; SATISFIES type?") + (gbool (ignore-errors (funcall predicate-name obj))) + ;; RAW coerced to a pure BOOLEAN value + (bool (not (not gbool)))) + (values bool t)) + (values nil nil))))))))) ;;; Return the layout for an object. This is the basic operation for ;;; finding out the "type" of an object, and is used for generic @@ -120,19 +120,19 @@ (defun layout-of (x) (declare (optimize (speed 3) (safety 0))) (cond ((typep x 'instance) (%instance-layout x)) - ((funcallable-instance-p x) (%funcallable-instance-layout x)) - ((null x) - ;; Note: was #.((CLASS-LAYOUT (SB!XC:FIND-CLASS 'NULL))). - ;; I (WHN 19990209) replaced this with an expression evaluated at - ;; run time in order to make it easier to build the cross-compiler. - ;; If it doesn't work, something else will be needed.. - (locally - ;; KLUDGE: In order to really make this run at run time - ;; (instead of doing some weird broken thing at cold load - ;; time), we need to suppress a DEFTRANSFORM.. -- WHN 19991004 - (declare (notinline find-classoid)) - (classoid-layout (find-classoid 'null)))) - (t (svref *built-in-class-codes* (widetag-of x))))) + ((funcallable-instance-p x) (%funcallable-instance-layout x)) + ((null x) + ;; Note: was #.((CLASS-LAYOUT (SB!XC:FIND-CLASS 'NULL))). + ;; I (WHN 19990209) replaced this with an expression evaluated at + ;; run time in order to make it easier to build the cross-compiler. + ;; If it doesn't work, something else will be needed.. + (locally + ;; KLUDGE: In order to really make this run at run time + ;; (instead of doing some weird broken thing at cold load + ;; time), we need to suppress a DEFTRANSFORM.. -- WHN 19991004 + (declare (notinline find-classoid)) + (classoid-layout (find-classoid 'null)))) + (t (svref *built-in-class-codes* (widetag-of x))))) #!-sb-fluid (declaim (inline classoid-of)) (defun classoid-of (object) @@ -155,12 +155,12 @@ (declare (special *type-system-initialized*)) (when *type-system-initialized* (dolist (sym '(values-specifier-type-cache-clear - values-type-union-cache-clear - type-union2-cache-clear - values-subtypep-cache-clear - csubtypep-cache-clear - type-intersection2-cache-clear - values-type-intersection-cache-clear + values-type-union-cache-clear + type-union2-cache-clear + values-subtypep-cache-clear + csubtypep-cache-clear + type-intersection2-cache-clear + values-type-intersection-cache-clear type=-cache-clear)) (funcall (the function (symbol-function sym))))) (values)) @@ -171,15 +171,15 @@ ;;; user might find most informative. (declaim (ftype (function (t) ctype) ctype-of)) (defun-cached (ctype-of - :hash-function (lambda (x) (logand (sxhash x) #x1FF)) - :hash-bits 9 - :init-wrapper !cold-init-forms) - ((x eq)) + :hash-function (lambda (x) (logand (sxhash x) #x1FF)) + :hash-bits 9 + :init-wrapper !cold-init-forms) + ((x eq)) (typecase x (function (if (funcallable-instance-p x) - (classoid-of x) - (extract-fun-type x))) + (classoid-of x) + (extract-fun-type x))) (symbol (make-member-type :members (list x))) (number @@ -187,9 +187,9 @@ (array (let ((etype (specifier-type (array-element-type x)))) (make-array-type :dimensions (array-dimensions x) - :complexp (not (typep x 'simple-array)) - :element-type etype - :specialized-element-type etype))) + :complexp (not (typep x 'simple-array)) + :element-type etype + :specialized-element-type etype))) (cons (make-cons-type *universal-type* *universal-type*)) (character diff --git a/src/code/thread.lisp b/src/code/thread.lisp index cd4ca4f..9671d60 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -21,9 +21,9 @@ and the mutex is in use, sleep until it is available" (with-unique-names (got) `(let ((,got (get-mutex ,mutex ,value ,wait-p))) (when ,got - (unwind-protect - (locally ,@body) - (release-mutex ,mutex))))) + (unwind-protect + (locally ,@body) + (release-mutex ,mutex))))) ;; KLUDGE: this separate expansion for (NOT SB-THREAD) is not ;; strictly necessary; GET-MUTEX and RELEASE-MUTEX are implemented. ;; However, there would be a (possibly slight) performance hit in @@ -47,17 +47,17 @@ mutex." (sb!sys:int-sap (sb!kernel:get-lisp-obj-address (mutex-value ,mutex))))))) (unless ,inner-lock - ;; this punning with MAKE-LISP-OBJ depends for its safety on - ;; the frame pointer being a lispobj-aligned integer. While - ;; it is, then MAKE-LISP-OBJ will always return a FIXNUM, so - ;; we're safe to do that. Should this ever change, this - ;; MAKE-LISP-OBJ could return something that looks like a - ;; pointer, but pointing into neverneverland, which will - ;; confuse GC completely. -- CSR, 2003-06-03 - (get-mutex ,mutex (sb!kernel:make-lisp-obj (sb!sys:sap-int ,cfp)))) + ;; this punning with MAKE-LISP-OBJ depends for its safety on + ;; the frame pointer being a lispobj-aligned integer. While + ;; it is, then MAKE-LISP-OBJ will always return a FIXNUM, so + ;; we're safe to do that. Should this ever change, this + ;; MAKE-LISP-OBJ could return something that looks like a + ;; pointer, but pointing into neverneverland, which will + ;; confuse GC completely. -- CSR, 2003-06-03 + (get-mutex ,mutex (sb!kernel:make-lisp-obj (sb!sys:sap-int ,cfp)))) (unwind-protect - (locally ,@body) + (locally ,@body) (unless ,inner-lock - (release-mutex ,mutex))))) + (release-mutex ,mutex))))) #!-sb-thread `(locally ,@body)) diff --git a/src/code/time.lisp b/src/code/time.lisp index c028cb2..52c3059 100644 --- a/src/code/time.lisp +++ b/src/code/time.lisp @@ -32,18 +32,18 @@ (multiple-value-bind (ignore seconds useconds) (sb!unix:unix-gettimeofday) (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds)) (let ((base *internal-real-time-base-seconds*) - (uint (truncate useconds - micro-seconds-per-internal-time-unit))) + (uint (truncate useconds + micro-seconds-per-internal-time-unit))) (declare (type (unsigned-byte 32) uint)) (cond (base - (truly-the (unsigned-byte 32) - (+ (the (unsigned-byte 32) - (* (the (unsigned-byte 32) (- seconds base)) - sb!xc:internal-time-units-per-second)) - uint))) - (t - (setq *internal-real-time-base-seconds* seconds) - uint))))) + (truly-the (unsigned-byte 32) + (+ (the (unsigned-byte 32) + (* (the (unsigned-byte 32) (- seconds base)) + sb!xc:internal-time-units-per-second)) + uint))) + (t + (setq *internal-real-time-base-seconds* seconds) + uint))))) (defun get-internal-run-time () #!+sb-doc @@ -53,19 +53,19 @@ (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec) (sb!unix:unix-fast-getrusage sb!unix:rusage_self) (declare (ignore ignore) - (type (unsigned-byte 31) utime-sec stime-sec) - ;; (Classic CMU CL had these (MOD 1000000) instead, but - ;; at least in Linux 2.2.12, the type doesn't seem to be - ;; documented anywhere and the observed behavior is to - ;; sometimes return 1000000 exactly.) - (type (integer 0 1000000) utime-usec stime-usec)) + (type (unsigned-byte 31) utime-sec stime-sec) + ;; (Classic CMU CL had these (MOD 1000000) instead, but + ;; at least in Linux 2.2.12, the type doesn't seem to be + ;; documented anywhere and the observed behavior is to + ;; sometimes return 1000000 exactly.) + (type (integer 0 1000000) utime-usec stime-usec)) (let ((result (+ (the (unsigned-byte 32) - (* (the (unsigned-byte 32) (+ utime-sec stime-sec)) - sb!xc:internal-time-units-per-second)) - (floor (+ utime-usec - stime-usec - (floor micro-seconds-per-internal-time-unit 2)) - micro-seconds-per-internal-time-unit)))) + (* (the (unsigned-byte 32) (+ utime-sec stime-sec)) + sb!xc:internal-time-units-per-second)) + (floor (+ utime-usec + stime-usec + (floor micro-seconds-per-internal-time-unit 2)) + micro-seconds-per-internal-time-unit)))) result))) ;;;; Encode and decode universal times. @@ -139,18 +139,18 @@ (defconstant +mar-1-2035+ #.(encode-universal-time 0 0 0 1 3 2035 0)) (defun years-since-mar-2000 (utime) - "Returns number of complete years since March 1st 2000, and remainder in seconds" + "Returns number of complete years since March 1st 2000, and remainder in seconds" (let* ((days-in-year (* 86400 365)) - (days-in-4year (+ (* 4 days-in-year) 86400)) - (days-in-100year (- (* 25 days-in-4year) 86400)) - (days-in-400year (+ (* 4 days-in-100year) 86400)) - (offset (- utime +mar-1-2000+)) - (year 0)) + (days-in-4year (+ (* 4 days-in-year) 86400)) + (days-in-100year (- (* 25 days-in-4year) 86400)) + (days-in-400year (+ (* 4 days-in-100year) 86400)) + (offset (- utime +mar-1-2000+)) + (year 0)) (labels ((whole-num (x y inc max) - (let ((w (truncate x y))) - (when (and max (> w max)) (setf w max)) - (incf year (* w inc)) - (* w y)))) + (let ((w (truncate x y))) + (when (and max (> w max)) (setf w max)) + (incf year (* w inc)) + (* w y)))) (decf offset (whole-num offset days-in-400year 400 nil)) (decf offset (whole-num offset days-in-100year 100 3)) (decf offset (whole-num offset days-in-4year 4 25)) @@ -160,11 +160,11 @@ (defun truncate-to-unix-range (utime) (let ((unix-time (- utime unix-to-universal-time))) (if (< unix-time (ash 1 31)) - unix-time - (multiple-value-bind (year offset) (years-since-mar-2000 utime) - (declare (ignore year)) - (+ +mar-1-2035+ (- unix-to-universal-time) offset))))) - + unix-time + (multiple-value-bind (year offset) (years-since-mar-2000 utime) + (declare (ignore year)) + (+ +mar-1-2035+ (- unix-to-universal-time) offset))))) + (defun decode-universal-time (universal-time &optional time-zone) #!+sb-doc "Converts a universal-time to decoded time format returning the following @@ -173,117 +173,117 @@ Completely ignores daylight-savings-time when time-zone is supplied." (multiple-value-bind (daylight seconds-west) (if time-zone - (values nil (* time-zone 60 60)) - (multiple-value-bind (ignore seconds-west daylight) - (sb!unix::get-timezone (truncate-to-unix-range universal-time)) - (declare (ignore ignore)) - (declare (fixnum seconds-west)) - (values daylight seconds-west))) + (values nil (* time-zone 60 60)) + (multiple-value-bind (ignore seconds-west daylight) + (sb!unix::get-timezone (truncate-to-unix-range universal-time)) + (declare (ignore ignore)) + (declare (fixnum seconds-west)) + (values daylight seconds-west))) (declare (fixnum seconds-west)) (multiple-value-bind (weeks secs) - (truncate (+ (- universal-time seconds-west) seconds-offset) - seconds-in-week) + (truncate (+ (- universal-time seconds-west) seconds-offset) + seconds-in-week) (let ((weeks (+ weeks weeks-offset))) - (multiple-value-bind (t1 second) - (truncate secs 60) - (let ((tday (truncate t1 minutes-per-day))) - (multiple-value-bind (hour minute) - (truncate (- t1 (* tday minutes-per-day)) 60) - (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4))) - (tcent (truncate t2 quarter-days-per-century))) - (setq t2 (mod t2 quarter-days-per-century)) - (setq t2 (+ (- t2 (mod t2 4)) 3)) - (let* ((year (+ (* tcent 100) - (truncate t2 quarter-days-per-year))) - (days-since-mar0 - (1+ (truncate (mod t2 quarter-days-per-year) 4))) - (day (mod (+ tday weekday-november-17-1858) 7)) - (t3 (+ (* days-since-mar0 5) 456))) - (cond ((>= t3 1989) - (setq t3 (- t3 1836)) - (setq year (1+ year)))) - (multiple-value-bind (month t3) - (truncate t3 153) - (let ((date (1+ (truncate t3 5)))) - (values second minute hour date month year day - daylight - (if daylight - (1+ (/ seconds-west 60 60)) - (/ seconds-west 60 60)))))))))))))) + (multiple-value-bind (t1 second) + (truncate secs 60) + (let ((tday (truncate t1 minutes-per-day))) + (multiple-value-bind (hour minute) + (truncate (- t1 (* tday minutes-per-day)) 60) + (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4))) + (tcent (truncate t2 quarter-days-per-century))) + (setq t2 (mod t2 quarter-days-per-century)) + (setq t2 (+ (- t2 (mod t2 4)) 3)) + (let* ((year (+ (* tcent 100) + (truncate t2 quarter-days-per-year))) + (days-since-mar0 + (1+ (truncate (mod t2 quarter-days-per-year) 4))) + (day (mod (+ tday weekday-november-17-1858) 7)) + (t3 (+ (* days-since-mar0 5) 456))) + (cond ((>= t3 1989) + (setq t3 (- t3 1836)) + (setq year (1+ year)))) + (multiple-value-bind (month t3) + (truncate t3 153) + (let ((date (1+ (truncate t3 5)))) + (values second minute hour date month year day + daylight + (if daylight + (1+ (/ seconds-west 60 60)) + (/ seconds-west 60 60)))))))))))))) (defun pick-obvious-year (year) (declare (type (mod 100) year)) (let* ((current-year (nth-value 5 (get-decoded-time))) - (guess (+ year (* (truncate (- current-year 50) 100) 100)))) + (guess (+ year (* (truncate (- current-year 50) 100) 100)))) (declare (type (integer 1900 9999) current-year guess)) (if (> (- current-year guess) 50) - (+ guess 100) - guess))) + (+ guess 100) + guess))) (defun leap-years-before (year) (let ((years (- year 1901))) (+ (- (truncate years 4) - (truncate years 100)) + (truncate years 100)) (truncate (+ years 300) 400)))) (defvar *days-before-month* #.(let ((reversed-result nil) - (sum 0)) + (sum 0)) (push nil reversed-result) (dolist (days-in-month '(31 28 31 30 31 30 31 31 30 31 30 31)) - (push sum reversed-result) - (incf sum days-in-month)) + (push sum reversed-result) + (incf sum days-in-month)) (coerce (nreverse reversed-result) 'simple-vector))) - + (defun encode-universal-time (second minute hour date month year - &optional time-zone) + &optional time-zone) #!+sb-doc "The time values specified in decoded format are converted to universal time, which is returned." (declare (type (mod 60) second) - (type (mod 60) minute) - (type (mod 24) hour) - (type (integer 1 31) date) - (type (integer 1 12) month) - (type (or (integer 0 99) (integer 1900)) year) - (type (or null rational) time-zone)) + (type (mod 60) minute) + (type (mod 24) hour) + (type (integer 1 31) date) + (type (integer 1 12) month) + (type (or (integer 0 99) (integer 1900)) year) + (type (or null rational) time-zone)) (let* ((year (if (< year 100) - (pick-obvious-year year) - year)) - (days (+ (1- date) - (aref *days-before-month* month) - (if (> month 2) - (leap-years-before (1+ year)) - (leap-years-before year)) - (* (- year 1900) 365))) - (hours (+ hour (* days 24)))) + (pick-obvious-year year) + year)) + (days (+ (1- date) + (aref *days-before-month* month) + (if (> month 2) + (leap-years-before (1+ year)) + (leap-years-before year)) + (* (- year 1900) 365))) + (hours (+ hour (* days 24)))) (if time-zone - (+ second (* (+ minute (* (+ hours time-zone) 60)) 60)) - ;; can't ask unix for times after 2037: this is only a problem - ;; if we need to query the system timezone - (if (> year 2037) - (labels ((leap-year-p (year) - (cond ((zerop (mod year 400)) t) - ((zerop (mod year 100)) nil) - ((zerop (mod year 4)) t) - (t nil)))) - (let* ((fake-year (if (leap-year-p year) 2036 2037)) - (fake-time (encode-universal-time second minute hour - date month fake-year))) - (+ fake-time - (* 86400 (+ (* 365 (- year fake-year)) - (- (leap-years-before year) - (leap-years-before fake-year))))))) - (let* ((secwest-guess - (sb!unix::unix-get-seconds-west - (- (* hours 60 60) unix-to-universal-time))) - (guess (+ second (* 60 (+ minute (* hours 60))) - secwest-guess)) - (secwest - (sb!unix::unix-get-seconds-west - (- guess unix-to-universal-time)))) - (+ guess (- secwest secwest-guess))))))) + (+ second (* (+ minute (* (+ hours time-zone) 60)) 60)) + ;; can't ask unix for times after 2037: this is only a problem + ;; if we need to query the system timezone + (if (> year 2037) + (labels ((leap-year-p (year) + (cond ((zerop (mod year 400)) t) + ((zerop (mod year 100)) nil) + ((zerop (mod year 4)) t) + (t nil)))) + (let* ((fake-year (if (leap-year-p year) 2036 2037)) + (fake-time (encode-universal-time second minute hour + date month fake-year))) + (+ fake-time + (* 86400 (+ (* 365 (- year fake-year)) + (- (leap-years-before year) + (leap-years-before fake-year))))))) + (let* ((secwest-guess + (sb!unix::unix-get-seconds-west + (- (* hours 60 60) unix-to-universal-time))) + (guess (+ second (* 60 (+ minute (* hours 60))) + secwest-guess)) + (secwest + (sb!unix::unix-get-seconds-west + (- guess unix-to-universal-time)))) + (+ guess (- secwest secwest-guess))))))) ;;;; TIME @@ -308,30 +308,30 @@ (defun %time (fun) (declare (type function fun)) (let (old-run-utime - new-run-utime - old-run-stime - new-run-stime - old-real-time - new-real-time - old-page-faults - new-page-faults - real-time-overhead - run-utime-overhead - run-stime-overhead - page-faults-overhead - old-bytes-consed - new-bytes-consed - cons-overhead) + new-run-utime + old-run-stime + new-run-stime + old-real-time + new-real-time + old-page-faults + new-page-faults + real-time-overhead + run-utime-overhead + run-stime-overhead + page-faults-overhead + old-bytes-consed + new-bytes-consed + cons-overhead) ;; Calculate the overhead... (multiple-value-setq - (old-run-utime old-run-stime old-page-faults old-bytes-consed) + (old-run-utime old-run-stime old-page-faults old-bytes-consed) (time-get-sys-info)) ;; Do it a second time to make sure everything is faulted in. (multiple-value-setq - (old-run-utime old-run-stime old-page-faults old-bytes-consed) + (old-run-utime old-run-stime old-page-faults old-bytes-consed) (time-get-sys-info)) (multiple-value-setq - (new-run-utime new-run-stime new-page-faults new-bytes-consed) + (new-run-utime new-run-stime new-page-faults new-bytes-consed) (time-get-sys-info)) (setq run-utime-overhead (- new-run-utime old-run-utime)) (setq run-stime-overhead (- new-run-stime old-run-stime)) @@ -343,33 +343,33 @@ (setq cons-overhead (- new-bytes-consed old-bytes-consed)) ;; Now get the initial times. (multiple-value-setq - (old-run-utime old-run-stime old-page-faults old-bytes-consed) + (old-run-utime old-run-stime old-page-faults old-bytes-consed) (time-get-sys-info)) (setq old-real-time (get-internal-real-time)) (let ((start-gc-run-time *gc-run-time*)) (multiple-value-prog1 - ;; Execute the form and return its values. - (funcall fun) + ;; Execute the form and return its values. + (funcall fun) (multiple-value-setq - (new-run-utime new-run-stime new-page-faults new-bytes-consed) - (time-get-sys-info)) + (new-run-utime new-run-stime new-page-faults new-bytes-consed) + (time-get-sys-info)) (setq new-real-time (- (get-internal-real-time) real-time-overhead)) (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0))) - (format *trace-output* - "~&Evaluation took:~% ~ + (format *trace-output* + "~&Evaluation took:~% ~ ~S second~:P of real time~% ~ ~S second~:P of user run time~% ~ ~S second~:P of system run time~% ~ ~@[ [Run times include ~S second~:P GC run time.]~% ~]~ ~S page fault~:P and~% ~ ~:D bytes consed.~%" - (max (/ (- new-real-time old-real-time) - (float sb!xc:internal-time-units-per-second)) - 0.0) - (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0) - (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0) - (unless (zerop gc-run-time) - (/ (float gc-run-time) - (float sb!xc:internal-time-units-per-second))) - (max (- new-page-faults old-page-faults) 0) - (max (- new-bytes-consed old-bytes-consed) 0))))))) + (max (/ (- new-real-time old-real-time) + (float sb!xc:internal-time-units-per-second)) + 0.0) + (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0) + (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0) + (unless (zerop gc-run-time) + (/ (float gc-run-time) + (float sb!xc:internal-time-units-per-second))) + (max (- new-page-faults old-page-faults) 0) + (max (- new-bytes-consed old-bytes-consed) 0))))))) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 7643a91..f77abc1 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -26,12 +26,12 @@ ;;; FIXME: These could be converted to DEFVARs. (declaim (special *gc-inhibit* *need-to-collect-garbage* - *after-gc-hooks* - #!+(or x86 x86-64) *pseudo-atomic-atomic* - #!+(or x86 x86-64) *pseudo-atomic-interrupted* - sb!unix::*interrupts-enabled* - sb!unix::*interrupt-pending* - *type-system-initialized*)) + *after-gc-hooks* + #!+(or x86 x86-64) *pseudo-atomic-atomic* + #!+(or x86 x86-64) *pseudo-atomic-interrupted* + sb!unix::*interrupts-enabled* + sb!unix::*interrupt-pending* + *type-system-initialized*)) (defvar *cold-init-complete-p*) @@ -42,7 +42,7 @@ ;;;; stepping control (defvar *step*) (defvar *stepping*) -(defvar *step-form-stack* nil +(defvar *step-form-stack* nil "A place for single steppers to push information about STEP-FORM-CONDITIONS avaiting the corresponding STEP-VALUES-CONDITIONS. The system is guaranteed to empty the stack @@ -58,8 +58,8 @@ steppers to maintain contextual information.") (defmacro handling-end-of-the-world (&body body) (with-unique-names (caught) `(let ((,caught (catch '%end-of-the-world - (/show0 "inside CATCH '%END-OF-THE-WORLD") - ,@body))) + (/show0 "inside CATCH '%END-OF-THE-WORLD") + ,@body))) (/show0 "back from CATCH '%END-OF-THE-WORLD, flushing output") (flush-standard-output-streams) (sb!thread::terminate-session) @@ -84,26 +84,26 @@ steppers to maintain contextual information.") (/show0 "entering INFINITE-ERROR-PROTECTOR, *CURRENT-ERROR-DEPTH*=..") (/hexstr *current-error-depth*) (cond ((not *cold-init-complete-p*) - (%primitive print "Argh! error in cold init, halting") - (%primitive sb!c:halt)) - ((or (not (boundp '*current-error-depth*)) - (not (realp *current-error-depth*)) - (not (boundp '*maximum-error-depth*)) - (not (realp *maximum-error-depth*))) - (%primitive print "Argh! corrupted error depth, halting") - (%primitive sb!c:halt)) - ((> *current-error-depth* *maximum-error-depth*) - (/show0 "*MAXIMUM-ERROR-DEPTH*=..") - (/hexstr *maximum-error-depth*) - (/show0 "in INFINITE-ERROR-PROTECTOR, calling ERROR-ERROR") - (error-error "Help! " - *current-error-depth* - " nested errors. " - "SB-KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.") - t) - (t - (/show0 "returning normally from INFINITE-ERROR-PROTECTOR") - nil))) + (%primitive print "Argh! error in cold init, halting") + (%primitive sb!c:halt)) + ((or (not (boundp '*current-error-depth*)) + (not (realp *current-error-depth*)) + (not (boundp '*maximum-error-depth*)) + (not (realp *maximum-error-depth*))) + (%primitive print "Argh! corrupted error depth, halting") + (%primitive sb!c:halt)) + ((> *current-error-depth* *maximum-error-depth*) + (/show0 "*MAXIMUM-ERROR-DEPTH*=..") + (/hexstr *maximum-error-depth*) + (/show0 "in INFINITE-ERROR-PROTECTOR, calling ERROR-ERROR") + (error-error "Help! " + *current-error-depth* + " nested errors. " + "SB-KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.") + t) + (t + (/show0 "returning normally from INFINITE-ERROR-PROTECTOR") + nil))) ;;; FIXME: I had a badly broken version of INFINITE-ERROR-PROTECTOR at ;;; one point (shown below), and SBCL cross-compiled it without @@ -113,25 +113,25 @@ steppers to maintain contextual information.") #| (defun infinite-error-protector () `(cond ((not *cold-init-complete-p*) - (%primitive print "Argh! error in cold init, halting") - (%primitive sb!c:halt)) - ((or (not (boundp '*current-error-depth*)) - (not (realp *current-error-depth*)) - (not (boundp '*maximum-error-depth*)) - (not (realp *maximum-error-depth*))) - (%primitive print "Argh! corrupted error depth, halting") - (%primitive sb!c:halt)) - ((> *current-error-depth* *maximum-error-depth*) - (/show0 "in INFINITE-ERROR-PROTECTOR, calling ERROR-ERROR") - (error-error "Help! " - *current-error-depth* - " nested errors. " - "SB-KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.") - (progn ,@forms) - t) - (t - (/show0 "in INFINITE-ERROR-PROTECTOR, returning normally") - nil))) + (%primitive print "Argh! error in cold init, halting") + (%primitive sb!c:halt)) + ((or (not (boundp '*current-error-depth*)) + (not (realp *current-error-depth*)) + (not (boundp '*maximum-error-depth*)) + (not (realp *maximum-error-depth*))) + (%primitive print "Argh! corrupted error depth, halting") + (%primitive sb!c:halt)) + ((> *current-error-depth* *maximum-error-depth*) + (/show0 "in INFINITE-ERROR-PROTECTOR, calling ERROR-ERROR") + (error-error "Help! " + *current-error-depth* + " nested errors. " + "SB-KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.") + (progn ,@forms) + t) + (t + (/show0 "in INFINITE-ERROR-PROTECTOR, returning normally") + nil))) |# ;;;; miscellaneous external functions @@ -141,7 +141,7 @@ steppers to maintain contextual information.") "This function causes execution to be suspended for N seconds. N may be any non-negative, non-complex number." (when (or (not (realp n)) - (minusp n)) + (minusp n)) (error 'simple-type-error :format-control "invalid argument to SLEEP: ~S" :format-arguments (list n) @@ -149,10 +149,10 @@ steppers to maintain contextual information.") :expected-type '(real 0))) (multiple-value-bind (sec nsec) (if (integerp n) - (values n 0) - (multiple-value-bind (sec frac) - (truncate n) - (values sec (truncate frac 1e-9)))) + (values n 0) + (multiple-value-bind (sec frac) + (truncate n) + (values sec (truncate frac 1e-9)))) (sb!unix:nanosleep sec nsec)) nil) @@ -178,79 +178,79 @@ steppers to maintain contextual information.") (defun scrub-control-stack () (declare (optimize (speed 3) (safety 0)) - (values (unsigned-byte 20))) ; FIXME: DECLARE VALUES? + (values (unsigned-byte 20))) ; FIXME: DECLARE VALUES? #!-stack-grows-downward-not-upward (let* ((csp (sap-int (sb!c::control-stack-pointer-sap))) - (initial-offset (logand csp (1- bytes-per-scrub-unit))) - (end-of-stack - (- (sb!vm:fixnumize sb!vm:*control-stack-end*) - sb!c:*backend-page-size*))) + (initial-offset (logand csp (1- bytes-per-scrub-unit))) + (end-of-stack + (- (sb!vm:fixnumize sb!vm:*control-stack-end*) + sb!c:*backend-page-size*))) (labels - ((scrub (ptr offset count) - (declare (type system-area-pointer ptr) - (type (unsigned-byte 16) offset) - (type (unsigned-byte 20) count) - (values (unsigned-byte 20))) - (cond ((>= (sap-int ptr) end-of-stack) 0) - ((= offset bytes-per-scrub-unit) - (look (sap+ ptr bytes-per-scrub-unit) 0 count)) - (t - (setf (sap-ref-word ptr offset) 0) - (scrub ptr (+ offset sb!vm:n-word-bytes) count)))) - (look (ptr offset count) - (declare (type system-area-pointer ptr) - (type (unsigned-byte 16) offset) - (type (unsigned-byte 20) count) - (values (unsigned-byte 20))) - (cond ((>= (sap-int ptr) end-of-stack) 0) - ((= offset bytes-per-scrub-unit) - count) - ((zerop (sap-ref-word ptr offset)) - (look ptr (+ offset sb!vm:n-word-bytes) count)) - (t - (scrub ptr offset (+ count sb!vm:n-word-bytes)))))) + ((scrub (ptr offset count) + (declare (type system-area-pointer ptr) + (type (unsigned-byte 16) offset) + (type (unsigned-byte 20) count) + (values (unsigned-byte 20))) + (cond ((>= (sap-int ptr) end-of-stack) 0) + ((= offset bytes-per-scrub-unit) + (look (sap+ ptr bytes-per-scrub-unit) 0 count)) + (t + (setf (sap-ref-word ptr offset) 0) + (scrub ptr (+ offset sb!vm:n-word-bytes) count)))) + (look (ptr offset count) + (declare (type system-area-pointer ptr) + (type (unsigned-byte 16) offset) + (type (unsigned-byte 20) count) + (values (unsigned-byte 20))) + (cond ((>= (sap-int ptr) end-of-stack) 0) + ((= offset bytes-per-scrub-unit) + count) + ((zerop (sap-ref-word ptr offset)) + (look ptr (+ offset sb!vm:n-word-bytes) count)) + (t + (scrub ptr offset (+ count sb!vm:n-word-bytes)))))) (declare (type sb!vm::word csp)) (scrub (int-sap (- csp initial-offset)) - (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes) - 0))) + (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes) + 0))) #!+stack-grows-downward-not-upward (let* ((csp (sap-int (sb!c::control-stack-pointer-sap))) - (end-of-stack (+ (sb!vm:fixnumize sb!vm:*control-stack-start*) - sb!c:*backend-page-size*)) - (initial-offset (logand csp (1- bytes-per-scrub-unit)))) + (end-of-stack (+ (sb!vm:fixnumize sb!vm:*control-stack-start*) + sb!c:*backend-page-size*)) + (initial-offset (logand csp (1- bytes-per-scrub-unit)))) (labels - ((scrub (ptr offset count) - (declare (type system-area-pointer ptr) - (type (unsigned-byte 16) offset) - (type (unsigned-byte 20) count) - (values (unsigned-byte 20))) - (let ((loc (int-sap (- (sap-int ptr) (+ offset sb!vm:n-word-bytes))))) - (cond ((< (sap-int loc) end-of-stack) 0) - ((= offset bytes-per-scrub-unit) - (look (int-sap (- (sap-int ptr) bytes-per-scrub-unit)) - 0 count)) - (t ;; need to fix bug in %SET-STACK-REF - (setf (sap-ref-word loc 0) 0) - (scrub ptr (+ offset sb!vm:n-word-bytes) count))))) - (look (ptr offset count) - (declare (type system-area-pointer ptr) - (type (unsigned-byte 16) offset) - (type (unsigned-byte 20) count) - (values (unsigned-byte 20))) - (let ((loc (int-sap (- (sap-int ptr) offset)))) - (cond ((< (sap-int loc) end-of-stack) 0) - ((= offset bytes-per-scrub-unit) - count) - ((zerop (sb!kernel::get-lisp-obj-address (stack-ref loc 0))) - (look ptr (+ offset sb!vm:n-word-bytes) count)) - (t - (scrub ptr offset (+ count sb!vm:n-word-bytes))))))) + ((scrub (ptr offset count) + (declare (type system-area-pointer ptr) + (type (unsigned-byte 16) offset) + (type (unsigned-byte 20) count) + (values (unsigned-byte 20))) + (let ((loc (int-sap (- (sap-int ptr) (+ offset sb!vm:n-word-bytes))))) + (cond ((< (sap-int loc) end-of-stack) 0) + ((= offset bytes-per-scrub-unit) + (look (int-sap (- (sap-int ptr) bytes-per-scrub-unit)) + 0 count)) + (t ;; need to fix bug in %SET-STACK-REF + (setf (sap-ref-word loc 0) 0) + (scrub ptr (+ offset sb!vm:n-word-bytes) count))))) + (look (ptr offset count) + (declare (type system-area-pointer ptr) + (type (unsigned-byte 16) offset) + (type (unsigned-byte 20) count) + (values (unsigned-byte 20))) + (let ((loc (int-sap (- (sap-int ptr) offset)))) + (cond ((< (sap-int loc) end-of-stack) 0) + ((= offset bytes-per-scrub-unit) + count) + ((zerop (sb!kernel::get-lisp-obj-address (stack-ref loc 0))) + (look ptr (+ offset sb!vm:n-word-bytes) count)) + (t + (scrub ptr offset (+ count sb!vm:n-word-bytes))))))) (declare (type sb!vm::word csp)) (scrub (int-sap (+ csp initial-offset)) - (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes) - 0)))) + (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes) + 0)))) ;;;; the default toplevel function @@ -273,172 +273,172 @@ steppers to maintain contextual information.") (setf - form) (let ((results (multiple-value-list (eval form)))) (setf /// // - // / - / results - *** ** - ** * - * (car results))) + // / + / results + *** ** + ** * + * (car results))) (setf +++ ++ - ++ + - + -) + ++ + + + -) (unless (boundp '*) ;; The bogon returned an unbound marker. ;; FIXME: It would be safer to check every one of the values in RESULTS, ;; instead of just the first one. (setf * nil) (cerror "Go on with * set to NIL." - "EVAL returned an unbound marker.")) + "EVAL returned an unbound marker.")) (values-list /)) ;;; Flush anything waiting on one of the ANSI Common Lisp standard ;;; output streams before proceeding. (defun flush-standard-output-streams () (dolist (name '(*debug-io* - *error-output* - *query-io* - *standard-output* - *trace-output*)) + *error-output* + *query-io* + *standard-output* + *trace-output*)) (finish-output (symbol-value name))) (values)) (defun process-init-file (truename) (when truename - (restart-case - (with-open-file (s truename :if-does-not-exist nil) - (flet ((next () - (let ((form (read s nil s))) - (if (eq s form) - (return-from process-init-file nil) - (eval form))))) - (loop - (restart-case - (handler-bind ((error (lambda (e) - (error - "Error during processing of ~ + (restart-case + (with-open-file (s truename :if-does-not-exist nil) + (flet ((next () + (let ((form (read s nil s))) + (if (eq s form) + (return-from process-init-file nil) + (eval form))))) + (loop + (restart-case + (handler-bind ((error (lambda (e) + (error + "Error during processing of ~ initialization file ~A:~%~% ~A" - truename e)))) - (next)) - (continue () - :report "Ignore and continue processing."))))) + truename e)))) + (next)) + (continue () + :report "Ignore and continue processing."))))) (abort () - :report "Skip rest of initialization file.")))) + :report "Skip rest of initialization file.")))) -(defun process-eval-options (eval-strings) +(defun process-eval-options (eval-strings) (/show0 "handling --eval options") (flet ((process-1 (string) - (multiple-value-bind (expr pos) (read-from-string string) - (unless (eq string (read-from-string string nil string :start pos)) - (error "More the one expression in ~S" string)) - (eval expr) - (flush-standard-output-streams)))) + (multiple-value-bind (expr pos) (read-from-string string) + (unless (eq string (read-from-string string nil string :start pos)) + (error "More the one expression in ~S" string)) + (eval expr) + (flush-standard-output-streams)))) (restart-case - (dolist (expr-as-string eval-strings) - (/show0 "handling one --eval option") - (restart-case - (handler-bind ((error (lambda (e) - (error "Error during processing of --eval ~ + (dolist (expr-as-string eval-strings) + (/show0 "handling one --eval option") + (restart-case + (handler-bind ((error (lambda (e) + (error "Error during processing of --eval ~ option ~S:~%~% ~A" - expr-as-string e)))) - (process-1 expr-as-string)) - (continue () - :report "Ignore and continue with next --eval option."))) + expr-as-string e)))) + (process-1 expr-as-string)) + (continue () + :report "Ignore and continue with next --eval option."))) (abort () - :report "Skip rest of --eval options.")))) + :report "Skip rest of --eval options.")))) ;;; the default system top level function (defun toplevel-init () - (/show0 "entering TOPLEVEL-INIT") + (/show0 "entering TOPLEVEL-INIT") (let (;; value of --sysinit option - (sysinit nil) - ;; value of --userinit option - (userinit nil) - ;; values of --eval options, in reverse order; and also any - ;; other options (like --load) which're translated into --eval - ;; - ;; The values are stored as strings, so that they can be - ;; passed to READ only after their predecessors have been - ;; EVALed, so that things work when e.g. REQUIRE in one EVAL - ;; form creates a package referred to in the next EVAL form. - (reversed-evals nil) - ;; Has a --noprint option been seen? - (noprint nil) - ;; everything in *POSIX-ARGV* except for argv[0]=programname - (options (rest *posix-argv*))) + (sysinit nil) + ;; value of --userinit option + (userinit nil) + ;; values of --eval options, in reverse order; and also any + ;; other options (like --load) which're translated into --eval + ;; + ;; The values are stored as strings, so that they can be + ;; passed to READ only after their predecessors have been + ;; EVALed, so that things work when e.g. REQUIRE in one EVAL + ;; form creates a package referred to in the next EVAL form. + (reversed-evals nil) + ;; Has a --noprint option been seen? + (noprint nil) + ;; everything in *POSIX-ARGV* except for argv[0]=programname + (options (rest *posix-argv*))) (declare (type list options)) (/show0 "done with outer LET in TOPLEVEL-INIT") - + ;; FIXME: There are lots of ways for errors to happen around here ;; (e.g. bad command line syntax, or READ-ERROR while trying to ;; READ an --eval string). Make sure that they're handled ;; reasonably. - + ;; Process command line options. (flet (;; Errors while processing the command line cause the system - ;; to QUIT, instead of trying to go into the Lisp debugger, - ;; because trying to go into the Lisp debugger would get - ;; into various annoying issues of where we should go after - ;; the user tries to return from the debugger. - (startup-error (control-string &rest args) + ;; to QUIT, instead of trying to go into the Lisp debugger, + ;; because trying to go into the Lisp debugger would get + ;; into various annoying issues of where we should go after + ;; the user tries to return from the debugger. + (startup-error (control-string &rest args) (format - *error-output* - "fatal error before reaching READ-EVAL-PRINT loop: ~% ~?~%" - control-string - args) + *error-output* + "fatal error before reaching READ-EVAL-PRINT loop: ~% ~?~%" + control-string + args) (quit :unix-status 1))) (loop while options do - (/show0 "at head of LOOP WHILE OPTIONS DO in TOPLEVEL-INIT") - (let ((option (first options))) - (flet ((pop-option () - (if options - (pop options) - (startup-error - "unexpected end of command line options")))) - (cond ((string= option "--sysinit") - (pop-option) - (if sysinit - (startup-error "multiple --sysinit options") - (setf sysinit (pop-option)))) - ((string= option "--userinit") - (pop-option) - (if userinit - (startup-error "multiple --userinit options") - (setf userinit (pop-option)))) - ((string= option "--eval") - (pop-option) - (push (pop-option) reversed-evals)) - ((string= option "--load") - (pop-option) - (push - ;; FIXME: see BUG 296 - (concatenate 'string "(|LOAD| \"" (pop-option) "\")") - reversed-evals)) - ((string= option "--noprint") - (pop-option) - (setf noprint t)) - ((string= option "--disable-debugger") - (pop-option) - (push "(|DISABLE-DEBUGGER|)" reversed-evals)) - ((string= option "--end-toplevel-options") - (pop-option) - (return)) - (t - ;; Anything we don't recognize as a toplevel - ;; option must be the start of user-level - ;; options.. except that if we encounter - ;; "--end-toplevel-options" after we gave up - ;; because we didn't recognize an option as a - ;; toplevel option, then the option we gave up on - ;; must have been an error. (E.g. in - ;; "sbcl --eval '(a)' --eval'(b)' --end-toplevel-options" - ;; this test will let us detect that the string - ;; "--eval(b)" is an error.) - (if (find "--end-toplevel-options" options - :test #'string=) - (startup-error "bad toplevel option: ~S" - (first options)) - (return))))))) + (/show0 "at head of LOOP WHILE OPTIONS DO in TOPLEVEL-INIT") + (let ((option (first options))) + (flet ((pop-option () + (if options + (pop options) + (startup-error + "unexpected end of command line options")))) + (cond ((string= option "--sysinit") + (pop-option) + (if sysinit + (startup-error "multiple --sysinit options") + (setf sysinit (pop-option)))) + ((string= option "--userinit") + (pop-option) + (if userinit + (startup-error "multiple --userinit options") + (setf userinit (pop-option)))) + ((string= option "--eval") + (pop-option) + (push (pop-option) reversed-evals)) + ((string= option "--load") + (pop-option) + (push + ;; FIXME: see BUG 296 + (concatenate 'string "(|LOAD| \"" (pop-option) "\")") + reversed-evals)) + ((string= option "--noprint") + (pop-option) + (setf noprint t)) + ((string= option "--disable-debugger") + (pop-option) + (push "(|DISABLE-DEBUGGER|)" reversed-evals)) + ((string= option "--end-toplevel-options") + (pop-option) + (return)) + (t + ;; Anything we don't recognize as a toplevel + ;; option must be the start of user-level + ;; options.. except that if we encounter + ;; "--end-toplevel-options" after we gave up + ;; because we didn't recognize an option as a + ;; toplevel option, then the option we gave up on + ;; must have been an error. (E.g. in + ;; "sbcl --eval '(a)' --eval'(b)' --end-toplevel-options" + ;; this test will let us detect that the string + ;; "--eval(b)" is an error.) + (if (find "--end-toplevel-options" options + :test #'string=) + (startup-error "bad toplevel option: ~S" + (first options)) + (return))))))) (/show0 "done with LOOP WHILE OPTIONS DO in TOPLEVEL-INIT") ;; Delete all the options that we processed, so that only @@ -448,60 +448,60 @@ steppers to maintain contextual information.") ;; Handle initialization files. (/show0 "handling initialization files in TOPLEVEL-INIT") (flet (;; shared idiom for searching for SYSINITish and - ;; USERINITish files + ;; USERINITish files (probe-init-files (explicitly-specified-init-file-name - &rest default-init-file-names) + &rest default-init-file-names) (declare (type list default-init-file-names)) - (if explicitly-specified-init-file-name - (or (probe-file explicitly-specified-init-file-name) + (if explicitly-specified-init-file-name + (or (probe-file explicitly-specified-init-file-name) (startup-error "The file ~S was not found." - explicitly-specified-init-file-name)) + explicitly-specified-init-file-name)) (find-if (lambda (x) (and (stringp x) (probe-file x))) default-init-file-names))) - ;; shared idiom for creating default names for - ;; SYSINITish and USERINITish files - (init-file-name (maybe-dir-name basename) - (and maybe-dir-name - (concatenate 'string maybe-dir-name "/" basename)))) + ;; shared idiom for creating default names for + ;; SYSINITish and USERINITish files + (init-file-name (maybe-dir-name basename) + (and maybe-dir-name + (concatenate 'string maybe-dir-name "/" basename)))) (let ((sysinit-truename - (probe-init-files sysinit - (init-file-name (posix-getenv "SBCL_HOME") - "sbclrc") - "/etc/sbclrc")) + (probe-init-files sysinit + (init-file-name (posix-getenv "SBCL_HOME") + "sbclrc") + "/etc/sbclrc")) (userinit-truename - (probe-init-files userinit - (init-file-name (posix-getenv "HOME") - ".sbclrc")))) - - ;; This CATCH is needed for the debugger command TOPLEVEL to - ;; work. - (catch 'toplevel-catcher - ;; We wrap all the pre-REPL user/system customized startup - ;; code in a restart. - ;; - ;; (Why not wrap everything, even the stuff above, in this - ;; restart? Errors above here are basically command line - ;; or Unix environment errors, e.g. a missing file or a - ;; typo on the Unix command line, and you don't need to - ;; get into Lisp to debug them, you should just start over - ;; and do it right at the Unix level. Errors below here - ;; are generally errors in user Lisp code, and it might be - ;; helpful to let the user reach the REPL in order to help - ;; figure out what's going on.) - (restart-case - (progn - (process-init-file sysinit-truename) - (process-init-file userinit-truename) - (process-eval-options (reverse reversed-evals))) - (abort () - :report "Skip to toplevel READ/EVAL/PRINT loop." - (/show0 "CONTINUEing from pre-REPL RESTART-CASE") - (values)) ; (no-op, just fall through) - (quit () - :report "Quit SBCL (calling #'QUIT, killing the process)." - (/show0 "falling through to QUIT from pre-REPL RESTART-CASE") - (quit))))) + (probe-init-files userinit + (init-file-name (posix-getenv "HOME") + ".sbclrc")))) + + ;; This CATCH is needed for the debugger command TOPLEVEL to + ;; work. + (catch 'toplevel-catcher + ;; We wrap all the pre-REPL user/system customized startup + ;; code in a restart. + ;; + ;; (Why not wrap everything, even the stuff above, in this + ;; restart? Errors above here are basically command line + ;; or Unix environment errors, e.g. a missing file or a + ;; typo on the Unix command line, and you don't need to + ;; get into Lisp to debug them, you should just start over + ;; and do it right at the Unix level. Errors below here + ;; are generally errors in user Lisp code, and it might be + ;; helpful to let the user reach the REPL in order to help + ;; figure out what's going on.) + (restart-case + (progn + (process-init-file sysinit-truename) + (process-init-file userinit-truename) + (process-eval-options (reverse reversed-evals))) + (abort () + :report "Skip to toplevel READ/EVAL/PRINT loop." + (/show0 "CONTINUEing from pre-REPL RESTART-CASE") + (values)) ; (no-op, just fall through) + (quit () + :report "Quit SBCL (calling #'QUIT, killing the process)." + (/show0 "falling through to QUIT from pre-REPL RESTART-CASE") + (quit))))) ;; one more time for good measure, in case we fell out of the ;; RESTART-CASE above before one of the flushes in the ordinary @@ -534,32 +534,32 @@ steppers to maintain contextual information.") (defun toplevel-repl (noprint) (/show0 "entering TOPLEVEL-REPL") (let ((* nil) (** nil) (*** nil) - (- nil) - (+ nil) (++ nil) (+++ nil) - (/// nil) (// nil) (/ nil)) + (- nil) + (+ nil) (++ nil) (+++ nil) + (/// nil) (// nil) (/ nil)) (/show0 "about to funcall *REPL-FUN-GENERATOR*") (let ((repl-fun (funcall *repl-fun-generator*))) ;; Each REPL in a multithreaded world should have bindings of ;; most CL specials (most critically *PACKAGE*). (with-rebound-io-syntax - (handler-bind ((step-condition 'invoke-stepper)) - (let ((*stepping* nil) - (*step* nil)) - (loop - (/show0 "about to set up restarts in TOPLEVEL-REPL") - ;; CLHS recommends that there should always be an - ;; ABORT restart; we have this one here, and one per - ;; debugger level. - (with-simple-restart - (abort "~@") - (catch 'toplevel-catcher - (sb!unix::reset-signal-mask) - ;; In the event of a control-stack-exhausted-error, we - ;; should have unwound enough stack by the time we get - ;; here that this is now possible. - (sb!kernel::protect-control-stack-guard-page 1) - (funcall repl-fun noprint) - (critically-unreachable "after REPL")))))))))) + (handler-bind ((step-condition 'invoke-stepper)) + (let ((*stepping* nil) + (*step* nil)) + (loop + (/show0 "about to set up restarts in TOPLEVEL-REPL") + ;; CLHS recommends that there should always be an + ;; ABORT restart; we have this one here, and one per + ;; debugger level. + (with-simple-restart + (abort "~@") + (catch 'toplevel-catcher + (sb!unix::reset-signal-mask) + ;; In the event of a control-stack-exhausted-error, we + ;; should have unwound enough stack by the time we get + ;; here that this is now possible. + (sb!kernel::protect-control-stack-guard-page 1) + (funcall repl-fun noprint) + (critically-unreachable "after REPL")))))))))) ;;; Our default REPL prompt is the minimal traditional one. (defun repl-prompt-fun (stream) @@ -571,39 +571,39 @@ steppers to maintain contextual information.") (defun repl-read-form-fun (in out) (declare (type stream in out) (ignore out)) (let* ((eof-marker (cons nil nil)) - (form (read in nil eof-marker))) + (form (read in nil eof-marker))) (if (eq form eof-marker) - (quit) - form))) + (quit) + form))) (defun repl-fun (noprint) (/show0 "entering REPL") (loop (unwind-protect - (progn - ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.) - (scrub-control-stack) - (sb!thread::get-foreground) - (unless noprint - (funcall *repl-prompt-fun* *standard-output*) - ;; (Should *REPL-PROMPT-FUN* be responsible for doing its own - ;; FORCE-OUTPUT? I can't imagine a valid reason for it not to - ;; be done here, so leaving it up to *REPL-PROMPT-FUN* seems - ;; odd. But maybe there *is* a valid reason in some - ;; circumstances? perhaps some deadlock issue when being driven - ;; by another process or something...) - (force-output *standard-output*)) - (let* ((form (funcall *repl-read-form-fun* - *standard-input* - *standard-output*)) - (results (multiple-value-list (interactive-eval form)))) - (unless noprint - (dolist (result results) - (fresh-line) - (prin1 result))))) + (progn + ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.) + (scrub-control-stack) + (sb!thread::get-foreground) + (unless noprint + (funcall *repl-prompt-fun* *standard-output*) + ;; (Should *REPL-PROMPT-FUN* be responsible for doing its own + ;; FORCE-OUTPUT? I can't imagine a valid reason for it not to + ;; be done here, so leaving it up to *REPL-PROMPT-FUN* seems + ;; odd. But maybe there *is* a valid reason in some + ;; circumstances? perhaps some deadlock issue when being driven + ;; by another process or something...) + (force-output *standard-output*)) + (let* ((form (funcall *repl-read-form-fun* + *standard-input* + *standard-output*)) + (results (multiple-value-list (interactive-eval form)))) + (unless noprint + (dolist (result results) + (fresh-line) + (prin1 result))))) ;; If we started stepping in the debugger we want to stop now. (setf *stepping* nil - *step* nil)))) + *step* nil)))) ;;; a convenient way to get into the assembly-level debugger (defun %halt () diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index fcd4706..509eebf 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -31,10 +31,10 @@ ;;; also used in EQ comparisons to determined if two types have the ;;; "same kind". (def!struct (type-class - #-no-ansi-print-object - (:print-object (lambda (x stream) - (print-unreadable-object (x stream :type t) - (prin1 (type-class-name x) stream))))) + #-no-ansi-print-object + (:print-object (lambda (x stream) + (print-unreadable-object (x stream :type t) + (prin1 (type-class-name x) stream))))) ;; the name of this type class (used to resolve references at load time) (name nil :type symbol) ; FIXME: should perhaps be (MISSING-ARG) default? ;; Dyadic type methods. If the classes of the two types are EQ, then @@ -60,7 +60,7 @@ ;; be done by just stuffing the two component types into an ;; UNION-TYPE or INTERSECTION-TYPE object. They return NIL on ;; failure, or a CTYPE for success. - ;; + ;; ;; Note: These methods are similar to CMU CL's SIMPLE-UNION, ;; COMPLEX-UNION, SIMPLE-INTERSECTION, and COMPLEX-UNION methods. ;; They were reworked in SBCL because SBCL has INTERSECTION-TYPE @@ -102,7 +102,7 @@ ;; supplying both. (unary-typep nil :type (or symbol null)) (typep nil :type (or symbol null)) - ;; These are like TYPEP and UNARY-TYPEP except they coerce objects to + ;; These are like TYPEP and UNARY-TYPEP except they coerce objects to ;; the type. (unary-coerce nil :type (or symbol null)) (coerce :type (or symbol null)) @@ -155,11 +155,11 @@ ;; reflected in *TYPE-CLASS-FUN-SLOTS*, the slots here will ;; have to be hand-tweaked to match. -- WHN 2001-03-19 (make-type-class :name (type-class-name x) - . #.(mapcan (lambda (type-class-fun-slot) - (destructuring-bind (keyword . slot-accessor) - type-class-fun-slot - `(,keyword (,slot-accessor x)))) - *type-class-fun-slots*))) + . #.(mapcan (lambda (type-class-fun-slot) + (destructuring-bind (keyword . slot-accessor) + type-class-fun-slot + `(,keyword (,slot-accessor x)))) + *type-class-fun-slots*))) (defun class-fun-slot-or-lose (name) (or (cdr (assoc name *type-class-fun-slots*)) @@ -171,29 +171,29 @@ ) ; EVAL-WHEN (defmacro !define-type-method ((class method &rest more-methods) - lambda-list &body body) + lambda-list &body body) (let ((name (symbolicate class "-" method "-TYPE-METHOD"))) `(progn (defun ,name ,lambda-list - ,@body) + ,@body) (!cold-init-forms - ,@(mapcar (lambda (method) - `(setf (,(class-fun-slot-or-lose method) - (type-class-or-lose ',class)) - #',name)) - (cons method more-methods))) + ,@(mapcar (lambda (method) + `(setf (,(class-fun-slot-or-lose method) + (type-class-or-lose ',class)) + #',name)) + (cons method more-methods))) ',name))) (defmacro !define-type-class (name &key inherits) `(!cold-init-forms ,(once-only ((n-class (if inherits - `(copy-type-class-coldly (type-class-or-lose - ',inherits)) - '(make-type-class)))) - `(progn - (setf (type-class-name ,n-class) ',name) - (setf (gethash ',name *type-classes*) ,n-class) - ',name)))) + `(copy-type-class-coldly (type-class-or-lose + ',inherits)) + '(make-type-class)))) + `(progn + (setf (type-class-name ,n-class) ',name) + (setf (gethash ',name *type-classes*) ,n-class) + ',name)))) ;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the ;;; same class, invoke the simple method. Otherwise, invoke any @@ -209,22 +209,22 @@ ;;; suspect is hard, so we'll bear with the old system for the time ;;; being. -- WHN 2001-03-11 (defmacro !invoke-type-method (simple complex-arg2 type1 type2 &key - (default '(values nil t)) - (complex-arg1 :foo complex-arg1-p)) + (default '(values nil t)) + (complex-arg1 :foo complex-arg1-p)) (declare (type keyword simple complex-arg1 complex-arg2)) `(multiple-value-bind (result-a result-b valid-p) (%invoke-type-method ',(class-fun-slot-or-lose simple) - ',(class-fun-slot-or-lose - (if complex-arg1-p - complex-arg1 - complex-arg2)) - ',(class-fun-slot-or-lose complex-arg2) - ,complex-arg1-p - ,type1 - ,type2) + ',(class-fun-slot-or-lose + (if complex-arg1-p + complex-arg1 + complex-arg2)) + ',(class-fun-slot-or-lose complex-arg2) + ,complex-arg1-p + ,type1 + ,type2) (if valid-p - (values result-a result-b) - ,default))) + (values result-a result-b) + ,default))) ;;; most of the implementation of !INVOKE-TYPE-METHOD ;;; @@ -241,23 +241,23 @@ (declare (type symbol simple cslot1 cslot2)) (multiple-value-bind (result-a result-b) (let ((class1 (type-class-info type1)) - (class2 (type-class-info type2))) - (if (eq class1 class2) - (funcall (the function (funcall simple class1)) type1 type2) - (let ((complex2 (funcall cslot2 class2))) + (class2 (type-class-info type2))) + (if (eq class1 class2) + (funcall (the function (funcall simple class1)) type1 type2) + (let ((complex2 (funcall cslot2 class2))) (declare (type (or function null) complex2)) - (if complex2 - (funcall complex2 type1 type2) - (let ((complex1 (funcall cslot1 class1))) + (if complex2 + (funcall complex2 type1 type2) + (let ((complex1 (funcall cslot1 class1))) (declare (type (or function null) complex1)) - (if complex1 - (if complex-arg1-p - (funcall complex1 type1 type2) - (funcall complex1 type2 type1)) - ;; No meaningful result was found: the caller - ;; should use the default value instead. - (return-from %invoke-type-method - (values nil nil nil)))))))) + (if complex1 + (if complex-arg1-p + (funcall complex1 type1 type2) + (funcall complex1 type2 type1)) + ;; No meaningful result was found: the caller + ;; should use the default value instead. + (return-from %invoke-type-method + (values nil nil nil)))))))) ;; If we get to here (without breaking out by calling RETURN-FROM) ;; then a meaningful result was found, and we return it. (values result-a result-b t))) @@ -284,19 +284,19 @@ ;;; (We miss CLOS! -- CSR and WHN) (defun invoke-complex-subtypep-arg1-method (type1 type2 &optional subtypep win) (let* ((type-class (type-class-info type1)) - (method-fun (type-class-complex-subtypep-arg1 type-class))) + (method-fun (type-class-complex-subtypep-arg1 type-class))) (if method-fun - (funcall (the function method-fun) type1 type2) - (values subtypep win)))) + (funcall (the function method-fun) type1 type2) + (values subtypep win)))) ;;; KLUDGE: This function is dangerous, as its overuse could easily ;;; cause stack exhaustion through unbounded recursion. We only use ;;; it in one place; maybe it ought not to be a function at all? (defun invoke-complex-=-other-method (type1 type2) (let* ((type-class (type-class-info type1)) - (method-fun (type-class-complex-= type-class))) + (method-fun (type-class-complex-= type-class))) (if method-fun - (funcall (the function method-fun) type2 type1) - (values nil t)))) + (funcall (the function method-fun) type2 type1) + (values nil t)))) (!defun-from-collected-cold-init-forms !type-class-cold-init) diff --git a/src/code/type-init.lisp b/src/code/type-init.lisp index 9f40927..064d452 100644 --- a/src/code/type-init.lisp +++ b/src/code/type-init.lisp @@ -20,10 +20,10 @@ ;;; numeric types (/show0 "precomputing numeric types") (precompute-types '((mod 2) (mod 4) (mod 16) (mod #x100) (mod #x10000) - (mod #x100000000) - (unsigned-byte 1) (unsigned-byte 2) (unsigned-byte 4) - (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) - (signed-byte 8) (signed-byte 16) (signed-byte 32))) + (mod #x100000000) + (unsigned-byte 1) (unsigned-byte 2) (unsigned-byte 4) + (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) + (signed-byte 8) (signed-byte 16) (signed-byte 32))) ;;; built-in symbol type specifiers (/show0 "precomputing built-in symbol type specifiers") diff --git a/src/code/typecheckfuns.lisp b/src/code/typecheckfuns.lisp index e4a0d8b..b602f64 100644 --- a/src/code/typecheckfuns.lisp +++ b/src/code/typecheckfuns.lisp @@ -3,7 +3,7 @@ ;;;; unreasonable to implement them all as different compiled ;;;; functions, because that's too much bloat. But when they are ;;;; called, it's unreasonable to just punt to interpreted TYPEP, -;;;; because that's unreasonably slow. The system implemented here +;;;; because that's unreasonably slow. The system implemented here ;;;; tries to be a reasonable compromise solution to this problem. ;;;; ;;;; Structure accessor functions are still implemented as closures, @@ -39,60 +39,60 @@ (eval-when (:compile-toplevel) (defvar *compile-time-common-typespecs* (let (;; When we generate collections of common specialized - ;; array types, what should their element types be? - (common-element-typespecs - ;; Note: This table is pretty arbitrary, just things I use a lot - ;; or see used a lot. If someone has ideas for better values, - ;; lemme know. -- WHN 2001-10-15 - #(t - character - bit fixnum (unsigned-byte 32) (signed-byte 32) - single-float double-float))) + ;; array types, what should their element types be? + (common-element-typespecs + ;; Note: This table is pretty arbitrary, just things I use a lot + ;; or see used a lot. If someone has ideas for better values, + ;; lemme know. -- WHN 2001-10-15 + #(t + character + bit fixnum (unsigned-byte 32) (signed-byte 32) + single-float double-float))) (coerce (remove-duplicates - (mapcar (lambda (typespec) - (type-specifier (specifier-type typespec))) - ;; Note: This collection of input values is - ;; pretty arbitrary, just inspired by things I - ;; use a lot or see being used a lot in the - ;; system. If someone has ideas for better - ;; values, lemme know. -- WHN 2001-10-15 - (concatenate - 'list - ;; non-array types - '(bit - boolean - character - cons - double-float - fixnum - hash-table - index - integer - list - package - signed-byte - (signed-byte 8) - single-float - structure-object - symbol - unsigned-byte - (unsigned-byte 8) - (unsigned-byte 32)) - ;; systematic names for array types - (map 'list - (lambda (element-type) - `(simple-array ,element-type 1)) - common-element-typespecs) - (map 'list - (lambda (element-type) - `(vector ,element-type)) - common-element-typespecs) - ;; idiosyncratic names for array types - '(simple-vector - bit-vector simple-bit-vector - string simple-string))) - :test #'equal) - 'simple-vector)))) + (mapcar (lambda (typespec) + (type-specifier (specifier-type typespec))) + ;; Note: This collection of input values is + ;; pretty arbitrary, just inspired by things I + ;; use a lot or see being used a lot in the + ;; system. If someone has ideas for better + ;; values, lemme know. -- WHN 2001-10-15 + (concatenate + 'list + ;; non-array types + '(bit + boolean + character + cons + double-float + fixnum + hash-table + index + integer + list + package + signed-byte + (signed-byte 8) + single-float + structure-object + symbol + unsigned-byte + (unsigned-byte 8) + (unsigned-byte 32)) + ;; systematic names for array types + (map 'list + (lambda (element-type) + `(simple-array ,element-type 1)) + common-element-typespecs) + (map 'list + (lambda (element-type) + `(vector ,element-type)) + common-element-typespecs) + ;; idiosyncratic names for array types + '(simple-vector + bit-vector simple-bit-vector + string simple-string))) + :test #'equal) + 'simple-vector)))) ;;; What are the common testable types? (If a slot accessor looks up ;;; one of these types, it doesn't need to supply a compiled TYPEP @@ -102,13 +102,13 @@ (declaim (type simple-vector *common-typespecs*)) (defvar *common-typespecs*) #-sb-xc (eval-when (:compile-toplevel :load-toplevel :execute) - (setf *common-typespecs* - #.*compile-time-common-typespecs*)) + (setf *common-typespecs* + #.*compile-time-common-typespecs*)) ;; (#+SB-XC initialization is handled elsewhere, at cold init time.) (defun ctype-is-common-typecheckfun-type-p (ctype) (position (type-specifier ctype) *common-typespecs* - :test #'equal)) + :test #'equal)) (defun typecheck-failure (arg typespec) (error 'type-error :datum arg :expected-type typespec)) @@ -125,8 +125,8 @@ (with-unique-names (n-typespec) `(let ((,n-typespec ,typespec)) (or (gethash ,n-typespec *typecheckfuns*) - (setf (gethash ,n-typespec *typecheckfuns*) - ,form))))) + (setf (gethash ,n-typespec *typecheckfuns*) + ,form))))) #+sb-xc (defun !typecheckfuns-cold-init () @@ -137,15 +137,15 @@ ;; Initialize *TYPECHECKFUNS* with typecheckfuns for common typespecs. (/show0 "typecheckfuns-cold-init initial setfs done") (macrolet ((macro () - `(progn - ,@(map 'list - (lambda (typespec) - `(progn + `(progn + ,@(map 'list + (lambda (typespec) + `(progn (/show0 "setf") (setf (gethash ',typespec *typecheckfuns*) (progn (/show0 "lambda") - (lambda (arg) + (lambda (arg) (unless (typep arg ',typespec) (typecheck-failure arg ',typespec)) (values)))))) @@ -157,7 +157,7 @@ ;;; implementation of a function which checks the type of its argument. (defun interpreted-typecheckfun (typespec) ;; Note that we don't and shouldn't memoize this, since otherwise the - ;; user could do + ;; user could do ;; (DEFSTRUCT FOO (X NIL :TYPE XYTYPE)) ;; (DEFTYPE XYTYPE () (OR SYMBOL CHARACTER)) ;; (DEFSTRUCT BAR (Y NIL :TYPE XYTYPE)) @@ -177,11 +177,11 @@ (let ((layout (compiler-layout-or-lose typespec))) (lambda (arg) (unless (typep-to-layout arg layout) - (typecheck-failure arg typespec)) + (typecheck-failure arg typespec)) (values)))) (defun structure-object-typecheckfun (typespec) (memoized-typecheckfun-form (%structure-object-typecheckfun typespec) - typespec)) + typespec)) ;;; General type checks need the full compiler, not just stereotyped ;;; closures. We arrange for UNMEMOIZED-TYPECHECKFUN to be produced @@ -200,11 +200,11 @@ ;; Until then this toy version should be good enough for some testing. (warn "FIXME: This is just a toy stub CTYPE-NEEDS-TO-BE-INTERPRETED-P.") (not (or (position (type-specifier ctype) - *common-typespecs* - :test #'equal) - (member-type-p ctype) - (numeric-type-p ctype) - (array-type-p ctype) + *common-typespecs* + :test #'equal) + (member-type-p ctype) + (numeric-type-p ctype) + (array-type-p ctype) (cons-type-p ctype) (intersection-type-p ctype) (union-type-p ctype) @@ -227,36 +227,36 @@ ;;; well be able to avoid interpreting it at runtime. (define-compiler-macro typespec-typecheckfun (&whole whole typespec-form) (if (and (consp typespec-form) - (eql (first typespec-form) 'quote)) + (eql (first typespec-form) 'quote)) (let* ((typespec (second typespec-form)) - (ctype (specifier-type typespec))) - (aver (= 2 (length typespec-form))) - (cond ((structure-classoid-p ctype) - `(structure-object-typecheckfun ,typespec-form)) - ((ctype-needs-to-be-interpreted-p ctype) - whole) ; i.e. give up compiler macro - (t - `(let ((typespec ,typespec-form)) - (general-typecheckfun - typespec - ;; Unless we know that the function is already in the - ;; memoization cache - ,@(unless (ctype-is-common-typecheckfun-type-p ctype) - ;; Note that we're arranging for the - ;; UNMEMOIZED-TYPECHECKFUN argument value to be - ;; constructed at compile time. This means the - ;; compiler does the work of compiling the function, - ;; and the loader does the work of loading the - ;; function, regardless of whether the runtime check - ;; for "is it in the memoization cache?" succeeds. - ;; (Then if the memoization check succeeds, the - ;; compiled and loaded function is eventually GCed.) - ;; The wasted motion in the case of a successful - ;; memoization check is unfortunate, but it avoids - ;; having to invoke the compiler at load time when - ;; memoization fails, which is probably more - ;; important. - `((lambda (arg) - (unless (typep arg typespec) - (typecheck-failure arg typespec)))))))))) + (ctype (specifier-type typespec))) + (aver (= 2 (length typespec-form))) + (cond ((structure-classoid-p ctype) + `(structure-object-typecheckfun ,typespec-form)) + ((ctype-needs-to-be-interpreted-p ctype) + whole) ; i.e. give up compiler macro + (t + `(let ((typespec ,typespec-form)) + (general-typecheckfun + typespec + ;; Unless we know that the function is already in the + ;; memoization cache + ,@(unless (ctype-is-common-typecheckfun-type-p ctype) + ;; Note that we're arranging for the + ;; UNMEMOIZED-TYPECHECKFUN argument value to be + ;; constructed at compile time. This means the + ;; compiler does the work of compiling the function, + ;; and the loader does the work of loading the + ;; function, regardless of whether the runtime check + ;; for "is it in the memoization cache?" succeeds. + ;; (Then if the memoization check succeeds, the + ;; compiled and loaded function is eventually GCed.) + ;; The wasted motion in the case of a successful + ;; memoization check is unfortunate, but it avoids + ;; having to invoke the compiler at load time when + ;; memoization fails, which is probably more + ;; important. + `((lambda (arg) + (unless (typep arg typespec) + (typecheck-failure arg typespec)))))))))) whole)) ; i.e. give up compiler macro diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index 98c3980..2aca4c3 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -41,29 +41,29 @@ ;; package!) (multiple-value-bind (whole wholeless-arglist) (if (eq '&whole (car arglist)) - (values (cadr arglist) (cddr arglist)) - (values (gensym) arglist)) + (values (cadr arglist) (cddr arglist)) + (values (gensym) arglist)) (multiple-value-bind (forms decls) - (parse-body body :doc-string-allowed nil) + (parse-body body :doc-string-allowed nil) `(progn - (!cold-init-forms - (setf (info :type :translator ',name) - (lambda (,whole) - (block ,name - (destructuring-bind ,wholeless-arglist - (rest ,whole) ; discarding NAME - ,@decls - ,@forms))))) - ',name)))) + (!cold-init-forms + (setf (info :type :translator ',name) + (lambda (,whole) + (block ,name + (destructuring-bind ,wholeless-arglist + (rest ,whole) ; discarding NAME + ,@decls + ,@forms))))) + ',name)))) ;;; DEFVARs for these come later, after we have enough stuff defined. (declaim (special *wild-type* *universal-type* *empty-type*)) ;;; the base class for the internal representation of types (def!struct (ctype (:conc-name type-) - (:constructor nil) - (:make-load-form-fun make-type-load-form) - #-sb-xc-host (:pure t)) + (:constructor nil) + (:make-load-form-fun make-type-load-form) + #-sb-xc-host (:pure t)) ;; the class of this type ;; ;; FIXME: It's unnecessarily confusing to have a structure accessor @@ -78,8 +78,8 @@ ;; an arbitrary hash code used in EQ-style hashing of identity ;; (since EQ hashing can't be done portably) (hash-value (random #.(ash 1 15)) - :type (and fixnum unsigned-byte) - :read-only t) + :type (and fixnum unsigned-byte) + :read-only t) ;; Can this object contain other types? A global property of our ;; implementation (which unfortunately seems impossible to enforce ;; with assertions or other in-the-code checks and constraints) is @@ -107,13 +107,13 @@ (multiple-value-bind (subtypep1 win1) (csubtypep type1 type2) (multiple-value-bind (subtypep2 win2) (csubtypep type2 type1) (cond (subtypep1 type1) - (subtypep2 type2) - ((and win1 win2) *empty-type*) - (t nil))))) + (subtypep2 type2) + ((and win1 win2) *empty-type*) + (t nil))))) (defun hierarchical-union2 (type1 type2) (cond ((csubtypep type1 type2) type2) - ((csubtypep type2 type1) type1) - (t nil))) + ((csubtypep type2 type1) type1) + (t nil))) ;;; Hash two things (types) down to 8 bits. In CMU CL this was an EQ ;;; hash, but since it now needs to run in vanilla ANSI Common Lisp at @@ -127,8 +127,8 @@ (declaim (ftype (function (ctype ctype) (unsigned-byte 8)) type-cache-hash)) (defun type-cache-hash (type1 type2) (logand (logxor (ash (type-hash-value type1) -3) - (type-hash-value type2)) - #xFF)) + (type-hash-value type2)) + #xFF)) #!-sb-fluid (declaim (inline type-list-cache-hash)) (declaim (ftype (function (list) (unsigned-byte 8)) type-list-cache-hash)) (defun type-list-cache-hash (types) @@ -137,7 +137,7 @@ for hash = (type-hash-value type) do (setq res (logxor res hash)) finally (return res)) - #xFF)) + #xFF)) ;;;; cold loading initializations diff --git a/src/code/typep.lisp b/src/code/typep.lisp index 0df87b1..0844ebf 100644 --- a/src/code/typep.lisp +++ b/src/code/typep.lisp @@ -28,9 +28,9 @@ ;;; function when it can't figure out anything more intelligent to do. (defun %typep (object specifier) (%%typep object - (if (ctype-p specifier) - specifier - (specifier-type specifier)))) + (if (ctype-p specifier) + specifier + (specifier-type specifier)))) (defun %%typep (object type) (declare (type ctype type)) (etypecase type @@ -40,67 +40,67 @@ ((nil) nil))) (numeric-type (and (numberp object) - (let (;; I think this works because of an invariant of the - ;; two components of a COMPLEX are always coerced to - ;; be the same, e.g. (COMPLEX 1.0 3/2) => #C(1.0 1.5). - ;; Dunno why that holds, though -- ANSI? Python - ;; tradition? marsh faerie spirits? -- WHN 2001-10-27 - (num (if (complexp object) - (realpart object) - object))) - (ecase (numeric-type-class type) - (integer (integerp num)) - (rational (rationalp num)) - (float - (ecase (numeric-type-format type) - (short-float (typep num 'short-float)) - (single-float (typep num 'single-float)) - (double-float (typep num 'double-float)) - (long-float (typep num 'long-float)) - ((nil) (floatp num)))) - ((nil) t))) - (flet ((bound-test (val) - (let ((low (numeric-type-low type)) - (high (numeric-type-high type))) - (and (cond ((null low) t) - ((listp low) (> val (car low))) - (t (>= val low))) - (cond ((null high) t) - ((listp high) (< val (car high))) - (t (<= val high))))))) - (ecase (numeric-type-complexp type) - ((nil) t) - (:complex - (and (complexp object) - (bound-test (realpart object)) - (bound-test (imagpart object)))) - (:real - (and (not (complexp object)) - (bound-test object))))))) + (let (;; I think this works because of an invariant of the + ;; two components of a COMPLEX are always coerced to + ;; be the same, e.g. (COMPLEX 1.0 3/2) => #C(1.0 1.5). + ;; Dunno why that holds, though -- ANSI? Python + ;; tradition? marsh faerie spirits? -- WHN 2001-10-27 + (num (if (complexp object) + (realpart object) + object))) + (ecase (numeric-type-class type) + (integer (integerp num)) + (rational (rationalp num)) + (float + (ecase (numeric-type-format type) + (short-float (typep num 'short-float)) + (single-float (typep num 'single-float)) + (double-float (typep num 'double-float)) + (long-float (typep num 'long-float)) + ((nil) (floatp num)))) + ((nil) t))) + (flet ((bound-test (val) + (let ((low (numeric-type-low type)) + (high (numeric-type-high type))) + (and (cond ((null low) t) + ((listp low) (> val (car low))) + (t (>= val low))) + (cond ((null high) t) + ((listp high) (< val (car high))) + (t (<= val high))))))) + (ecase (numeric-type-complexp type) + ((nil) t) + (:complex + (and (complexp object) + (bound-test (realpart object)) + (bound-test (imagpart object)))) + (:real + (and (not (complexp object)) + (bound-test object))))))) (array-type (and (arrayp object) - (ecase (array-type-complexp type) - ((t) (not (typep object 'simple-array))) - ((nil) (typep object 'simple-array)) - ((:maybe) t)) - (or (eq (array-type-dimensions type) '*) - (do ((want (array-type-dimensions type) (cdr want)) - (got (array-dimensions object) (cdr got))) - ((and (null want) (null got)) t) - (unless (and want got - (or (eq (car want) '*) - (= (car want) (car got)))) - (return nil)))) - (if (unknown-type-p (array-type-element-type type)) - ;; better to fail this way than to get bogosities like - ;; (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T - (error "~@" - (type-specifier type)) - t) - (or (eq (array-type-element-type type) *wild-type*) - (values (type= (array-type-specialized-element-type type) - (specifier-type (array-element-type - object))))))) + (ecase (array-type-complexp type) + ((t) (not (typep object 'simple-array))) + ((nil) (typep object 'simple-array)) + ((:maybe) t)) + (or (eq (array-type-dimensions type) '*) + (do ((want (array-type-dimensions type) (cdr want)) + (got (array-dimensions object) (cdr got))) + ((and (null want) (null got)) t) + (unless (and want got + (or (eq (car want) '*) + (= (car want) (car got)))) + (return nil)))) + (if (unknown-type-p (array-type-element-type type)) + ;; better to fail this way than to get bogosities like + ;; (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T + (error "~@" + (type-specifier type)) + t) + (or (eq (array-type-element-type type) *wild-type*) + (values (type= (array-type-specialized-element-type type) + (specifier-type (array-element-type + object))))))) (member-type (if (member object (member-type-members type)) t)) (classoid @@ -108,15 +108,15 @@ #-sb-xc-host (classoid-typep (layout-of object) type object)) (union-type (some (lambda (union-type-type) (%%typep object union-type-type)) - (union-type-types type))) + (union-type-types type))) (intersection-type (every (lambda (intersection-type-type) - (%%typep object intersection-type-type)) - (intersection-type-types type))) + (%%typep object intersection-type-type)) + (intersection-type-types type))) (cons-type (and (consp object) - (%%typep (car object) (cons-type-car-type type)) - (%%typep (cdr object) (cons-type-cdr-type type)))) + (%%typep (car object) (cons-type-car-type type)) + (%%typep (cdr object) (cons-type-cdr-type type)))) (character-set-type (and (characterp object) (let ((code (char-code object)) @@ -131,36 +131,36 @@ ;; Parse it again to make sure it's really undefined. (let ((reparse (specifier-type (unknown-type-specifier type)))) (if (typep reparse 'unknown-type) - (error "unknown type specifier: ~S" - (unknown-type-specifier reparse)) - (%%typep object reparse)))) + (error "unknown type specifier: ~S" + (unknown-type-specifier reparse)) + (%%typep object reparse)))) (negation-type (not (%%typep object (negation-type-type type)))) (hairy-type ;; Now the tricky stuff. (let* ((hairy-spec (hairy-type-specifier type)) - (symbol (car hairy-spec))) + (symbol (car hairy-spec))) (ecase symbol - (and - (every (lambda (spec) (%%typep object (specifier-type spec))) - (rest hairy-spec))) - ;; Note: it should be safe to skip OR here, because union - ;; types can always be represented as UNION-TYPE in general - ;; or other CTYPEs in special cases; we never need to use - ;; HAIRY-TYPE for them. - (not - (unless (proper-list-of-length-p hairy-spec 2) - (error "invalid type specifier: ~S" hairy-spec)) - (not (%%typep object (specifier-type (cadr hairy-spec))))) - (satisfies - (unless (proper-list-of-length-p hairy-spec 2) - (error "invalid type specifier: ~S" hairy-spec)) - (values (funcall (symbol-function (cadr hairy-spec)) object)))))) + (and + (every (lambda (spec) (%%typep object (specifier-type spec))) + (rest hairy-spec))) + ;; Note: it should be safe to skip OR here, because union + ;; types can always be represented as UNION-TYPE in general + ;; or other CTYPEs in special cases; we never need to use + ;; HAIRY-TYPE for them. + (not + (unless (proper-list-of-length-p hairy-spec 2) + (error "invalid type specifier: ~S" hairy-spec)) + (not (%%typep object (specifier-type (cadr hairy-spec))))) + (satisfies + (unless (proper-list-of-length-p hairy-spec 2) + (error "invalid type specifier: ~S" hairy-spec)) + (values (funcall (symbol-function (cadr hairy-spec)) object)))))) (alien-type-type (sb!alien-internals:alien-typep object (alien-type-type-alien-type type))) (fun-type (error "Function types are not a legal argument to TYPEP:~% ~S" - (type-specifier type))))) + (type-specifier type))))) ;;; Do a type test from a class cell, allowing forward reference and ;;; redefinition. @@ -168,7 +168,7 @@ (let ((classoid (classoid-cell-classoid cell))) (unless classoid (error "The class ~S has not yet been defined." - (classoid-cell-name cell))) + (classoid-cell-name cell))) (classoid-typep obj-layout classoid object))) ;;; Test whether OBJ-LAYOUT is from an instance of CLASSOID. @@ -176,17 +176,17 @@ (declare (optimize speed)) (when (layout-invalid obj-layout) (if (and (typep (classoid-of object) 'standard-classoid) object) - (setq obj-layout (sb!pcl::check-wrapper-validity object)) - (error "TYPEP was called on an obsolete object (was class ~S)." - (classoid-proper-name (layout-classoid obj-layout))))) + (setq obj-layout (sb!pcl::check-wrapper-validity object)) + (error "TYPEP was called on an obsolete object (was class ~S)." + (classoid-proper-name (layout-classoid obj-layout))))) (let ((layout (classoid-layout classoid)) - (obj-inherits (layout-inherits obj-layout))) + (obj-inherits (layout-inherits obj-layout))) (when (layout-invalid layout) (error "The class ~S is currently invalid." classoid)) (or (eq obj-layout layout) - (dotimes (i (length obj-inherits) nil) - (when (eq (svref obj-inherits i) layout) - (return t)))))) + (dotimes (i (length obj-inherits) nil) + (when (eq (svref obj-inherits i) layout) + (return t)))))) ;;; This implementation is a placeholder to use until PCL is set up, ;;; at which time it will be overwritten by a real implementation. diff --git a/src/code/uncross.lisp b/src/code/uncross.lisp index bfb3c81..cabbc06 100644 --- a/src/code/uncross.lisp +++ b/src/code/uncross.lisp @@ -30,11 +30,11 @@ (define-condition uncross-rcr-failure (style-warning) ((form :initarg :form :reader uncross-rcr-failure-form)) (:report (lambda (c s) - (format s - "UNCROSS couldn't recurse through ~S~%~ - (which is OK as long as there are no SB-XC symbols ~ - down there)" - (uncross-rcr-failure-form c))))) + (format s + "UNCROSS couldn't recurse through ~S~%~ + (which is OK as long as there are no SB-XC symbols ~ + down there)" + (uncross-rcr-failure-form c))))) |# ;;; When cross-compiling, EVAL-WHEN :COMPILE-TOPLEVEL code is executed @@ -66,58 +66,58 @@ (defun uncross (form) (labels ((uncross-symbol (symbol) (let ((old-symbol-package (symbol-package symbol))) - (if (and old-symbol-package - (string= (package-name old-symbol-package) "SB-XC")) - (values (intern (symbol-name symbol) "COMMON-LISP")) - symbol))) - (rcr (form) ; recursive part - (cond ((symbolp form) - (uncross-symbol form)) - ((or (numberp form) - (characterp form) - (stringp form)) - form) - (t - ;; If we reach here, FORM is something with - ;; internal structure which could include - ;; symbols in the SB-XC package. - (when (gethash form inside?) - (let ((*print-circle* t)) - ;; This code could probably be generalized - ;; to work on circular structure, but it - ;; seems easier just to avoid putting any - ;; circular structure into the bootstrap - ;; code. - (error "circular structure in ~S" form))) - (setf (gethash form inside?) t) - (unwind-protect - (typecase form - (cons (rcr-cons form)) - (t - ;; KLUDGE: There are other types - ;; (especially (ARRAY T) and - ;; STRUCTURE-OBJECT, but also HASH-TABLE - ;; and perhaps others) which could hold - ;; symbols. In principle we should handle - ;; those types as well. Failing that, we - ;; could give warnings for them. However, - ;; the current system works for - ;; bootstrapping in practice (because we - ;; don't use those constructs that way) - ;; and the warnings more annoying than - ;; useful, so I simply turned the - ;; warnings off. -- WHN 20001105 - #+nil (warn 'uncross-rcr-failure :form form) - form)) - (remhash form inside?))))) - (rcr-cons (form) - (declare (type cons form)) - (let* ((car (car form)) - (rcr-car (rcr car)) - (cdr (cdr form)) - (rcr-cdr (rcr cdr))) - (if (and (eq rcr-car car) (eq rcr-cdr cdr)) - form - (cons rcr-car rcr-cdr))))) + (if (and old-symbol-package + (string= (package-name old-symbol-package) "SB-XC")) + (values (intern (symbol-name symbol) "COMMON-LISP")) + symbol))) + (rcr (form) ; recursive part + (cond ((symbolp form) + (uncross-symbol form)) + ((or (numberp form) + (characterp form) + (stringp form)) + form) + (t + ;; If we reach here, FORM is something with + ;; internal structure which could include + ;; symbols in the SB-XC package. + (when (gethash form inside?) + (let ((*print-circle* t)) + ;; This code could probably be generalized + ;; to work on circular structure, but it + ;; seems easier just to avoid putting any + ;; circular structure into the bootstrap + ;; code. + (error "circular structure in ~S" form))) + (setf (gethash form inside?) t) + (unwind-protect + (typecase form + (cons (rcr-cons form)) + (t + ;; KLUDGE: There are other types + ;; (especially (ARRAY T) and + ;; STRUCTURE-OBJECT, but also HASH-TABLE + ;; and perhaps others) which could hold + ;; symbols. In principle we should handle + ;; those types as well. Failing that, we + ;; could give warnings for them. However, + ;; the current system works for + ;; bootstrapping in practice (because we + ;; don't use those constructs that way) + ;; and the warnings more annoying than + ;; useful, so I simply turned the + ;; warnings off. -- WHN 20001105 + #+nil (warn 'uncross-rcr-failure :form form) + form)) + (remhash form inside?))))) + (rcr-cons (form) + (declare (type cons form)) + (let* ((car (car form)) + (rcr-car (rcr car)) + (cdr (cdr form)) + (rcr-cdr (rcr cdr))) + (if (and (eq rcr-car car) (eq rcr-cdr cdr)) + form + (cons rcr-car rcr-cdr))))) (clrhash inside?) (rcr form)))) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index c5e6ee1..95f8fb1 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -29,8 +29,8 @@ (defmacro def-enum (inc cur &rest names) (flet ((defform (name) - (prog1 (when name `(defconstant ,name ,cur)) - (setf cur (funcall inc cur 1))))) + (prog1 (when name `(defconstant ,name ,cur)) + (setf cur (funcall inc cur 1))))) `(progn ,@(mapcar #'defform names)))) ;;; Given a C-level zero-terminated array of C strings, return a @@ -41,9 +41,9 @@ (dotimes (i most-positive-fixnum (error "argh! can't happen")) (declare (type index i)) (let ((c-string (deref c-strings i))) - (if c-string + (if c-string (push c-string reversed-result) - (return (nreverse reversed-result))))))) + (return (nreverse reversed-result))))))) ;;;; Lisp types used by syscalls @@ -67,10 +67,10 @@ `(locally (declare (optimize (sb!c::float-accuracy 0))) (let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) - ,@args))) + ,@args))) (if (minusp result) - (values nil (get-errno)) - ,success-form)))) + (values nil (get-errno)) + ,success-form)))) ;;; This is like SYSCALL, but if it fails, signal an error instead of ;;; returning error codes. Should only be used for syscalls that will @@ -79,10 +79,10 @@ `(locally (declare (optimize (sb!c::float-accuracy 0))) (let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) - ,@args))) + ,@args))) (if (minusp result) - (error "Syscall ~A failed: ~A" ,name (strerror)) - ,success-form)))) + (error "Syscall ~A failed: ~A" ,name (strerror)) + ,success-form)))) (/show0 "unix.lisp 109") @@ -136,15 +136,15 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (define-alien-type nil (struct fd-set - (fds-bits (array fd-mask #.(/ fd-setsize - sb!vm:n-machine-word-bits))))) + (fds-bits (array fd-mask #.(/ fd-setsize + sb!vm:n-machine-word-bits))))) (/show0 "unix.lisp 304") ;;;; fcntl.h ;;;; -;;;; POSIX Standard: 6.5 File Control Operations +;;;; POSIX Standard: 6.5 File Control Operations ;;; Open the file whose pathname is specified by PATH for reading ;;; and/or writing as specified by the FLAGS argument. Various FLAGS @@ -155,8 +155,8 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; file descriptor is returned by UNIX-OPEN. (defun unix-open (path flags mode) (declare (type unix-pathname path) - (type fixnum flags) - (type unix-file-mode mode)) + (type fixnum flags) + (type unix-file-mode mode)) (int-syscall ("open" c-string int int) path flags mode)) ;;; UNIX-CLOSE accepts a file descriptor and attempts to close the file @@ -172,8 +172,8 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;; microsecond but also has a range of years. (define-alien-type nil (struct timeval - (tv-sec time-t) ; seconds - (tv-usec time-t))) ; and microseconds + (tv-sec time-t) ; seconds + (tv-usec time-t))) ; and microseconds ;;;; resourcebits.h @@ -183,22 +183,22 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (define-alien-type nil (struct rusage - (ru-utime (struct timeval)) ; user time used - (ru-stime (struct timeval)) ; system time used. - (ru-maxrss long) ; maximum resident set size (in kilobytes) - (ru-ixrss long) ; integral shared memory size - (ru-idrss long) ; integral unshared data size - (ru-isrss long) ; integral unshared stack size - (ru-minflt long) ; page reclaims - (ru-majflt long) ; page faults - (ru-nswap long) ; swaps - (ru-inblock long) ; block input operations - (ru-oublock long) ; block output operations - (ru-msgsnd long) ; messages sent - (ru-msgrcv long) ; messages received - (ru-nsignals long) ; signals received - (ru-nvcsw long) ; voluntary context switches - (ru-nivcsw long))) ; involuntary context switches + (ru-utime (struct timeval)) ; user time used + (ru-stime (struct timeval)) ; system time used. + (ru-maxrss long) ; maximum resident set size (in kilobytes) + (ru-ixrss long) ; integral shared memory size + (ru-idrss long) ; integral unshared data size + (ru-isrss long) ; integral unshared stack size + (ru-minflt long) ; page reclaims + (ru-majflt long) ; page faults + (ru-nswap long) ; swaps + (ru-inblock long) ; block input operations + (ru-oublock long) ; block output operations + (ru-msgsnd long) ; messages sent + (ru-msgrcv long) ; messages received + (ru-nsignals long) ; signals received + (ru-nvcsw long) ; voluntary context switches + (ru-nivcsw long))) ; involuntary context switches ;;;; unistd.h @@ -206,7 +206,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; return T if the file is accessible with that mode and NIL if not. ;;; When NIL, also return an errno value with NIL which tells why the ;;; file was not accessible. -;;; +;;; ;;; The access modes are: ;;; r_ok Read permission. ;;; w_ok Write permission. @@ -214,7 +214,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; f_ok Presence of file. (defun unix-access (path mode) (declare (type unix-pathname path) - (type (mod 8) mode)) + (type (mod 8) mode)) (void-syscall ("access" c-string int) path mode)) ;;; values for the second argument to UNIX-LSEEK @@ -228,7 +228,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (int-syscall ("isatty" int) fd)) (defun unix-lseek (fd offset whence) - "Unix-lseek accepts a file descriptor and moves the file pointer by + "Unix-lseek accepts a file descriptor and moves the file pointer by OFFSET octets. Whence can be any of the following: L_SET Set the file pointer. @@ -236,11 +236,11 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." L_XTND Extend the file size. " (declare (type unix-fd fd) - (type (integer 0 2) whence)) + (type (integer 0 2) whence)) (let ((result (alien-funcall (extern-alien "lseek" (function off-t int off-t int)) - fd offset whence))) + fd offset whence))) (if (minusp result ) - (values nil (get-errno)) + (values nil (get-errno)) (values result 0)))) ;;; UNIX-READ accepts a file descriptor, a buffer, and the length to read. @@ -249,7 +249,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; bytes read. (defun unix-read (fd buf len) (declare (type unix-fd fd) - (type (unsigned-byte 32) len)) + (type (unsigned-byte 32) len)) (int-syscall ("read" int (* char) int) fd buf len)) @@ -259,16 +259,16 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; the actual number of bytes written. (defun unix-write (fd buf offset len) (declare (type unix-fd fd) - (type (unsigned-byte 32) offset len)) + (type (unsigned-byte 32) offset len)) (int-syscall ("write" int (* char) int) - fd - (with-alien ((ptr (* char) (etypecase buf - ((simple-array * (*)) - (vector-sap buf)) - (system-area-pointer - buf)))) - (addr (deref ptr offset))) - len)) + fd + (with-alien ((ptr (* char) (etypecase buf + ((simple-array * (*)) + (vector-sap buf)) + (system-area-pointer + buf)))) + (addr (deref ptr offset))) + len)) ;;; Set up a unix-piping mechanism consisting of an input pipe and an ;;; output pipe. Return two values: if no error occurred the first @@ -278,12 +278,12 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (defun unix-pipe () (with-alien ((fds (array int 2))) (syscall ("pipe" (* int)) - (values (deref fds 0) (deref fds 1)) - (cast fds (* int))))) + (values (deref fds 0) (deref fds 1)) + (cast fds (* int))))) (defun unix-mkdir (name mode) (declare (type unix-pathname name) - (type unix-file-mode mode)) + (type unix-file-mode mode)) (void-syscall ("mkdir" c-string int) name mode)) ;;; Given a C char* pointer allocated by malloc(), free it and return a @@ -293,11 +293,11 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (if (null-alien newcharstar) nil (prog1 - (cast newcharstar c-string) - (free-alien newcharstar)))) + (cast newcharstar c-string) + (free-alien newcharstar)))) ;;; Return the Unix current directory as a SIMPLE-STRING, in the -;;; style returned by getcwd() (no trailing slash character). +;;; style returned by getcwd() (no trailing slash character). (defun posix-getcwd () ;; This implementation relies on a BSD/Linux extension to getcwd() ;; behavior, automatically allocating memory when a null buffer @@ -314,12 +314,12 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." #!-(or linux openbsd freebsd netbsd sunos osf1 darwin) (,stub,) #!+(or linux openbsd freebsd netbsd sunos osf1 darwin) (or (newcharstar-string (alien-funcall (extern-alien "getcwd" - (function (* char) - (* char) - size-t)) - nil - #!+(or linux openbsd freebsd netbsd darwin) 0 - #!+(or sunos osf1) 1025)) + (function (* char) + (* char) + size-t)) + nil + #!+(or linux openbsd freebsd netbsd darwin) 0 + #!+(or sunos osf1) 1025)) (simple-perror "getcwd"))) ;;; Return the Unix current directory as a SIMPLE-STRING terminated @@ -366,16 +366,16 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; Translate a user id into a login name. (defun uid-username (uid) (or (newcharstar-string (alien-funcall (extern-alien "uid_username" - (function (* char) int)) - uid)) + (function (* char) int)) + uid)) (error "found no match for Unix uid=~S" uid))) ;;; Return the namestring of the home directory, being careful to ;;; include a trailing #\/ (defun uid-homedir (uid) (or (newcharstar-string (alien-funcall (extern-alien "uid_homedir" - (function (* char) int)) - uid)) + (function (* char) int)) + uid)) (error "failed to resolve home directory for Unix uid=~S" uid))) ;;; Invoke readlink(2) on the file name specified by PATH. Return @@ -384,19 +384,19 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (defun unix-readlink (path) (declare (type unix-pathname path)) (with-alien ((ptr (* char) - (alien-funcall (extern-alien - "wrapped_readlink" - (function (* char) c-string)) - path))) + (alien-funcall (extern-alien + "wrapped_readlink" + (function (* char) c-string)) + path))) (if (null-alien ptr) - (values nil (get-errno)) - (multiple-value-prog1 - (values (with-alien ((c-string c-string ptr)) c-string) - nil) - (free-alien ptr))))) + (values nil (get-errno)) + (multiple-value-prog1 + (values (with-alien ((c-string c-string ptr)) c-string) + nil) + (free-alien ptr))))) ;;; UNIX-UNLINK accepts a name and deletes the directory entry for that -;;; name and the file if this is the last link. +;;; name and the file if this is the last link. (defun unix-unlink (name) (declare (type unix-pathname name)) (void-syscall ("unlink" c-string) name)) @@ -405,8 +405,8 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (defun unix-gethostname () (with-alien ((buf (array char 256))) (syscall ("gethostname" (* char) int) - (cast buf c-string) - (cast buf (* char)) 256))) + (cast buf c-string) + (cast buf (* char)) 256))) (defun unix-setsid () (int-syscall ("setsid"))) @@ -418,7 +418,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; information. (defun unix-ioctl (fd cmd arg) (declare (type unix-fd fd) - (type (signed-byte 32) cmd)) + (type (signed-byte 32) cmd)) (void-syscall ("ioctl" int int (* char)) fd cmd arg)) ;;;; sys/resource.h @@ -431,16 +431,16 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." #!-sb-fluid (declaim (inline unix-fast-getrusage)) (defun unix-fast-getrusage (who) (declare (values (member t) - (unsigned-byte 31) (integer 0 1000000) - (unsigned-byte 31) (integer 0 1000000))) + (unsigned-byte 31) (integer 0 1000000) + (unsigned-byte 31) (integer 0 1000000))) (with-alien ((usage (struct rusage))) (syscall* ("getrusage" int (* (struct rusage))) - (values t - (slot (slot usage 'ru-utime) 'tv-sec) - (slot (slot usage 'ru-utime) 'tv-usec) - (slot (slot usage 'ru-stime) 'tv-sec) - (slot (slot usage 'ru-stime) 'tv-usec)) - who (addr usage)))) + (values t + (slot (slot usage 'ru-utime) 'tv-sec) + (slot (slot usage 'ru-utime) 'tv-usec) + (slot (slot usage 'ru-stime) 'tv-sec) + (slot (slot usage 'ru-stime) 'tv-usec)) + who (addr usage)))) ;;; Return information about the resource usage of the process ;;; specified by WHO. WHO can be either the current process @@ -450,26 +450,26 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (defun unix-getrusage (who) (with-alien ((usage (struct rusage))) (syscall ("getrusage" int (* (struct rusage))) - (values t - (+ (* (slot (slot usage 'ru-utime) 'tv-sec) 1000000) - (slot (slot usage 'ru-utime) 'tv-usec)) - (+ (* (slot (slot usage 'ru-stime) 'tv-sec) 1000000) - (slot (slot usage 'ru-stime) 'tv-usec)) - (slot usage 'ru-maxrss) - (slot usage 'ru-ixrss) - (slot usage 'ru-idrss) - (slot usage 'ru-isrss) - (slot usage 'ru-minflt) - (slot usage 'ru-majflt) - (slot usage 'ru-nswap) - (slot usage 'ru-inblock) - (slot usage 'ru-oublock) - (slot usage 'ru-msgsnd) - (slot usage 'ru-msgrcv) - (slot usage 'ru-nsignals) - (slot usage 'ru-nvcsw) - (slot usage 'ru-nivcsw)) - who (addr usage)))) + (values t + (+ (* (slot (slot usage 'ru-utime) 'tv-sec) 1000000) + (slot (slot usage 'ru-utime) 'tv-usec)) + (+ (* (slot (slot usage 'ru-stime) 'tv-sec) 1000000) + (slot (slot usage 'ru-stime) 'tv-usec)) + (slot usage 'ru-maxrss) + (slot usage 'ru-ixrss) + (slot usage 'ru-idrss) + (slot usage 'ru-isrss) + (slot usage 'ru-minflt) + (slot usage 'ru-majflt) + (slot usage 'ru-nswap) + (slot usage 'ru-inblock) + (slot usage 'ru-oublock) + (slot usage 'ru-msgsnd) + (slot usage 'ru-msgrcv) + (slot usage 'ru-nsignals) + (slot usage 'ru-nvcsw) + (slot usage 'ru-nivcsw)) + who (addr usage)))) ;;;; sys/select.h @@ -478,13 +478,13 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; Perform the UNIX select(2) system call. (declaim (inline unix-fast-select)) ; (used to be a macro in CMU CL) (defun unix-fast-select (num-descriptors - read-fds write-fds exception-fds - timeout-secs &optional (timeout-usecs 0)) + read-fds write-fds exception-fds + timeout-secs &optional (timeout-usecs 0)) (declare (type (integer 0 #.fd-setsize) num-descriptors) - (type (or (alien (* (struct fd-set))) null) - read-fds write-fds exception-fds) - (type (or null (unsigned-byte 31)) timeout-secs) - (type (unsigned-byte 31) timeout-usecs)) + (type (or (alien (* (struct fd-set))) null) + read-fds write-fds exception-fds) + (type (or null (unsigned-byte 31)) timeout-secs) + (type (unsigned-byte 31) timeout-usecs)) ;; FIXME: CMU CL had ;; (declare (optimize (speed 3) (safety 0) (inhibit-warnings 3))) ;; here. Is that important for SBCL? If so, why? Profiling might tell us.. @@ -493,48 +493,48 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (setf (slot tv 'tv-sec) timeout-secs) (setf (slot tv 'tv-usec) timeout-usecs)) (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set)) - (* (struct fd-set)) (* (struct timeval))) - num-descriptors read-fds write-fds exception-fds - (if timeout-secs (alien-sap (addr tv)) (int-sap 0))))) + (* (struct fd-set)) (* (struct timeval))) + num-descriptors read-fds write-fds exception-fds + (if timeout-secs (alien-sap (addr tv)) (int-sap 0))))) ;;; UNIX-SELECT accepts sets of file descriptors and waits for an event ;;; to happen on one of them or to time out. (defmacro num-to-fd-set (fdset num) `(if (fixnump ,num) (progn - (setf (deref (slot ,fdset 'fds-bits) 0) ,num) - ,@(loop for index upfrom 1 below (/ fd-setsize - sb!vm:n-machine-word-bits) - collect `(setf (deref (slot ,fdset 'fds-bits) ,index) 0))) + (setf (deref (slot ,fdset 'fds-bits) 0) ,num) + ,@(loop for index upfrom 1 below (/ fd-setsize + sb!vm:n-machine-word-bits) + collect `(setf (deref (slot ,fdset 'fds-bits) ,index) 0))) (progn - ,@(loop for index upfrom 0 below (/ fd-setsize - sb!vm:n-machine-word-bits) - collect `(setf (deref (slot ,fdset 'fds-bits) ,index) - (ldb (byte sb!vm:n-machine-word-bits - ,(* index sb!vm:n-machine-word-bits)) - ,num)))))) + ,@(loop for index upfrom 0 below (/ fd-setsize + sb!vm:n-machine-word-bits) + collect `(setf (deref (slot ,fdset 'fds-bits) ,index) + (ldb (byte sb!vm:n-machine-word-bits + ,(* index sb!vm:n-machine-word-bits)) + ,num)))))) (defmacro fd-set-to-num (nfds fdset) `(if (<= ,nfds sb!vm:n-machine-word-bits) (deref (slot ,fdset 'fds-bits) 0) (+ ,@(loop for index upfrom 0 below (/ fd-setsize - sb!vm:n-machine-word-bits) - collect `(ash (deref (slot ,fdset 'fds-bits) ,index) - ,(* index sb!vm:n-machine-word-bits)))))) + sb!vm:n-machine-word-bits) + collect `(ash (deref (slot ,fdset 'fds-bits) ,index) + ,(* index sb!vm:n-machine-word-bits)))))) ;;; Examine the sets of descriptors passed as arguments to see whether ;;; they are ready for reading and writing. See the UNIX Programmer's ;;; Manual for more information. (defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0)) (declare (type (integer 0 #.fd-setsize) nfds) - (type unsigned-byte rdfds wrfds xpfds) - (type (or (unsigned-byte 31) null) to-secs) - (type (unsigned-byte 31) to-usecs) - (optimize (speed 3) (safety 0) (inhibit-warnings 3))) + (type unsigned-byte rdfds wrfds xpfds) + (type (or (unsigned-byte 31) null) to-secs) + (type (unsigned-byte 31) to-usecs) + (optimize (speed 3) (safety 0) (inhibit-warnings 3))) (with-alien ((tv (struct timeval)) - (rdf (struct fd-set)) - (wrf (struct fd-set)) - (xpf (struct fd-set))) + (rdf (struct fd-set)) + (wrf (struct fd-set)) + (xpf (struct fd-set))) (when to-secs (setf (slot tv 'tv-sec) to-secs) (setf (slot tv 'tv-usec) to-usecs)) @@ -542,17 +542,17 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (num-to-fd-set wrf wrfds) (num-to-fd-set xpf xpfds) (macrolet ((frob (lispvar alienvar) - `(if (zerop ,lispvar) - (int-sap 0) - (alien-sap (addr ,alienvar))))) + `(if (zerop ,lispvar) + (int-sap 0) + (alien-sap (addr ,alienvar))))) (syscall ("select" int (* (struct fd-set)) (* (struct fd-set)) - (* (struct fd-set)) (* (struct timeval))) - (values result - (fd-set-to-num nfds rdf) - (fd-set-to-num nfds wrf) - (fd-set-to-num nfds xpf)) - nfds (frob rdfds rdf) (frob wrfds wrf) (frob xpfds xpf) - (if to-secs (alien-sap (addr tv)) (int-sap 0)))))) + (* (struct fd-set)) (* (struct timeval))) + (values result + (fd-set-to-num nfds rdf) + (fd-set-to-num nfds wrf) + (fd-set-to-num nfds xpf)) + nfds (frob rdfds rdf) (frob wrfds wrf) (frob xpfds xpf) + (if to-secs (alien-sap (addr tv)) (int-sap 0)))))) ;;;; sys/stat.h @@ -580,7 +580,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (st-uid uid-t) (st-gid gid-t) (st-rdev unsigned-int) ; would be dev-t in a real stat - (st-size unsigned-int) ; would be off-t in a real stat + (st-size unsigned-int) ; would be off-t in a real stat (st-blksize unsigned-long) (st-blocks unsigned-long) (st-atime time-t) @@ -603,19 +603,19 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (defun %extract-stat-results (wrapped-stat) (declare (type (alien (* (struct wrapped_stat))) wrapped-stat)) (values t - (slot wrapped-stat 'st-dev) - (slot wrapped-stat 'st-ino) - (slot wrapped-stat 'st-mode) - (slot wrapped-stat 'st-nlink) - (slot wrapped-stat 'st-uid) - (slot wrapped-stat 'st-gid) - (slot wrapped-stat 'st-rdev) - (slot wrapped-stat 'st-size) - (slot wrapped-stat 'st-atime) - (slot wrapped-stat 'st-mtime) - (slot wrapped-stat 'st-ctime) - (slot wrapped-stat 'st-blksize) - (slot wrapped-stat 'st-blocks))) + (slot wrapped-stat 'st-dev) + (slot wrapped-stat 'st-ino) + (slot wrapped-stat 'st-mode) + (slot wrapped-stat 'st-nlink) + (slot wrapped-stat 'st-uid) + (slot wrapped-stat 'st-gid) + (slot wrapped-stat 'st-rdev) + (slot wrapped-stat 'st-size) + (slot wrapped-stat 'st-atime) + (slot wrapped-stat 'st-mtime) + (slot wrapped-stat 'st-ctime) + (slot wrapped-stat 'st-blksize) + (slot wrapped-stat 'st-blocks))) ;;; Unix system calls in the stat(2) family are handled by calls to ;;; C-level wrapper functions which copy all the raw "struct stat" @@ -627,20 +627,20 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (declare (type unix-pathname name)) (with-alien ((buf (struct wrapped_stat))) (syscall ("stat_wrapper" c-string (* (struct wrapped_stat))) - (%extract-stat-results (addr buf)) - name (addr buf)))) + (%extract-stat-results (addr buf)) + name (addr buf)))) (defun unix-lstat (name) (declare (type unix-pathname name)) (with-alien ((buf (struct wrapped_stat))) (syscall ("lstat_wrapper" c-string (* (struct wrapped_stat))) - (%extract-stat-results (addr buf)) - name (addr buf)))) + (%extract-stat-results (addr buf)) + name (addr buf)))) (defun unix-fstat (fd) (declare (type unix-fd fd)) (with-alien ((buf (struct wrapped_stat))) (syscall ("fstat_wrapper" int (* (struct wrapped_stat))) - (%extract-stat-results (addr buf)) - fd (addr buf)))) + (%extract-stat-results (addr buf)) + fd (addr buf)))) ;;;; time.h @@ -648,23 +648,23 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;; timeval" but has nanoseconds instead of microseconds. (define-alien-type nil (struct timespec - (tv-sec long) ; seconds - (tv-nsec long))) ; nanoseconds + (tv-sec long) ; seconds + (tv-nsec long))) ; nanoseconds ;; used by other time functions (define-alien-type nil (struct tm - (tm-sec int) ; Seconds. [0-60] (1 leap second) - (tm-min int) ; Minutes. [0-59] - (tm-hour int) ; Hours. [0-23] - (tm-mday int) ; Day. [1-31] - (tm-mon int) ; Month. [0-11] - (tm-year int) ; Year - 1900. - (tm-wday int) ; Day of week. [0-6] - (tm-yday int) ; Days in year. [0-365] - (tm-isdst int) ; DST. [-1/0/1] - (tm-gmtoff long) ; Seconds east of UTC. - (tm-zone c-string))) ; Timezone abbreviation. + (tm-sec int) ; Seconds. [0-60] (1 leap second) + (tm-min int) ; Minutes. [0-59] + (tm-hour int) ; Hours. [0-23] + (tm-mday int) ; Day. [1-31] + (tm-mon int) ; Month. [0-11] + (tm-year int) ; Year - 1900. + (tm-wday int) ; Day of week. [0-6] + (tm-yday int) ; Days in year. [0-365] + (tm-isdst int) ; DST. [-1/0/1] + (tm-gmtoff long) ; Seconds east of UTC. + (tm-zone c-string))) ; Timezone abbreviation. (define-alien-routine get-timezone sb!alien:void (when sb!alien:long :in) @@ -694,8 +694,8 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; obsolete and should never be used. (define-alien-type nil (struct timezone - (tz-minuteswest int) ; minutes west of Greenwich - (tz-dsttime int))) ; type of dst correction + (tz-minuteswest int) ; minutes west of Greenwich + (tz-dsttime int))) ; type of dst correction ;;; If it works, UNIX-GETTIMEOFDAY returns 5 values: T, the seconds ;;; and microseconds of the current time of day, the timezone (in @@ -704,24 +704,24 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." #!-sb-fluid (declaim (inline unix-gettimeofday)) (defun unix-gettimeofday () (with-alien ((tv (struct timeval)) - (tz (struct timezone))) + (tz (struct timezone))) (syscall* ("gettimeofday" (* (struct timeval)) - (* (struct timezone))) - (values t - (slot tv 'tv-sec) - (slot tv 'tv-usec) - (slot tz 'tz-minuteswest) - (slot tz 'tz-dsttime)) - (addr tv) - (addr tz)))) + (* (struct timezone))) + (values t + (slot tv 'tv-sec) + (slot tv 'tv-usec) + (slot tz 'tz-minuteswest) + (slot tz 'tz-dsttime)) + (addr tv) + (addr tz)))) ;; Type of the second argument to `getitimer' and -;; the second and third arguments `setitimer'. +;; the second and third arguments `setitimer'. (define-alien-type nil (struct itimerval - (it-interval (struct timeval)) ; timer interval - (it-value (struct timeval)))) ; current value + (it-interval (struct timeval)) ; timer interval + (it-value (struct timeval)))) ; current value (defconstant itimer-real 0) (defconstant itimer-virtual 1) @@ -733,21 +733,21 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." unix-getitimer returns 5 values, T, it-interval-secs, it-interval-usec, it-value-secs, it-value-usec." (declare (type (member :real :virtual :profile) which) - (values t - (unsigned-byte 29) (mod 1000000) - (unsigned-byte 29) (mod 1000000))) + (values t + (unsigned-byte 29) (mod 1000000) + (unsigned-byte 29) (mod 1000000))) (let ((which (ecase which - (:real itimer-real) - (:virtual itimer-virtual) - (:profile itimer-prof)))) + (:real itimer-real) + (:virtual itimer-virtual) + (:profile itimer-prof)))) (with-alien ((itv (struct itimerval))) (syscall* ("getitimer" int (* (struct itimerval))) - (values t - (slot (slot itv 'it-interval) 'tv-sec) - (slot (slot itv 'it-interval) 'tv-usec) - (slot (slot itv 'it-value) 'tv-sec) - (slot (slot itv 'it-value) 'tv-usec)) - which (alien-sap (addr itv)))))) + (values t + (slot (slot itv 'it-interval) 'tv-sec) + (slot (slot itv 'it-interval) 'tv-usec) + (slot (slot itv 'it-value) 'tv-sec) + (slot (slot itv 'it-value) 'tv-usec)) + which (alien-sap (addr itv)))))) (defun unix-setitimer (which int-secs int-usec val-secs val-usec) " Unix-setitimer sets the INTERVAL and VALUE slots of one of @@ -759,28 +759,28 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." unix-setitimer returns the old contents of the INTERVAL and VALUE slots as in unix-getitimer." (declare (type (member :real :virtual :profile) which) - (type (unsigned-byte 29) int-secs val-secs) - (type (integer 0 (1000000)) int-usec val-usec) - (values t - (unsigned-byte 29) (mod 1000000) - (unsigned-byte 29) (mod 1000000))) + (type (unsigned-byte 29) int-secs val-secs) + (type (integer 0 (1000000)) int-usec val-usec) + (values t + (unsigned-byte 29) (mod 1000000) + (unsigned-byte 29) (mod 1000000))) (let ((which (ecase which - (:real itimer-real) - (:virtual itimer-virtual) - (:profile itimer-prof)))) + (:real itimer-real) + (:virtual itimer-virtual) + (:profile itimer-prof)))) (with-alien ((itvn (struct itimerval)) - (itvo (struct itimerval))) + (itvo (struct itimerval))) (setf (slot (slot itvn 'it-interval) 'tv-sec ) int-secs - (slot (slot itvn 'it-interval) 'tv-usec) int-usec - (slot (slot itvn 'it-value ) 'tv-sec ) val-secs - (slot (slot itvn 'it-value ) 'tv-usec) val-usec) + (slot (slot itvn 'it-interval) 'tv-usec) int-usec + (slot (slot itvn 'it-value ) 'tv-sec ) val-secs + (slot (slot itvn 'it-value ) 'tv-usec) val-usec) (syscall* ("setitimer" int (* (struct timeval))(* (struct timeval))) - (values t - (slot (slot itvo 'it-interval) 'tv-sec) - (slot (slot itvo 'it-interval) 'tv-usec) - (slot (slot itvo 'it-value) 'tv-sec) - (slot (slot itvo 'it-value) 'tv-usec)) - which (alien-sap (addr itvn))(alien-sap (addr itvo)))))) + (values t + (slot (slot itvo 'it-interval) 'tv-sec) + (slot (slot itvo 'it-interval) 'tv-usec) + (slot (slot itvo 'it-value) 'tv-sec) + (slot (slot itvo 'it-value) 'tv-usec)) + which (alien-sap (addr itvn))(alien-sap (addr itvo)))))) (defmacro sb!ext:with-timeout (expires &body body) "Execute the body, interrupting it with a SIGALRM after at least @@ -789,21 +789,21 @@ previous timer after the body has finished executing" (with-unique-names (saved-seconds saved-useconds s u) `(let (- ,saved-seconds ,saved-useconds) (multiple-value-setq (- - - ,saved-seconds ,saved-useconds) - (unix-getitimer :real)) + (unix-getitimer :real)) (multiple-value-bind (,s ,u) (floor ,expires) - (setf ,u (floor (* ,u 1000000))) - (if (and (> ,expires 0) - (or (and (zerop ,saved-seconds) (zerop ,saved-useconds)) - (> ,saved-seconds ,s) - (and (= ,saved-seconds ,s) - (> ,saved-useconds ,u)))) - (unwind-protect - (progn - (unix-setitimer :real 0 0 ,s ,u) - ,@body) - (unix-setitimer :real 0 0 ,saved-seconds ,saved-useconds)) - (progn - ,@body)))))) + (setf ,u (floor (* ,u 1000000))) + (if (and (> ,expires 0) + (or (and (zerop ,saved-seconds) (zerop ,saved-useconds)) + (> ,saved-seconds ,s) + (and (= ,saved-seconds ,s) + (> ,saved-useconds ,u)))) + (unwind-protect + (progn + (unix-setitimer :real 0 0 ,s ,u) + ,@body) + (unix-setitimer :real 0 0 ,saved-seconds ,saved-useconds)) + (progn + ,@body)))))) ;;; FIXME: Many Unix error code definitions were deleted from the old ;;; CMU CL source code here, but not in the exports of SB-UNIX. I @@ -821,13 +821,13 @@ previous timer after the body has finished executing" (multiple-value-bind (res dev ino mode) (if check-for-links (unix-lstat name) (unix-stat name)) (declare (type (or fixnum null) mode) - (ignore dev ino)) + (ignore dev ino)) (when res (let ((kind (logand mode s-ifmt))) - (cond ((eql kind s-ifdir) :directory) - ((eql kind s-ifreg) :file) - ((eql kind s-iflnk) :link) - (t :special)))))) + (cond ((eql kind s-ifdir) :directory) + ((eql kind s-ifreg) :file) + ((eql kind s-iflnk) :link) + (t :special)))))) ;;; Is the Unix pathname PATHNAME relative, instead of absolute? (E.g. ;;; "passwd" or "etc/passwd" instead of "/etc/passwd"?) @@ -854,126 +854,126 @@ previous timer after the body has finished executing" (loop with previous-pathnames = nil do (/noshow pathname previous-pathnames) (let ((link (unix-readlink pathname))) - (/noshow link) - ;; Unlike the old CMU CL code, we handle a broken symlink by - ;; returning the link itself. That way, CL:TRUENAME on a - ;; broken link returns the link itself, so that CL:DIRECTORY - ;; can return broken links, so that even without - ;; Unix-specific extensions to do interesting things with - ;; them, at least Lisp programs can see them and, if - ;; necessary, delete them. (This is handy e.g. when your - ;; managed-by-Lisp directories are visited by Emacs, which - ;; creates broken links as notes to itself.) - (if (null link) - (return pathname) - (let ((new-pathname - (unix-simplify-pathname - (if (relative-unix-pathname? link) - (let* ((dir-len (1+ (position #\/ - pathname - :from-end t))) - (dir (subseq pathname 0 dir-len))) - (/noshow dir) - (concatenate 'base-string dir link)) - link)))) - (if (unix-file-kind new-pathname) - (setf pathname new-pathname) - (return pathname))))) - ;; To generalize the principle that even if portable Lisp code - ;; can't do anything interesting with a broken symlink, at - ;; least it should be able to see and delete it, when we - ;; detect a cyclic link, we return the link itself. (So even - ;; though portable Lisp code can't do anything interesting - ;; with a cyclic link, at least it can see it and delete it.) - (if (member pathname previous-pathnames :test #'string=) - (return pathname) - (push pathname previous-pathnames)))) + (/noshow link) + ;; Unlike the old CMU CL code, we handle a broken symlink by + ;; returning the link itself. That way, CL:TRUENAME on a + ;; broken link returns the link itself, so that CL:DIRECTORY + ;; can return broken links, so that even without + ;; Unix-specific extensions to do interesting things with + ;; them, at least Lisp programs can see them and, if + ;; necessary, delete them. (This is handy e.g. when your + ;; managed-by-Lisp directories are visited by Emacs, which + ;; creates broken links as notes to itself.) + (if (null link) + (return pathname) + (let ((new-pathname + (unix-simplify-pathname + (if (relative-unix-pathname? link) + (let* ((dir-len (1+ (position #\/ + pathname + :from-end t))) + (dir (subseq pathname 0 dir-len))) + (/noshow dir) + (concatenate 'base-string dir link)) + link)))) + (if (unix-file-kind new-pathname) + (setf pathname new-pathname) + (return pathname))))) + ;; To generalize the principle that even if portable Lisp code + ;; can't do anything interesting with a broken symlink, at + ;; least it should be able to see and delete it, when we + ;; detect a cyclic link, we return the link itself. (So even + ;; though portable Lisp code can't do anything interesting + ;; with a cyclic link, at least it can see it and delete it.) + (if (member pathname previous-pathnames :test #'string=) + (return pathname) + (push pathname previous-pathnames)))) (defun unix-simplify-pathname (src) (declare (type simple-base-string src)) (let* ((src-len (length src)) - (dst (make-string src-len :element-type 'base-char)) - (dst-len 0) - (dots 0) - (last-slash nil)) + (dst (make-string src-len :element-type 'base-char)) + (dst-len 0) + (dots 0) + (last-slash nil)) (macrolet ((deposit (char) - `(progn - (setf (schar dst dst-len) ,char) - (incf dst-len)))) + `(progn + (setf (schar dst dst-len) ,char) + (incf dst-len)))) (dotimes (src-index src-len) - (let ((char (schar src src-index))) - (cond ((char= char #\.) - (when dots - (incf dots)) - (deposit char)) - ((char= char #\/) - (case dots - (0 - ;; either ``/...' or ``...//...' - (unless last-slash - (setf last-slash dst-len) - (deposit char))) - (1 - ;; either ``./...'' or ``..././...'' - (decf dst-len)) - (2 - ;; We've found .. - (cond - ((and last-slash (not (zerop last-slash))) - ;; There is something before this .. - (let ((prev-prev-slash - (position #\/ dst :end last-slash :from-end t))) - (cond ((and (= (+ (or prev-prev-slash 0) 2) - last-slash) - (char= (schar dst (- last-slash 2)) #\.) - (char= (schar dst (1- last-slash)) #\.)) - ;; The something before this .. is another .. - (deposit char) - (setf last-slash dst-len)) - (t - ;; The something is some directory or other. - (setf dst-len - (if prev-prev-slash - (1+ prev-prev-slash) - 0)) - (setf last-slash prev-prev-slash))))) - (t - ;; There is nothing before this .., so we need to keep it - (setf last-slash dst-len) - (deposit char)))) - (t - ;; something other than a dot between slashes - (setf last-slash dst-len) - (deposit char))) - (setf dots 0)) - (t - (setf dots nil) - (setf (schar dst dst-len) char) - (incf dst-len)))))) + (let ((char (schar src src-index))) + (cond ((char= char #\.) + (when dots + (incf dots)) + (deposit char)) + ((char= char #\/) + (case dots + (0 + ;; either ``/...' or ``...//...' + (unless last-slash + (setf last-slash dst-len) + (deposit char))) + (1 + ;; either ``./...'' or ``..././...'' + (decf dst-len)) + (2 + ;; We've found .. + (cond + ((and last-slash (not (zerop last-slash))) + ;; There is something before this .. + (let ((prev-prev-slash + (position #\/ dst :end last-slash :from-end t))) + (cond ((and (= (+ (or prev-prev-slash 0) 2) + last-slash) + (char= (schar dst (- last-slash 2)) #\.) + (char= (schar dst (1- last-slash)) #\.)) + ;; The something before this .. is another .. + (deposit char) + (setf last-slash dst-len)) + (t + ;; The something is some directory or other. + (setf dst-len + (if prev-prev-slash + (1+ prev-prev-slash) + 0)) + (setf last-slash prev-prev-slash))))) + (t + ;; There is nothing before this .., so we need to keep it + (setf last-slash dst-len) + (deposit char)))) + (t + ;; something other than a dot between slashes + (setf last-slash dst-len) + (deposit char))) + (setf dots 0)) + (t + (setf dots nil) + (setf (schar dst dst-len) char) + (incf dst-len)))))) (when (and last-slash (not (zerop last-slash))) (case dots - (1 - ;; We've got ``foobar/.'' - (decf dst-len)) - (2 - ;; We've got ``foobar/..'' - (unless (and (>= last-slash 2) - (char= (schar dst (1- last-slash)) #\.) - (char= (schar dst (- last-slash 2)) #\.) - (or (= last-slash 2) - (char= (schar dst (- last-slash 3)) #\/))) - (let ((prev-prev-slash - (position #\/ dst :end last-slash :from-end t))) - (if prev-prev-slash - (setf dst-len (1+ prev-prev-slash)) - (return-from unix-simplify-pathname - (coerce "./" 'simple-base-string)))))))) + (1 + ;; We've got ``foobar/.'' + (decf dst-len)) + (2 + ;; We've got ``foobar/..'' + (unless (and (>= last-slash 2) + (char= (schar dst (1- last-slash)) #\.) + (char= (schar dst (- last-slash 2)) #\.) + (or (= last-slash 2) + (char= (schar dst (- last-slash 3)) #\/))) + (let ((prev-prev-slash + (position #\/ dst :end last-slash :from-end t))) + (if prev-prev-slash + (setf dst-len (1+ prev-prev-slash)) + (return-from unix-simplify-pathname + (coerce "./" 'simple-base-string)))))))) (cond ((zerop dst-len) - "./") - ((= dst-len src-len) - dst) - (t - (subseq dst 0 dst-len))))) + "./") + ((= dst-len src-len) + dst) + (t + (subseq dst 0 dst-len))))) ;;;; A magic constant for wait3(). ;;;; @@ -993,38 +993,38 @@ previous timer after the body has finished executing" ;;; not checked for linux... (defmacro fd-set (offset fd-set) (let ((word (gensym)) - (bit (gensym))) + (bit (gensym))) `(multiple-value-bind (,word ,bit) (floor ,offset - sb!vm:n-machine-word-bits) + sb!vm:n-machine-word-bits) (setf (deref (slot ,fd-set 'fds-bits) ,word) - (logior (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits) - (ash 1 ,bit)) - (deref (slot ,fd-set 'fds-bits) ,word)))))) + (logior (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits) + (ash 1 ,bit)) + (deref (slot ,fd-set 'fds-bits) ,word)))))) ;;; not checked for linux... (defmacro fd-clr (offset fd-set) (let ((word (gensym)) - (bit (gensym))) + (bit (gensym))) `(multiple-value-bind (,word ,bit) (floor ,offset - sb!vm:n-machine-word-bits) + sb!vm:n-machine-word-bits) (setf (deref (slot ,fd-set 'fds-bits) ,word) - (logand (deref (slot ,fd-set 'fds-bits) ,word) - (sb!kernel:word-logical-not - (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits) - (ash 1 ,bit)))))))) + (logand (deref (slot ,fd-set 'fds-bits) ,word) + (sb!kernel:word-logical-not + (truly-the (unsigned-byte #.sb!vm:n-machine-word-bits) + (ash 1 ,bit)))))))) ;;; not checked for linux... (defmacro fd-isset (offset fd-set) (let ((word (gensym)) - (bit (gensym))) + (bit (gensym))) `(multiple-value-bind (,word ,bit) (floor ,offset - sb!vm:n-machine-word-bits) + sb!vm:n-machine-word-bits) (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word))))) ;;; not checked for linux... (defmacro fd-zero (fd-set) `(progn ,@(loop for index upfrom 0 below (/ fd-setsize sb!vm:n-machine-word-bits) - collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0)))) + collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0)))) diff --git a/src/code/unportable-float.lisp b/src/code/unportable-float.lisp index 9e7abff..e09885f 100644 --- a/src/code/unportable-float.lisp +++ b/src/code/unportable-float.lisp @@ -20,9 +20,9 @@ (declare (notinline opaque-identity make-single-float make-double-float)) (ecase name (:single-float-negative-zero (make-single-float - (opaque-identity #x-80000000))) + (opaque-identity #x-80000000))) (:double-float-negative-zero (make-double-float - (opaque-identity #x-80000000) - (opaque-identity #x00000000))) + (opaque-identity #x-80000000) + (opaque-identity #x00000000))) #!+long-float (:long-float-negative-zero (error "write LONG-FLOAT creation form"))))) diff --git a/src/code/weak.lisp b/src/code/weak.lisp index 7268b38..e5300e1 100644 --- a/src/code/weak.lisp +++ b/src/code/weak.lisp @@ -33,5 +33,5 @@ returns the values NIL and NIL." ;; compiler will never try to reorder them even in code where we ;; neglect to frame them in a LET? (let ((value (sb!c::%weak-pointer-value weak-pointer)) - (broken (sb!c::%weak-pointer-broken weak-pointer))) + (broken (sb!c::%weak-pointer-broken weak-pointer))) (values value (not broken)))) diff --git a/src/code/x86-64-vm.lisp b/src/code/x86-64-vm.lisp index 286c292..6eacf48 100644 --- a/src/code/x86-64-vm.lisp +++ b/src/code/x86-64-vm.lisp @@ -13,7 +13,7 @@ ;;;; OS-CONTEXT-T -;;; a POSIX signal context, i.e. the type passed as the third +;;; a POSIX signal context, i.e. the type passed as the third ;;; argument to an SA_SIGACTION-style signal handler ;;; ;;; The real type does have slots, but at Lisp level, we never @@ -45,17 +45,17 @@ (defun get-machine-version () #!+linux (with-open-file (stream "/proc/cpuinfo" - ;; Even on Linux it's an option to build - ;; kernels without /proc filesystems, so - ;; degrade gracefully. - :if-does-not-exist nil) + ;; Even on Linux it's an option to build + ;; kernels without /proc filesystems, so + ;; degrade gracefully. + :if-does-not-exist nil) (loop with line while (setf line (read-line stream nil)) - ;; The field "model name" exists on kernel 2.4.21-rc6-ac1 - ;; anyway, with values e.g. - ;; "AMD Athlon(TM) XP 2000+" - ;; "Intel(R) Pentium(R) M processor 1300MHz" - ;; which seem comparable to the information in the example - ;; in the MACHINE-VERSION page of the ANSI spec. + ;; The field "model name" exists on kernel 2.4.21-rc6-ac1 + ;; anyway, with values e.g. + ;; "AMD Athlon(TM) XP 2000+" + ;; "Intel(R) Pentium(R) M processor 1300MHz" + ;; which seem comparable to the information in the example + ;; in the MACHINE-VERSION page of the ANSI spec. when (eql (search "model name" line) 0) return (string-trim " " (subseq line (1+ (position #\: line)))))) #!-linux @@ -81,68 +81,68 @@ (defun fixup-code-object (code offset fixup kind) (declare (type index offset)) (flet ((add-fixup (code offset) - ;; (We check for and ignore fixups for code objects in the - ;; read-only and static spaces. (In the old CMU CL code - ;; this check was conditional on *ENABLE-DYNAMIC-SPACE-CODE*, - ;; but in SBCL relocatable dynamic space code is always in - ;; use, so we always do the check.) - (incf *num-fixups*) - (let ((fixups (code-header-ref code code-constants-offset))) - (cond ((typep fixups '(simple-array (unsigned-byte 64) (*))) - (let ((new-fixups - (adjust-fixup-array fixups (1+ (length fixups))))) - (setf (aref new-fixups (length fixups)) offset) - (setf (code-header-ref code code-constants-offset) - new-fixups))) - (t - (unless (or (eq (widetag-of fixups) - unbound-marker-widetag) - (zerop fixups)) - (format t "** Init. code FU = ~S~%" fixups)) ; FIXME - (setf (code-header-ref code code-constants-offset) - (make-array - 1 - :element-type '(unsigned-byte 64) - :initial-element offset))))))) + ;; (We check for and ignore fixups for code objects in the + ;; read-only and static spaces. (In the old CMU CL code + ;; this check was conditional on *ENABLE-DYNAMIC-SPACE-CODE*, + ;; but in SBCL relocatable dynamic space code is always in + ;; use, so we always do the check.) + (incf *num-fixups*) + (let ((fixups (code-header-ref code code-constants-offset))) + (cond ((typep fixups '(simple-array (unsigned-byte 64) (*))) + (let ((new-fixups + (adjust-fixup-array fixups (1+ (length fixups))))) + (setf (aref new-fixups (length fixups)) offset) + (setf (code-header-ref code code-constants-offset) + new-fixups))) + (t + (unless (or (eq (widetag-of fixups) + unbound-marker-widetag) + (zerop fixups)) + (format t "** Init. code FU = ~S~%" fixups)) ; FIXME + (setf (code-header-ref code code-constants-offset) + (make-array + 1 + :element-type '(unsigned-byte 64) + :initial-element offset))))))) (sb!sys:without-gcing (let* ((sap (truly-the system-area-pointer - (sb!kernel:code-instructions code))) - (obj-start-addr (logand (sb!kernel:get-lisp-obj-address code) - #xfffffffffffffff8)) - (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions - code))) - (ncode-words (sb!kernel:code-header-ref code 1)) - (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes)))) + (sb!kernel:code-instructions code))) + (obj-start-addr (logand (sb!kernel:get-lisp-obj-address code) + #xfffffffffffffff8)) + (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions + code))) + (ncode-words (sb!kernel:code-header-ref code 1)) + (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes)))) (unless (member kind '(:absolute :absolute64 :relative)) - (error "Unknown code-object-fixup kind ~S." kind)) + (error "Unknown code-object-fixup kind ~S." kind)) (ecase kind - (:absolute64 - ;; Word at sap + offset contains a value to be replaced by - ;; adding that value to fixup. - (setf (sap-ref-64 sap offset) (+ fixup (sap-ref-64 sap offset))) - ;; Record absolute fixups that point within the code object. - (when (> code-end-addr (sap-ref-64 sap offset) obj-start-addr) - (add-fixup code offset))) - (:absolute - ;; Word at sap + offset contains a value to be replaced by - ;; adding that value to fixup. - (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset))) - ;; Record absolute fixups that point within the code object. - (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr) - (add-fixup code offset))) - (:relative - ;; Fixup is the actual address wanted. - ;; - ;; Record relative fixups that point outside the code - ;; object. - (when (or (< fixup obj-start-addr) (> fixup code-end-addr)) - (add-fixup code offset)) - ;; Replace word with value to add to that loc to get there. - (let* ((loc-sap (+ (sap-int sap) offset)) - (rel-val (- fixup loc-sap (/ n-word-bytes 2)))) - (declare (type (unsigned-byte 64) loc-sap) - (type (signed-byte 32) rel-val)) - (setf (signed-sap-ref-32 sap offset) rel-val)))))) + (:absolute64 + ;; Word at sap + offset contains a value to be replaced by + ;; adding that value to fixup. + (setf (sap-ref-64 sap offset) (+ fixup (sap-ref-64 sap offset))) + ;; Record absolute fixups that point within the code object. + (when (> code-end-addr (sap-ref-64 sap offset) obj-start-addr) + (add-fixup code offset))) + (:absolute + ;; Word at sap + offset contains a value to be replaced by + ;; adding that value to fixup. + (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset))) + ;; Record absolute fixups that point within the code object. + (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr) + (add-fixup code offset))) + (:relative + ;; Fixup is the actual address wanted. + ;; + ;; Record relative fixups that point outside the code + ;; object. + (when (or (< fixup obj-start-addr) (> fixup code-end-addr)) + (add-fixup code offset)) + ;; Replace word with value to add to that loc to get there. + (let* ((loc-sap (+ (sap-int sap) offset)) + (rel-val (- fixup loc-sap (/ n-word-bytes 2)))) + (declare (type (unsigned-byte 64) loc-sap) + (type (signed-byte 32) rel-val)) + (setf (signed-sap-ref-32 sap offset) rel-val)))))) nil)) ;;; Add a code fixup to a code object generated by GENESIS. The fixup @@ -155,42 +155,42 @@ #!+gencgc (defun !envector-load-time-code-fixup (code offset fixup kind) (flet ((frob (code offset) - (let ((fixups (code-header-ref code code-constants-offset))) - (cond ((typep fixups '(simple-array (unsigned-byte 64) (*))) - (let ((new-fixups - (adjust-fixup-array fixups (1+ (length fixups))))) - (setf (aref new-fixups (length fixups)) offset) - (setf (code-header-ref code code-constants-offset) - new-fixups))) - (t - (unless (or (eq (widetag-of fixups) - unbound-marker-widetag) - (zerop fixups)) - (sb!impl::!cold-lose "Argh! can't process fixup")) - (setf (code-header-ref code code-constants-offset) - (make-array - 1 - :element-type '(unsigned-byte 64) - :initial-element offset))))))) + (let ((fixups (code-header-ref code code-constants-offset))) + (cond ((typep fixups '(simple-array (unsigned-byte 64) (*))) + (let ((new-fixups + (adjust-fixup-array fixups (1+ (length fixups))))) + (setf (aref new-fixups (length fixups)) offset) + (setf (code-header-ref code code-constants-offset) + new-fixups))) + (t + (unless (or (eq (widetag-of fixups) + unbound-marker-widetag) + (zerop fixups)) + (sb!impl::!cold-lose "Argh! can't process fixup")) + (setf (code-header-ref code code-constants-offset) + (make-array + 1 + :element-type '(unsigned-byte 64) + :initial-element offset))))))) (let* ((sap (truly-the system-area-pointer - (sb!kernel:code-instructions code))) - (obj-start-addr - ;; FIXME: looks like (LOGANDC2 foo typebits) - (logand (sb!kernel:get-lisp-obj-address code) #xfffffffffffffff8)) - (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions - code))) - (ncode-words (sb!kernel:code-header-ref code 1)) - (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes)))) + (sb!kernel:code-instructions code))) + (obj-start-addr + ;; FIXME: looks like (LOGANDC2 foo typebits) + (logand (sb!kernel:get-lisp-obj-address code) #xfffffffffffffff8)) + (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions + code))) + (ncode-words (sb!kernel:code-header-ref code 1)) + (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes)))) (ecase kind - (:absolute - ;; Record absolute fixups that point within the code object. - ;; The fixup data is 32 bits, don't use SAP-REF-64 here. - (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr) - (frob code offset))) - (:relative - ;; Record relative fixups that point outside the code object. - (when (or (< fixup obj-start-addr) (> fixup code-end-addr)) - (frob code offset))))))) + (:absolute + ;; Record absolute fixups that point within the code object. + ;; The fixup data is 32 bits, don't use SAP-REF-64 here. + (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr) + (frob code offset))) + (:relative + ;; Record relative fixups that point outside the code object. + (when (or (< fixup obj-start-addr) (> fixup code-end-addr)) + (frob code offset))))))) ;;;; low-level signal context access functions ;;;; @@ -293,27 +293,27 @@ (/show0 "got PC") ;; using INT3 the pc is .. INT3 code length bytes... (let* ((length (sap-ref-8 pc 1)) - (vector (make-array length :element-type '(unsigned-byte 8)))) + (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (type (unsigned-byte 8) length) - (type (simple-array (unsigned-byte 8) (*)) vector)) + (type (simple-array (unsigned-byte 8) (*)) vector)) (/show0 "LENGTH,VECTOR,ERROR-NUMBER=..") (/hexstr length) (/hexstr vector) (copy-ub8-from-system-area pc 2 vector 0 length) (let* ((index 0) - (error-number (sb!c:read-var-integer vector index))) - (/hexstr error-number) - (collect ((sc-offsets)) - (loop - (/show0 "INDEX=..") - (/hexstr index) - (when (>= index length) - (return)) - (let ((sc-offset (sb!c:read-var-integer vector index))) - (/show0 "SC-OFFSET=..") - (/hexstr sc-offset) - (sc-offsets sc-offset))) - (values error-number (sc-offsets))))))) + (error-number (sb!c:read-var-integer vector index))) + (/hexstr error-number) + (collect ((sc-offsets)) + (loop + (/show0 "INDEX=..") + (/hexstr index) + (when (>= index length) + (return)) + (let ((sc-offset (sb!c:read-var-integer vector index))) + (/show0 "SC-OFFSET=..") + (/hexstr sc-offset) + (sc-offsets sc-offset))) + (values error-number (sc-offsets))))))) ;;; the current alien stack pointer; saved/restored for non-local exits diff --git a/src/code/x86-vm.lisp b/src/code/x86-vm.lisp index 21fd69c..041007b 100644 --- a/src/code/x86-vm.lisp +++ b/src/code/x86-vm.lisp @@ -13,7 +13,7 @@ ;;;; OS-CONTEXT-T -;;; a POSIX signal context, i.e. the type passed as the third +;;; a POSIX signal context, i.e. the type passed as the third ;;; argument to an SA_SIGACTION-style signal handler ;;; ;;; The real type does have slots, but at Lisp level, we never @@ -45,17 +45,17 @@ (defun get-machine-version () #!+linux (with-open-file (stream "/proc/cpuinfo" - ;; Even on Linux it's an option to build - ;; kernels without /proc filesystems, so - ;; degrade gracefully. - :if-does-not-exist nil) + ;; Even on Linux it's an option to build + ;; kernels without /proc filesystems, so + ;; degrade gracefully. + :if-does-not-exist nil) (loop with line while (setf line (read-line stream nil)) - ;; The field "model name" exists on kernel 2.4.21-rc6-ac1 - ;; anyway, with values e.g. - ;; "AMD Athlon(TM) XP 2000+" - ;; "Intel(R) Pentium(R) M processor 1300MHz" - ;; which seem comparable to the information in the example - ;; in the MACHINE-VERSION page of the ANSI spec. + ;; The field "model name" exists on kernel 2.4.21-rc6-ac1 + ;; anyway, with values e.g. + ;; "AMD Athlon(TM) XP 2000+" + ;; "Intel(R) Pentium(R) M processor 1300MHz" + ;; which seem comparable to the information in the example + ;; in the MACHINE-VERSION page of the ANSI spec. when (eql (search "model name" line) 0) return (string-trim " " (subseq line (1+ (position #\: line)))))) #!-linux @@ -81,63 +81,63 @@ (defun fixup-code-object (code offset fixup kind) (declare (type index offset)) (flet ((add-fixup (code offset) - ;; (We check for and ignore fixups for code objects in the - ;; read-only and static spaces. (In the old CMU CL code - ;; this check was conditional on *ENABLE-DYNAMIC-SPACE-CODE*, - ;; but in SBCL relocatable dynamic space code is always in - ;; use, so we always do the check.) - (incf *num-fixups*) - (let ((fixups (code-header-ref code code-constants-offset))) - (cond ((typep fixups '(simple-array (unsigned-byte 32) (*))) - (let ((new-fixups - (adjust-fixup-array fixups (1+ (length fixups))))) - (setf (aref new-fixups (length fixups)) offset) - (setf (code-header-ref code code-constants-offset) - new-fixups))) - (t - (unless (or (eq (widetag-of fixups) - unbound-marker-widetag) - (zerop fixups)) - (format t "** Init. code FU = ~S~%" fixups)) ; FIXME - (setf (code-header-ref code code-constants-offset) - (make-array - 1 - :element-type '(unsigned-byte 32) - :initial-element offset))))))) + ;; (We check for and ignore fixups for code objects in the + ;; read-only and static spaces. (In the old CMU CL code + ;; this check was conditional on *ENABLE-DYNAMIC-SPACE-CODE*, + ;; but in SBCL relocatable dynamic space code is always in + ;; use, so we always do the check.) + (incf *num-fixups*) + (let ((fixups (code-header-ref code code-constants-offset))) + (cond ((typep fixups '(simple-array (unsigned-byte 32) (*))) + (let ((new-fixups + (adjust-fixup-array fixups (1+ (length fixups))))) + (setf (aref new-fixups (length fixups)) offset) + (setf (code-header-ref code code-constants-offset) + new-fixups))) + (t + (unless (or (eq (widetag-of fixups) + unbound-marker-widetag) + (zerop fixups)) + (format t "** Init. code FU = ~S~%" fixups)) ; FIXME + (setf (code-header-ref code code-constants-offset) + (make-array + 1 + :element-type '(unsigned-byte 32) + :initial-element offset))))))) (sb!sys:without-gcing (let* ((sap (truly-the system-area-pointer - (sb!kernel:code-instructions code))) - (obj-start-addr (logand (sb!kernel:get-lisp-obj-address code) - #xfffffff8)) - ;; FIXME: what is this 5? - #+nil (const-start-addr (+ obj-start-addr (* 5 n-word-bytes))) - (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions - code))) - (ncode-words (sb!kernel:code-header-ref code 1)) - (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes)))) + (sb!kernel:code-instructions code))) + (obj-start-addr (logand (sb!kernel:get-lisp-obj-address code) + #xfffffff8)) + ;; FIXME: what is this 5? + #+nil (const-start-addr (+ obj-start-addr (* 5 n-word-bytes))) + (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions + code))) + (ncode-words (sb!kernel:code-header-ref code 1)) + (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes)))) (unless (member kind '(:absolute :relative)) - (error "Unknown code-object-fixup kind ~S." kind)) + (error "Unknown code-object-fixup kind ~S." kind)) (ecase kind - (:absolute - ;; Word at sap + offset contains a value to be replaced by - ;; adding that value to fixup. - (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset))) - ;; Record absolute fixups that point within the code object. - (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr) - (add-fixup code offset))) - (:relative - ;; Fixup is the actual address wanted. - ;; - ;; Record relative fixups that point outside the code - ;; object. - (when (or (< fixup obj-start-addr) (> fixup code-end-addr)) - (add-fixup code offset)) - ;; Replace word with value to add to that loc to get there. - (let* ((loc-sap (+ (sap-int sap) offset)) - (rel-val (- fixup loc-sap n-word-bytes))) - (declare (type (unsigned-byte 32) loc-sap) - (type (signed-byte 32) rel-val)) - (setf (signed-sap-ref-32 sap offset) rel-val)))))) + (:absolute + ;; Word at sap + offset contains a value to be replaced by + ;; adding that value to fixup. + (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset))) + ;; Record absolute fixups that point within the code object. + (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr) + (add-fixup code offset))) + (:relative + ;; Fixup is the actual address wanted. + ;; + ;; Record relative fixups that point outside the code + ;; object. + (when (or (< fixup obj-start-addr) (> fixup code-end-addr)) + (add-fixup code offset)) + ;; Replace word with value to add to that loc to get there. + (let* ((loc-sap (+ (sap-int sap) offset)) + (rel-val (- fixup loc-sap n-word-bytes))) + (declare (type (unsigned-byte 32) loc-sap) + (type (signed-byte 32) rel-val)) + (setf (signed-sap-ref-32 sap offset) rel-val)))))) nil)) ;;; Add a code fixup to a code object generated by GENESIS. The fixup @@ -150,41 +150,41 @@ #!+gencgc (defun !envector-load-time-code-fixup (code offset fixup kind) (flet ((frob (code offset) - (let ((fixups (code-header-ref code code-constants-offset))) - (cond ((typep fixups '(simple-array (unsigned-byte 32) (*))) - (let ((new-fixups - (adjust-fixup-array fixups (1+ (length fixups))))) - (setf (aref new-fixups (length fixups)) offset) - (setf (code-header-ref code code-constants-offset) - new-fixups))) - (t - (unless (or (eq (widetag-of fixups) - unbound-marker-widetag) - (zerop fixups)) - (sb!impl::!cold-lose "Argh! can't process fixup")) - (setf (code-header-ref code code-constants-offset) - (make-array - 1 - :element-type '(unsigned-byte 32) - :initial-element offset))))))) + (let ((fixups (code-header-ref code code-constants-offset))) + (cond ((typep fixups '(simple-array (unsigned-byte 32) (*))) + (let ((new-fixups + (adjust-fixup-array fixups (1+ (length fixups))))) + (setf (aref new-fixups (length fixups)) offset) + (setf (code-header-ref code code-constants-offset) + new-fixups))) + (t + (unless (or (eq (widetag-of fixups) + unbound-marker-widetag) + (zerop fixups)) + (sb!impl::!cold-lose "Argh! can't process fixup")) + (setf (code-header-ref code code-constants-offset) + (make-array + 1 + :element-type '(unsigned-byte 32) + :initial-element offset))))))) (let* ((sap (truly-the system-area-pointer - (sb!kernel:code-instructions code))) - (obj-start-addr - ;; FIXME: looks like (LOGANDC2 foo typebits) - (logand (sb!kernel:get-lisp-obj-address code) #xfffffff8)) - (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions - code))) - (ncode-words (sb!kernel:code-header-ref code 1)) - (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes)))) + (sb!kernel:code-instructions code))) + (obj-start-addr + ;; FIXME: looks like (LOGANDC2 foo typebits) + (logand (sb!kernel:get-lisp-obj-address code) #xfffffff8)) + (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions + code))) + (ncode-words (sb!kernel:code-header-ref code 1)) + (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes)))) (ecase kind - (:absolute - ;; Record absolute fixups that point within the code object. - (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr) - (frob code offset))) - (:relative - ;; Record relative fixups that point outside the code object. - (when (or (< fixup obj-start-addr) (> fixup code-end-addr)) - (frob code offset))))))) + (:absolute + ;; Record absolute fixups that point within the code object. + (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr) + (frob code offset))) + (:relative + ;; Record relative fixups that point outside the code object. + (when (or (< fixup obj-start-addr) (> fixup code-end-addr)) + (frob code offset))))))) ;;;; low-level signal context access functions ;;;; @@ -267,7 +267,7 @@ ;; old code for Linux: #+nil (let ((cw (slot (deref (slot context 'fpstate) 0) 'cw)) - (sw (slot (deref (slot context 'fpstate) 0) 'sw))) + (sw (slot (deref (slot context 'fpstate) 0) 'sw))) ;;(format t "cw = ~4X~%sw = ~4X~%" cw sw) ;; NOT TESTED -- Clear sticky bits to clear interrupt condition. (setf (slot (deref (slot context 'fpstate) 0) 'sw) (logandc2 sw #x3f)) @@ -295,27 +295,27 @@ (/show0 "got PC") ;; using INT3 the pc is .. INT3 code length bytes... (let* ((length (sap-ref-8 pc 1)) - (vector (make-array length :element-type '(unsigned-byte 8)))) + (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (type (unsigned-byte 8) length) - (type (simple-array (unsigned-byte 8) (*)) vector)) + (type (simple-array (unsigned-byte 8) (*)) vector)) (/show0 "LENGTH,VECTOR,ERROR-NUMBER=..") (/hexstr length) (/hexstr vector) (copy-ub8-from-system-area pc 2 vector 0 length) (let* ((index 0) - (error-number (sb!c:read-var-integer vector index))) - (/hexstr error-number) - (collect ((sc-offsets)) - (loop - (/show0 "INDEX=..") - (/hexstr index) - (when (>= index length) - (return)) - (let ((sc-offset (sb!c:read-var-integer vector index))) - (/show0 "SC-OFFSET=..") - (/hexstr sc-offset) - (sc-offsets sc-offset))) - (values error-number (sc-offsets))))))) + (error-number (sb!c:read-var-integer vector index))) + (/hexstr error-number) + (collect ((sc-offsets)) + (loop + (/show0 "INDEX=..") + (/hexstr index) + (when (>= index length) + (return)) + (let ((sc-offset (sb!c:read-var-integer vector index))) + (/show0 "SC-OFFSET=..") + (/hexstr sc-offset) + (sc-offsets sc-offset))) + (values error-number (sc-offsets))))))) ;;; This is used in error.lisp to insure that floating-point exceptions ;;; are properly trapped. The compiler translates this to a VOP. diff --git a/src/cold/ansify.lisp b/src/cold/ansify.lisp index 25b957c..901286d 100644 --- a/src/cold/ansify.lisp +++ b/src/cold/ansify.lisp @@ -68,7 +68,7 @@ (warn "CMU CL has a broken implementation of READ-SEQUENCE.") (pushnew :no-ansi-read-sequence *features*)) -;;; This is apparently quite old, according to +;;; This is apparently quite old, according to ;;; : ;;; (error "CMUCL on Alpha can't read floats in the format \"1.0l0\". ;;; the warning relates to a random vinary produced from cvs of @@ -84,8 +84,8 @@ ;;;; OpenMCL issues ;;; This issue in OpenMCL led to some SBCL bug reports ca. late 2003. -#+openmcl -(unless (ignore-errors (funcall (constantly t) 1 2 3)) +#+openmcl +(unless (ignore-errors (funcall (constantly t) 1 2 3)) (error "please find a binary that understands CONSTANTLY to build from")) ;;;; general non-ANSI-ness @@ -95,7 +95,7 @@ (defmacro munging-cl-package (&body body) #-clisp `(progn ,@body) #+clisp `(ext:without-package-lock ("CL") - ,@body)) + ,@body)) ;;; Do the exports of COMMON-LISP conform to the standard? If not, try ;;; to make them conform. (Of course, ANSI says that bashing symbols @@ -104,57 +104,57 @@ ;;; we? "One dirty unportable hack deserves another.":-) (let ((standard-ht (make-hash-table :test 'equal)) (host-ht (make-hash-table :test 'equal)) - (cl (find-package "COMMON-LISP"))) + (cl (find-package "COMMON-LISP"))) (do-external-symbols (i cl) (setf (gethash (symbol-name i) host-ht) t)) (dolist (i (read-from-file "common-lisp-exports.lisp-expr")) (setf (gethash i standard-ht) t)) (maphash (lambda (key value) - (declare (ignore value)) - (unless (gethash key standard-ht) - (warn "removing non-ANSI export from package CL: ~S" key) - (munging-cl-package - (unexport (intern key cl) cl)))) - host-ht) + (declare (ignore value)) + (unless (gethash key standard-ht) + (warn "removing non-ANSI export from package CL: ~S" key) + (munging-cl-package + (unexport (intern key cl) cl)))) + host-ht) (maphash (lambda (key value) - (declare (ignore value)) - (unless (gethash key host-ht) - (warn "adding required-by-ANSI export to package CL: ~S" key) - (munging-cl-package - (export (intern key cl) cl))) - - ;; FIXME: My righteous indignation below was misplaced. ANSI sez - ;; (in 11.1.2.1, "The COMMON-LISP Package") that it's OK for - ;; COMMON-LISP things to have their home packages elsewhere. - ;; For now, the hack below works, but it's not good to rely - ;; on this nonstandardness. Ergo, I should fix things so that even - ;; when the cross-compilation host COMMON-LISP package has - ;; symbols with home packages elsewhere, genesis dumps out - ;; the correct stuff. (For each symbol dumped, check whether it's - ;; exported from COMMON-LISP, and if so, dump it as though its - ;; home package is COMMON-LISP regardless of whether it actually - ;; is. I think..) - ;; - ;; X CMU CL, at least the Debian versions ca. 2.4.9 that I'm - ;; X using as I write this, plays a sneaky trick on us by - ;; X putting DEBUG and FLOATING-POINT-INEXACT in the - ;; X EXTENSIONS package, then IMPORTing them into - ;; X COMMON-LISP, then reEXPORTing them from COMMON-LISP. - ;; X This leaves their home packages bogusly set to - ;; X EXTENSIONS, which confuses genesis into thinking that - ;; X the CMU CL EXTENSIONS package has to be dumped into the - ;; X target SBCL. (perhaps a last-ditch survival strategy - ;; X for the CMU CL "nooo! don't bootstrap from scratch!" - ;; X meme?) As far as I can see, there's no even slightly - ;; X portable way to undo the damage, so we'll play the "one - ;; X dirty unportable hack deserves another" game, only even - ;; X dirtierly and more unportably than before.. - #+cmu - (let ((symbol (intern key cl))) - (unless (eq (symbol-package symbol) cl) - (warn "using low-level hack to move ~S from ~S to ~S" - symbol - (symbol-package symbol) - cl) - (kernel:%set-symbol-package symbol cl)))) - standard-ht)) + (declare (ignore value)) + (unless (gethash key host-ht) + (warn "adding required-by-ANSI export to package CL: ~S" key) + (munging-cl-package + (export (intern key cl) cl))) + + ;; FIXME: My righteous indignation below was misplaced. ANSI sez + ;; (in 11.1.2.1, "The COMMON-LISP Package") that it's OK for + ;; COMMON-LISP things to have their home packages elsewhere. + ;; For now, the hack below works, but it's not good to rely + ;; on this nonstandardness. Ergo, I should fix things so that even + ;; when the cross-compilation host COMMON-LISP package has + ;; symbols with home packages elsewhere, genesis dumps out + ;; the correct stuff. (For each symbol dumped, check whether it's + ;; exported from COMMON-LISP, and if so, dump it as though its + ;; home package is COMMON-LISP regardless of whether it actually + ;; is. I think..) + ;; + ;; X CMU CL, at least the Debian versions ca. 2.4.9 that I'm + ;; X using as I write this, plays a sneaky trick on us by + ;; X putting DEBUG and FLOATING-POINT-INEXACT in the + ;; X EXTENSIONS package, then IMPORTing them into + ;; X COMMON-LISP, then reEXPORTing them from COMMON-LISP. + ;; X This leaves their home packages bogusly set to + ;; X EXTENSIONS, which confuses genesis into thinking that + ;; X the CMU CL EXTENSIONS package has to be dumped into the + ;; X target SBCL. (perhaps a last-ditch survival strategy + ;; X for the CMU CL "nooo! don't bootstrap from scratch!" + ;; X meme?) As far as I can see, there's no even slightly + ;; X portable way to undo the damage, so we'll play the "one + ;; X dirty unportable hack deserves another" game, only even + ;; X dirtierly and more unportably than before.. + #+cmu + (let ((symbol (intern key cl))) + (unless (eq (symbol-package symbol) cl) + (warn "using low-level hack to move ~S from ~S to ~S" + symbol + (symbol-package symbol) + cl) + (kernel:%set-symbol-package symbol cl)))) + standard-ht)) diff --git a/src/cold/compile-cold-sbcl.lisp b/src/cold/compile-cold-sbcl.lisp index 465236d..c2017d3 100644 --- a/src/cold/compile-cold-sbcl.lisp +++ b/src/cold/compile-cold-sbcl.lisp @@ -21,10 +21,10 @@ (unless (position :not-target flags) (push (target-compile-stem stem :trace-file (find :trace-file flags) - :assem-p (find :assem flags) - :ignore-failure-p (find :ignore-failure-p - flags)) - reversed-target-object-file-names) + :assem-p (find :assem flags) + :ignore-failure-p (find :ignore-failure-p + flags)) + reversed-target-object-file-names) #!+sb-show (warn-when-cl-snapshot-diff *cl-snapshot*))) (setf *target-object-file-names* - (nreverse reversed-target-object-file-names))) + (nreverse reversed-target-object-file-names))) diff --git a/src/cold/defun-load-or-cload-xcompiler.lisp b/src/cold/defun-load-or-cload-xcompiler.lisp index d489b03..b3e8e2e 100644 --- a/src/cold/defun-load-or-cload-xcompiler.lisp +++ b/src/cold/defun-load-or-cload-xcompiler.lisp @@ -25,129 +25,129 @@ (let ((package-name "SB-XC")) (make-package package-name :use nil :nicknames nil) (dolist (name '(;; the constants (except for T and NIL which have - ;; a specially hacked correspondence between - ;; cross-compilation host Lisp and target Lisp) - "ARRAY-DIMENSION-LIMIT" - "ARRAY-RANK-LIMIT" - "ARRAY-TOTAL-SIZE-LIMIT" - "BOOLE-1" - "BOOLE-2" - "BOOLE-AND" - "BOOLE-ANDC1" - "BOOLE-ANDC2" - "BOOLE-C1" - "BOOLE-C2" - "BOOLE-CLR" - "BOOLE-EQV" - "BOOLE-IOR" - "BOOLE-NAND" - "BOOLE-NOR" - "BOOLE-ORC1" - "BOOLE-ORC2" - "BOOLE-SET" - "BOOLE-XOR" - "CALL-ARGUMENTS-LIMIT" - "CHAR-CODE-LIMIT" - "DOUBLE-FLOAT-EPSILON" - "DOUBLE-FLOAT-NEGATIVE-EPSILON" - "INTERNAL-TIME-UNITS-PER-SECOND" - "LAMBDA-LIST-KEYWORDS" - "LAMBDA-PARAMETERS-LIMIT" - "LEAST-NEGATIVE-DOUBLE-FLOAT" - "LEAST-NEGATIVE-LONG-FLOAT" - "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" - "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" - "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" - "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" - "LEAST-NEGATIVE-SHORT-FLOAT" - "LEAST-NEGATIVE-SINGLE-FLOAT" - "LEAST-POSITIVE-DOUBLE-FLOAT" - "LEAST-POSITIVE-LONG-FLOAT" - "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" - "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" - "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" - "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" - "LEAST-POSITIVE-SHORT-FLOAT" - "LEAST-POSITIVE-SINGLE-FLOAT" - "LONG-FLOAT-EPSILON" - "LONG-FLOAT-NEGATIVE-EPSILON" - "MOST-NEGATIVE-DOUBLE-FLOAT" - "MOST-NEGATIVE-FIXNUM" - "MOST-NEGATIVE-LONG-FLOAT" - "MOST-NEGATIVE-SHORT-FLOAT" - "MOST-NEGATIVE-SINGLE-FLOAT" - "MOST-POSITIVE-DOUBLE-FLOAT" - "MOST-POSITIVE-FIXNUM" - "MOST-POSITIVE-LONG-FLOAT" - "MOST-POSITIVE-SHORT-FLOAT" - "MOST-POSITIVE-SINGLE-FLOAT" - "MULTIPLE-VALUES-LIMIT" - "PI" - "SHORT-FLOAT-EPSILON" - "SHORT-FLOAT-NEGATIVE-EPSILON" - "SINGLE-FLOAT-EPSILON" - "SINGLE-FLOAT-NEGATIVE-EPSILON" + ;; a specially hacked correspondence between + ;; cross-compilation host Lisp and target Lisp) + "ARRAY-DIMENSION-LIMIT" + "ARRAY-RANK-LIMIT" + "ARRAY-TOTAL-SIZE-LIMIT" + "BOOLE-1" + "BOOLE-2" + "BOOLE-AND" + "BOOLE-ANDC1" + "BOOLE-ANDC2" + "BOOLE-C1" + "BOOLE-C2" + "BOOLE-CLR" + "BOOLE-EQV" + "BOOLE-IOR" + "BOOLE-NAND" + "BOOLE-NOR" + "BOOLE-ORC1" + "BOOLE-ORC2" + "BOOLE-SET" + "BOOLE-XOR" + "CALL-ARGUMENTS-LIMIT" + "CHAR-CODE-LIMIT" + "DOUBLE-FLOAT-EPSILON" + "DOUBLE-FLOAT-NEGATIVE-EPSILON" + "INTERNAL-TIME-UNITS-PER-SECOND" + "LAMBDA-LIST-KEYWORDS" + "LAMBDA-PARAMETERS-LIMIT" + "LEAST-NEGATIVE-DOUBLE-FLOAT" + "LEAST-NEGATIVE-LONG-FLOAT" + "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" + "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" + "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" + "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" + "LEAST-NEGATIVE-SHORT-FLOAT" + "LEAST-NEGATIVE-SINGLE-FLOAT" + "LEAST-POSITIVE-DOUBLE-FLOAT" + "LEAST-POSITIVE-LONG-FLOAT" + "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" + "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" + "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" + "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" + "LEAST-POSITIVE-SHORT-FLOAT" + "LEAST-POSITIVE-SINGLE-FLOAT" + "LONG-FLOAT-EPSILON" + "LONG-FLOAT-NEGATIVE-EPSILON" + "MOST-NEGATIVE-DOUBLE-FLOAT" + "MOST-NEGATIVE-FIXNUM" + "MOST-NEGATIVE-LONG-FLOAT" + "MOST-NEGATIVE-SHORT-FLOAT" + "MOST-NEGATIVE-SINGLE-FLOAT" + "MOST-POSITIVE-DOUBLE-FLOAT" + "MOST-POSITIVE-FIXNUM" + "MOST-POSITIVE-LONG-FLOAT" + "MOST-POSITIVE-SHORT-FLOAT" + "MOST-POSITIVE-SINGLE-FLOAT" + "MULTIPLE-VALUES-LIMIT" + "PI" + "SHORT-FLOAT-EPSILON" + "SHORT-FLOAT-NEGATIVE-EPSILON" + "SINGLE-FLOAT-EPSILON" + "SINGLE-FLOAT-NEGATIVE-EPSILON" - ;; everything else which needs a separate + ;; everything else which needs a separate ;; existence in xc and target - "BOOLE" - "BOOLE-CLR" "BOOLE-SET" "BOOLE-1" "BOOLE-2" - "BOOLE-C1" "BOOLE-C2" "BOOLE-AND" "BOOLE-IOR" - "BOOLE-XOR" "BOOLE-EQV" "BOOLE-NAND" "BOOLE-NOR" - "BOOLE-ANDC1" "BOOLE-ANDC2" "BOOLE-ORC1" "BOOLE-ORC2" - "BUILT-IN-CLASS" - "BYTE" "BYTE-POSITION" "BYTE-SIZE" - "CHAR-CODE" - "CLASS" "CLASS-NAME" "CLASS-OF" - "CODE-CHAR" - "COMPILE-FILE" - "COMPILE-FILE-PATHNAME" - "*COMPILE-FILE-PATHNAME*" - "*COMPILE-FILE-TRUENAME*" - "*COMPILE-PRINT*" - "*COMPILE-VERBOSE*" - "COMPILER-MACRO-FUNCTION" - "CONSTANTP" - "DEFCONSTANT" - "DEFINE-MODIFY-MACRO" - "DEFINE-SETF-EXPANDER" - "DEFMACRO" "DEFSETF" "DEFSTRUCT" "DEFTYPE" - "DEPOSIT-FIELD" "DPB" - "FBOUNDP" "FDEFINITION" "FMAKUNBOUND" - "FIND-CLASS" - "GET-SETF-EXPANSION" - "LDB" "LDB-TEST" - "LISP-IMPLEMENTATION-TYPE" "LISP-IMPLEMENTATION-VERSION" - "MACRO-FUNCTION" - "MACROEXPAND" "MACROEXPAND-1" "*MACROEXPAND-HOOK*" - "MAKE-LOAD-FORM" - "MAKE-LOAD-FORM-SAVING-SLOTS" - "MASK-FIELD" - "PACKAGE" "PACKAGEP" - "PROCLAIM" - "SPECIAL-OPERATOR-P" - "STANDARD-CLASS" - "STRUCTURE-CLASS" - "SUBTYPEP" - "TYPE-OF" "TYPEP" - "UPGRADED-ARRAY-ELEMENT-TYPE" - "UPGRADED-COMPLEX-PART-TYPE" - "WITH-COMPILATION-UNIT")) + "BOOLE" + "BOOLE-CLR" "BOOLE-SET" "BOOLE-1" "BOOLE-2" + "BOOLE-C1" "BOOLE-C2" "BOOLE-AND" "BOOLE-IOR" + "BOOLE-XOR" "BOOLE-EQV" "BOOLE-NAND" "BOOLE-NOR" + "BOOLE-ANDC1" "BOOLE-ANDC2" "BOOLE-ORC1" "BOOLE-ORC2" + "BUILT-IN-CLASS" + "BYTE" "BYTE-POSITION" "BYTE-SIZE" + "CHAR-CODE" + "CLASS" "CLASS-NAME" "CLASS-OF" + "CODE-CHAR" + "COMPILE-FILE" + "COMPILE-FILE-PATHNAME" + "*COMPILE-FILE-PATHNAME*" + "*COMPILE-FILE-TRUENAME*" + "*COMPILE-PRINT*" + "*COMPILE-VERBOSE*" + "COMPILER-MACRO-FUNCTION" + "CONSTANTP" + "DEFCONSTANT" + "DEFINE-MODIFY-MACRO" + "DEFINE-SETF-EXPANDER" + "DEFMACRO" "DEFSETF" "DEFSTRUCT" "DEFTYPE" + "DEPOSIT-FIELD" "DPB" + "FBOUNDP" "FDEFINITION" "FMAKUNBOUND" + "FIND-CLASS" + "GET-SETF-EXPANSION" + "LDB" "LDB-TEST" + "LISP-IMPLEMENTATION-TYPE" "LISP-IMPLEMENTATION-VERSION" + "MACRO-FUNCTION" + "MACROEXPAND" "MACROEXPAND-1" "*MACROEXPAND-HOOK*" + "MAKE-LOAD-FORM" + "MAKE-LOAD-FORM-SAVING-SLOTS" + "MASK-FIELD" + "PACKAGE" "PACKAGEP" + "PROCLAIM" + "SPECIAL-OPERATOR-P" + "STANDARD-CLASS" + "STRUCTURE-CLASS" + "SUBTYPEP" + "TYPE-OF" "TYPEP" + "UPGRADED-ARRAY-ELEMENT-TYPE" + "UPGRADED-COMPLEX-PART-TYPE" + "WITH-COMPILATION-UNIT")) (export (intern name package-name) package-name))) ;; don't watch: (dolist (package (list-all-packages)) (when (= (mismatch (package-name package) "SB!") 3) (shadowing-import (mapcar (lambda (name) (find-symbol name "SB-XC")) - '("BYTE" "BYTE-POSITION" "BYTE-SIZE" - "DPB" "LDB" "LDB-TEST" - "DEPOSIT-FIELD" "MASK-FIELD" - - "BOOLE" - "BOOLE-CLR" "BOOLE-SET" "BOOLE-1" "BOOLE-2" - "BOOLE-C1" "BOOLE-C2" "BOOLE-AND" "BOOLE-IOR" - "BOOLE-XOR" "BOOLE-EQV" "BOOLE-NAND" "BOOLE-NOR" - "BOOLE-ANDC1" "BOOLE-ANDC2" "BOOLE-ORC1" "BOOLE-ORC2")) + '("BYTE" "BYTE-POSITION" "BYTE-SIZE" + "DPB" "LDB" "LDB-TEST" + "DEPOSIT-FIELD" "MASK-FIELD" + + "BOOLE" + "BOOLE-CLR" "BOOLE-SET" "BOOLE-1" "BOOLE-2" + "BOOLE-C1" "BOOLE-C2" "BOOLE-AND" "BOOLE-IOR" + "BOOLE-XOR" "BOOLE-EQV" "BOOLE-NAND" "BOOLE-NOR" + "BOOLE-ANDC1" "BOOLE-ANDC2" "BOOLE-ORC1" "BOOLE-ORC2")) package))) ;; Build a version of Python to run in the host Common Lisp, to be @@ -162,8 +162,8 @@ (do-stems-and-flags (stem flags) (unless (find :not-host flags) (funcall load-or-cload-stem - stem - :ignore-failure-p (find :ignore-failure-p flags)) + stem + :ignore-failure-p (find :ignore-failure-p flags)) #!+sb-show (warn-when-cl-snapshot-diff *cl-snapshot*))) ;; If the cross-compilation host is SBCL itself, we can use the diff --git a/src/cold/read-from-file.lisp b/src/cold/read-from-file.lisp index a2ee083..d7e0838 100644 --- a/src/cold/read-from-file.lisp +++ b/src/cold/read-from-file.lisp @@ -14,9 +14,9 @@ (defun read-from-file (pathname-designator) (with-open-file (s pathname-designator) (let* ((result (read s)) - (eof-result (cons nil nil)) - (after-result (read s nil eof-result))) + (eof-result (cons nil nil)) + (after-result (read s nil eof-result))) (unless (eq after-result eof-result) - (error "more than one expression in file ~S" pathname-designator)) + (error "more than one expression in file ~S" pathname-designator)) result))) (compile 'read-from-file) diff --git a/src/cold/rename-package-carefully.lisp b/src/cold/rename-package-carefully.lisp index 158572a..797571b 100644 --- a/src/cold/rename-package-carefully.lisp +++ b/src/cold/rename-package-carefully.lisp @@ -14,10 +14,10 @@ ;;; (ANSI on RENAME-PACKAGE: "The consequences are undefined if new-name or any ;;; new-nickname conflicts with any existing package names.") (defun rename-package-carefully (package-designator - new-name - &optional new-nicknames) + new-name + &optional new-nicknames) (let ((package (find-package package-designator)) - (unused-name "UNUSED-PACKAGE-NAME")) + (unused-name "UNUSED-PACKAGE-NAME")) (assert (not (find-package unused-name))) (assert (not (string= unused-name new-name))) (assert (not (find unused-name new-nicknames :test #'string=))) diff --git a/src/cold/set-up-cold-packages.lisp b/src/cold/set-up-cold-packages.lisp index 6533047..0b6fb57 100644 --- a/src/cold/set-up-cold-packages.lisp +++ b/src/cold/set-up-cold-packages.lisp @@ -15,11 +15,11 @@ ;;; We make no attempt to be fully general; our table doesn't need to be ;;; able to express features which we don't happen to use. (export '(package-data - package-data-name - package-data-export - package-data-reexport - package-data-import-from - package-data-use)) + package-data-name + package-data-export + package-data-reexport + package-data-import-from + package-data-use)) (defstruct package-data ;; a string designator for the package name (name (error "missing PACKAGE-DATA-NAME datum")) @@ -50,56 +50,56 @@ ;; can without referring to any other packages. (dolist (package-data package-data-list) (let* ((package (make-package - (package-data-name package-data) - ;; Note: As of 0.7.0, the only nicknames we use - ;; for our implementation packages are hacks - ;; not needed at cross-compile time (e.g. the - ;; deprecated SB-C-CALL nickname for SB-ALIEN). - ;; So support for nicknaming during xc is gone, - ;; since any nicknames are hacked in during - ;; cold init. - :nicknames nil - :use nil))) - #-clisp ; As of "2.27 (released 2001-07-17) (built 3215971334)" - ; CLISP didn't support DOCUMENTATION on PACKAGE values. - (progn - #!+sb-doc (setf (documentation package t) - (package-data-doc package-data))) - ;; Walk the tree of exported names, exporting each name. - (labels ((recurse (tree) - (etypecase tree - ;; FIXME: The comments above say the structure is a tree, - ;; but here we're sleazily treating it as though - ;; dotted lists never occur. Replace this LIST case - ;; with separate NULL and CONS cases to fix this. - (list (mapc #'recurse tree)) - (string (export (intern tree package) package))))) - (recurse (package-data-export package-data))))) + (package-data-name package-data) + ;; Note: As of 0.7.0, the only nicknames we use + ;; for our implementation packages are hacks + ;; not needed at cross-compile time (e.g. the + ;; deprecated SB-C-CALL nickname for SB-ALIEN). + ;; So support for nicknaming during xc is gone, + ;; since any nicknames are hacked in during + ;; cold init. + :nicknames nil + :use nil))) + #-clisp ; As of "2.27 (released 2001-07-17) (built 3215971334)" + ; CLISP didn't support DOCUMENTATION on PACKAGE values. + (progn + #!+sb-doc (setf (documentation package t) + (package-data-doc package-data))) + ;; Walk the tree of exported names, exporting each name. + (labels ((recurse (tree) + (etypecase tree + ;; FIXME: The comments above say the structure is a tree, + ;; but here we're sleazily treating it as though + ;; dotted lists never occur. Replace this LIST case + ;; with separate NULL and CONS cases to fix this. + (list (mapc #'recurse tree)) + (string (export (intern tree package) package))))) + (recurse (package-data-export package-data))))) ;; Now that all packages exist, we can set up package-package ;; references. (dolist (package-data package-data-list) (use-package (package-data-use package-data) - (package-data-name package-data)) + (package-data-name package-data)) (dolist (sublist (package-data-import-from package-data)) - (let* ((from-package (first sublist)) - (symbol-names (rest sublist)) - (symbols (mapcar (lambda (name) - ;; old way, broke for importing symbols - ;; like SB!C::DEBUG-SOURCE-FORM into - ;; SB!DI -- WHN 19990714 - #+nil - (let ((s (find-symbol name from-package))) - (unless s - (error "can't find ~S in ~S" - name - from-package)) - s) - ;; new way, works for SB!DI stuff - ;; -- WHN 19990714 - (intern name from-package)) - symbol-names))) - (import symbols (package-data-name package-data))))) + (let* ((from-package (first sublist)) + (symbol-names (rest sublist)) + (symbols (mapcar (lambda (name) + ;; old way, broke for importing symbols + ;; like SB!C::DEBUG-SOURCE-FORM into + ;; SB!DI -- WHN 19990714 + #+nil + (let ((s (find-symbol name from-package))) + (unless s + (error "can't find ~S in ~S" + name + from-package)) + s) + ;; new way, works for SB!DI stuff + ;; -- WHN 19990714 + (intern name from-package)) + symbol-names))) + (import symbols (package-data-name package-data))))) ;; Now that all package-package references exist, we can handle ;; REEXPORT operations. (We have to wait until now because they @@ -107,32 +107,32 @@ ;; properly, but is somewhat ugly. (let (done) (labels - ((reexport (package-data) - (let ((package (find-package (package-data-name package-data)))) - (cond - ((member package done)) - ((null (package-data-reexport package-data)) - (push package done)) - (t - (mapcar #'reexport - (remove-if-not - (lambda (x) - (member x (package-data-use package-data) - :test #'string=)) - package-data-list - :key #'package-data-name)) - (dolist (symbol-name (package-data-reexport package-data)) - (multiple-value-bind (symbol status) - (find-symbol symbol-name package) - (unless status - (error "No symbol named ~S is accessible in ~S." - symbol-name package)) - (when (eq (symbol-package symbol) package) - (error - "~S is not inherited/imported, but native to ~S." - symbol-name package)) - (export symbol package))) - (push package done)))))) - (dolist (x package-data-list) - (reexport x)) - (assert (= (length done) (length package-data-list)))))) + ((reexport (package-data) + (let ((package (find-package (package-data-name package-data)))) + (cond + ((member package done)) + ((null (package-data-reexport package-data)) + (push package done)) + (t + (mapcar #'reexport + (remove-if-not + (lambda (x) + (member x (package-data-use package-data) + :test #'string=)) + package-data-list + :key #'package-data-name)) + (dolist (symbol-name (package-data-reexport package-data)) + (multiple-value-bind (symbol status) + (find-symbol symbol-name package) + (unless status + (error "No symbol named ~S is accessible in ~S." + symbol-name package)) + (when (eq (symbol-package symbol) package) + (error + "~S is not inherited/imported, but native to ~S." + symbol-name package)) + (export symbol package))) + (push package done)))))) + (dolist (x package-data-list) + (reexport x)) + (assert (= (length done) (length package-data-list)))))) diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index 9fe9f42..7a77c6d 100644 --- a/src/cold/shared.lisp +++ b/src/cold/shared.lisp @@ -34,7 +34,7 @@ (defvar *target-obj-prefix*) ;;; suffixes for filename stems when cross-compiling -(defvar *host-obj-suffix* +(defvar *host-obj-suffix* (or ;; On some xc hosts, it's impossible to LOAD a fasl file unless it ;; has the same extension that the host uses for COMPILE-FILE @@ -89,14 +89,14 @@ ;;; COMPILE-STEM function above. -- WHN 19990321 (defun rename-file-a-la-unix (x y) - (let ((path ;; (Note that the TRUENAME expression here is lifted from an - ;; example in the ANSI spec for TRUENAME.) - (with-open-file (stream y :direction :output) - (close stream) - ;; From the ANSI spec: "In this case, the file is closed - ;; when the truename is tried, so the truename - ;; information is reliable." - (truename stream)))) + (let ((path ;; (Note that the TRUENAME expression here is lifted from an + ;; example in the ANSI spec for TRUENAME.) + (with-open-file (stream y :direction :output) + (close stream) + ;; From the ANSI spec: "In this case, the file is closed + ;; when the truename is tried, so the truename + ;; information is reliable." + (truename stream)))) (delete-file path) (rename-file x path))) (compile 'rename-file-a-la-unix) @@ -113,7 +113,7 @@ ;;; :OBJ-PREFIX, :OBJ-SUFFIX = ;;; strings to be concatenated to STEM to produce object filename ;;; :TMP-OBJ-SUFFIX-SUFFIX = -;;; string to be appended to the name of an object file to produce +;;; string to be appended to the name of an object file to produce ;;; the name of a temporary object file ;;; :COMPILE-FILE, :IGNORE-FAILURE-P = ;;; :COMPILE-FILE is a function to use for compiling the file @@ -123,29 +123,29 @@ ;;; :IGNORE-FAILURE-P is set, in which case only a warning will be ;;; signalled. (defun compile-stem (stem - &key - (obj-prefix "") - (obj-suffix (error "missing OBJ-SUFFIX")) - (tmp-obj-suffix-suffix "-tmp") - (src-prefix "") - (src-suffix ".lisp") - (compile-file #'compile-file) - trace-file - ignore-failure-p) + &key + (obj-prefix "") + (obj-suffix (error "missing OBJ-SUFFIX")) + (tmp-obj-suffix-suffix "-tmp") + (src-prefix "") + (src-suffix ".lisp") + (compile-file #'compile-file) + trace-file + ignore-failure-p) (declare (type function compile-file)) (let* (;; KLUDGE: Note that this CONCATENATE 'STRING stuff is not The Common - ;; Lisp Way, although it works just fine for common UNIX environments. - ;; Should it come to pass that the system is ported to environments - ;; where version numbers and so forth become an issue, it might become - ;; urgent to rewrite this using the fancy Common Lisp PATHNAME - ;; machinery instead of just using strings. In the absence of such a - ;; port, it might or might be a good idea to do the rewrite. - ;; -- WHN 19990815 - (src (concatenate 'string src-prefix stem src-suffix)) - (obj (concatenate 'string obj-prefix stem obj-suffix)) - (tmp-obj (concatenate 'string obj tmp-obj-suffix-suffix))) + ;; Lisp Way, although it works just fine for common UNIX environments. + ;; Should it come to pass that the system is ported to environments + ;; where version numbers and so forth become an issue, it might become + ;; urgent to rewrite this using the fancy Common Lisp PATHNAME + ;; machinery instead of just using strings. In the absence of such a + ;; port, it might or might be a good idea to do the rewrite. + ;; -- WHN 19990815 + (src (concatenate 'string src-prefix stem src-suffix)) + (obj (concatenate 'string obj-prefix stem obj-suffix)) + (tmp-obj (concatenate 'string obj tmp-obj-suffix-suffix))) (ensure-directories-exist obj :verbose t) @@ -169,23 +169,23 @@ ;; behaviour is right; and in any case absolutifying the pathname ;; insulates us against changes of behaviour. -- CSR, 2002-08-09 (setf tmp-obj - ;; (Note that this idiom is taken from the ANSI - ;; documentation for TRUENAME.) - (with-open-file (stream tmp-obj + ;; (Note that this idiom is taken from the ANSI + ;; documentation for TRUENAME.) + (with-open-file (stream tmp-obj :direction :output ;; Compilation would overwrite the ;; temporary object anyway and overly ;; strict implementations default ;; to :ERROR. :if-exists :supersede) - (close stream) - (truename stream))) + (close stream) + (truename stream))) ;; and some compilers (e.g. OpenMCL) will complain if they're ;; asked to write over a file that exists already (and isn't ;; recognizeably a fasl file), so (when (probe-file tmp-obj) (delete-file tmp-obj)) - + ;; Try to use the compiler to generate a new temporary object file. (flet ((report-recompile-restart (stream) (format stream "Recompile file ~S" src)) @@ -250,33 +250,33 @@ ;;; readmacros instead of the ordinary #+ and #- readmacros. (setf *shebang-features* (let* ((default-features - (append (read-from-file "base-target-features.lisp-expr") - (read-from-file "local-target-features.lisp-expr"))) - (customizer-file-name "customize-target-features.lisp") - (customizer (if (probe-file customizer-file-name) - (compile nil - (read-from-file customizer-file-name)) - #'identity))) - (funcall customizer default-features))) + (append (read-from-file "base-target-features.lisp-expr") + (read-from-file "local-target-features.lisp-expr"))) + (customizer-file-name "customize-target-features.lisp") + (customizer (if (probe-file customizer-file-name) + (compile nil + (read-from-file customizer-file-name)) + #'identity))) + (funcall customizer default-features))) (let ((*print-length* nil) (*print-level* nil)) (format t - "target features *SHEBANG-FEATURES*=~@<~S~:>~%" - *shebang-features*)) + "target features *SHEBANG-FEATURES*=~@<~S~:>~%" + *shebang-features*)) (defvar *shebang-backend-subfeatures* (let* ((default-subfeatures nil) - (customizer-file-name "customize-backend-subfeatures.lisp") - (customizer (if (probe-file customizer-file-name) - (compile nil - (read-from-file customizer-file-name)) - #'identity))) + (customizer-file-name "customize-backend-subfeatures.lisp") + (customizer (if (probe-file customizer-file-name) + (compile nil + (read-from-file customizer-file-name)) + #'identity))) (funcall customizer default-subfeatures))) (let ((*print-length* nil) (*print-level* nil)) (format t - "target backend-subfeatures *SHEBANG-BACKEND-FEATURES*=~@<~S~:>~%" - *shebang-backend-subfeatures*)) + "target backend-subfeatures *SHEBANG-BACKEND-FEATURES*=~@<~S~:>~%" + *shebang-backend-subfeatures*)) ;;;; cold-init-related PACKAGE and SYMBOL tools @@ -331,8 +331,8 @@ (let ((stem-and-flags (gensym "STEM-AND-FLAGS"))) `(dolist (,stem-and-flags *stems-and-flags*) (let ((,stem (first ,stem-and-flags)) - (,flags (rest ,stem-and-flags))) - ,@body)))) + (,flags (rest ,stem-and-flags))) + ,@body)))) ;;; Check for stupid typos in FLAGS list keywords. (let ((stems (make-hash-table :test 'equal))) @@ -342,8 +342,8 @@ (setf (gethash stem stems) t)) (let ((set-difference (set-difference flags *expected-stem-flags*))) (when set-difference - (error "found unexpected flag(s) in *STEMS-AND-FLAGS*: ~S" - set-difference))))) + (error "found unexpected flag(s) in *STEMS-AND-FLAGS*: ~S" + set-difference))))) ;;;; tools to compile SBCL sources to create the cross-compiler @@ -352,11 +352,11 @@ (defun in-host-compilation-mode (fn) (declare (type function fn)) (let ((*features* (cons :sb-xc-host *features*)) - ;; the CROSS-FLOAT-INFINITY-KLUDGE, as documented in - ;; base-target-features.lisp-expr: - (*shebang-features* (set-difference *shebang-features* - '(:sb-propagate-float-type - :sb-propagate-fun-type)))) + ;; the CROSS-FLOAT-INFINITY-KLUDGE, as documented in + ;; base-target-features.lisp-expr: + (*shebang-features* (set-difference *shebang-features* + '(:sb-propagate-float-type + :sb-propagate-fun-type)))) (with-additional-nickname ("SB-XC" "SB!XC") (funcall fn)))) (compile 'in-host-compilation-mode) @@ -366,13 +366,13 @@ ;;; into the cross-compilation host Common lisp. (defun host-cload-stem (stem &key ignore-failure-p) (let ((compiled-filename (in-host-compilation-mode - (lambda () - (compile-stem - stem - :obj-prefix *host-obj-prefix* - :obj-suffix *host-obj-suffix* - :compile-file #'cl:compile-file - :ignore-failure-p ignore-failure-p))))) + (lambda () + (compile-stem + stem + :obj-prefix *host-obj-prefix* + :obj-suffix *host-obj-suffix* + :compile-file #'cl:compile-file + :ignore-failure-p ignore-failure-p))))) (load compiled-filename))) (compile 'host-cload-stem) @@ -393,15 +393,15 @@ ;;; produce a corresponding file in the target object directory tree. (defun target-compile-stem (stem &key assem-p ignore-failure-p trace-file) (funcall *in-target-compilation-mode-fn* - (lambda () - (compile-stem stem - :obj-prefix *target-obj-prefix* - :obj-suffix *target-obj-suffix* + (lambda () + (compile-stem stem + :obj-prefix *target-obj-prefix* + :obj-suffix *target-obj-suffix* :trace-file trace-file - :ignore-failure-p ignore-failure-p - :compile-file (if assem-p - *target-assemble-file* - *target-compile-file*))))) + :ignore-failure-p ignore-failure-p + :compile-file (if assem-p + *target-assemble-file* + *target-compile-file*))))) (compile 'target-compile-stem) ;;; (This function is not used by the build process, but is intended @@ -410,6 +410,6 @@ ;;; necessarily in the source tree, e.g. in "/tmp".) (defun target-compile-file (filename) (funcall *in-target-compilation-mode-fn* - (lambda () - (funcall *target-compile-file* filename)))) + (lambda () + (funcall *target-compile-file* filename)))) (compile 'target-compile-file) diff --git a/src/cold/shebang.lisp b/src/cold/shebang.lisp index 6d6a2cb..753a877 100644 --- a/src/cold/shebang.lisp +++ b/src/cold/shebang.lisp @@ -26,15 +26,15 @@ (etypecase feature (symbol (member feature list :test #'eq)) (cons (flet ((subfeature-in-list-p (subfeature) - (feature-in-list-p subfeature list))) - (ecase (first feature) - (:or (some #'subfeature-in-list-p (rest feature))) - (:and (every #'subfeature-in-list-p (rest feature))) - (:not (let ((rest (cdr feature))) - (if (or (null (car rest)) (cdr rest)) - (error "wrong number of terms in compound feature ~S" - feature) - (not (subfeature-in-list-p (second feature))))))))))) + (feature-in-list-p subfeature list))) + (ecase (first feature) + (:or (some #'subfeature-in-list-p (rest feature))) + (:and (every #'subfeature-in-list-p (rest feature))) + (:not (let ((rest (cdr feature))) + (if (or (null (car rest)) (cdr rest)) + (error "wrong number of terms in compound feature ~S" + feature) + (not (subfeature-in-list-p (second feature))))))))))) (compile 'feature-in-list-p) (defun shebang-reader (stream sub-character infix-parameter) @@ -48,15 +48,15 @@ ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then ;; would become "unless test is satisfied".. (when (let* ((*package* (find-package "KEYWORD")) - (*read-suppress* nil) - (not-p (char= next-char #\-)) - (feature (read stream))) - (if (feature-in-list-p feature *shebang-features*) - not-p - (not not-p))) + (*read-suppress* nil) + (not-p (char= next-char #\-)) + (feature (read stream))) + (if (feature-in-list-p feature *shebang-features*) + not-p + (not not-p))) ;; Read (and discard) a form from input. (let ((*read-suppress* t)) - (read stream t nil t)))) + (read stream t nil t)))) (values)) (compile 'shebang-reader) @@ -99,42 +99,42 @@ ;;; it until run-time. (defun shebang-double-quote (stream) (labels ((rc () (read-char stream)) - (white-p (char) - ;; Putting non-standard characters in the compiler source is - ;; generally a bad idea, since we'd like to be really portable. - ;; It's specifically a bad idea in strings intended to be - ;; processed by SHEBANG-DOUBLE-QUOTE, because there seems to be no - ;; portable way to test a non-STANDARD-CHAR for whitespaceness. - ;; (The most common problem would be to put a #\TAB -- which is - ;; not a STANDARD-CHAR -- into the string. If this is part of the - ;; to-be-skipped-over whitespace after a #\~ #\NEWLINE sequence in - ;; the string, it won't work, because it won't be recognized as - ;; whitespace.) - (unless (typep char 'standard-char) - (warn "non-STANDARD-CHAR in #!\": ~C" result)) - (or (char= char #\newline) - (char= char #\space))) - (skip-white () - (do ((char (rc) (rc)) - (count 0 (1+ count))) - ((not (white-p char)) - (unread-char char stream) - count)))) + (white-p (char) + ;; Putting non-standard characters in the compiler source is + ;; generally a bad idea, since we'd like to be really portable. + ;; It's specifically a bad idea in strings intended to be + ;; processed by SHEBANG-DOUBLE-QUOTE, because there seems to be no + ;; portable way to test a non-STANDARD-CHAR for whitespaceness. + ;; (The most common problem would be to put a #\TAB -- which is + ;; not a STANDARD-CHAR -- into the string. If this is part of the + ;; to-be-skipped-over whitespace after a #\~ #\NEWLINE sequence in + ;; the string, it won't work, because it won't be recognized as + ;; whitespace.) + (unless (typep char 'standard-char) + (warn "non-STANDARD-CHAR in #!\": ~C" result)) + (or (char= char #\newline) + (char= char #\space))) + (skip-white () + (do ((char (rc) (rc)) + (count 0 (1+ count))) + ((not (white-p char)) + (unread-char char stream) + count)))) (do ((adj-string (make-array 0 :element-type 'char :adjustable t)) - (char (rc) (rc))) - ((char= char #\") (coerce adj-string 'simple-string)) + (char (rc) (rc))) + ((char= char #\") (coerce adj-string 'simple-string)) (cond ((char= char #\~) - (let ((next-char (read-char stream))) - (cond ((char= next-char #\newline) - (incf *shebang-double-quote--approx-bytes-saved* - (+ 2 (skip-white)))) - (t - (vector-push-extend char adj-string) - (vector-push-extend next-char adj-string))))) - ((char= char #\\) - (vector-push-extend char adj-string) - (vector-push-extend (rc) adj-string)) - (t (vector-push-extend char adj-string)))))) + (let ((next-char (read-char stream))) + (cond ((char= next-char #\newline) + (incf *shebang-double-quote--approx-bytes-saved* + (+ 2 (skip-white)))) + (t + (vector-push-extend char adj-string) + (vector-push-extend next-char adj-string))))) + ((char= char #\\) + (vector-push-extend char adj-string) + (vector-push-extend (rc) adj-string)) + (t (vector-push-extend char adj-string)))))) (setf (gethash #\" *shebang-dispatch*) #'shebang-double-quote) diff --git a/src/cold/slam.lisp b/src/cold/slam.lisp index 92534c6..e9dc76f 100644 --- a/src/cold/slam.lisp +++ b/src/cold/slam.lisp @@ -29,16 +29,16 @@ ;; recompile unnecessarily than sometimes bogusly to assume ;; up-to-date-ness.) (> (file-write-date output) - (file-write-date input)))) + (file-write-date input)))) (do-stems-and-flags (stem flags) (unless (position :not-target flags) (let ((srcname (concatenate 'string stem ".lisp")) - (objname (concatenate 'string - *target-obj-prefix* - stem - *target-obj-suffix*))) + (objname (concatenate 'string + *target-obj-prefix* + stem + *target-obj-suffix*))) (unless (output-up-to-date-wrt-input-p objname srcname) - (target-compile-stem stem - :assem-p (find :assem flags) - :ignore-failure-p (find :ignore-failure-p flags)))))) + (target-compile-stem stem + :assem-p (find :assem flags) + :ignore-failure-p (find :ignore-failure-p flags)))))) diff --git a/src/cold/snapshot.lisp b/src/cold/snapshot.lisp index 0e6723d..4e01ec3 100644 --- a/src/cold/snapshot.lisp +++ b/src/cold/snapshot.lisp @@ -32,8 +32,8 @@ (defstruct snapshot (hash-table (make-hash-table :test 'eq) - :type hash-table - :read-only t)) + :type hash-table + :read-only t)) ;;; Return a SNAPSHOT object representing the current state of the ;;; package associated with PACKAGE-DESIGNATOR. @@ -42,58 +42,58 @@ ;;; type definitions and documentation strings. (defun take-snapshot (package-designator) (let ((package (find-package package-designator)) - (result (make-snapshot))) + (result (make-snapshot))) (unless package (error "can't find package ~S" package-designator)) (do-symbols (symbol package) (multiple-value-bind (symbol-ignore status) - (find-symbol (symbol-name symbol) package) - (declare (ignore symbol-ignore)) - (let ((symbol-properties nil)) - (ecase status - (:inherited - (values)) - ((:internal :external) - (when (boundp symbol) - (push (cons :symbol-value (symbol-value symbol)) - symbol-properties)) - (when (fboundp symbol) - (push (cons :symbol-function (symbol-function symbol)) - symbol-properties)) - (when (macro-function symbol) - (push (cons :macro-function (macro-function symbol)) - symbol-properties)) - (when (special-operator-p symbol) - (push :special-operator - symbol-properties)))) - (push status symbol-properties) - (setf (gethash symbol (snapshot-hash-table result)) - symbol-properties)))) + (find-symbol (symbol-name symbol) package) + (declare (ignore symbol-ignore)) + (let ((symbol-properties nil)) + (ecase status + (:inherited + (values)) + ((:internal :external) + (when (boundp symbol) + (push (cons :symbol-value (symbol-value symbol)) + symbol-properties)) + (when (fboundp symbol) + (push (cons :symbol-function (symbol-function symbol)) + symbol-properties)) + (when (macro-function symbol) + (push (cons :macro-function (macro-function symbol)) + symbol-properties)) + (when (special-operator-p symbol) + (push :special-operator + symbol-properties)))) + (push status symbol-properties) + (setf (gethash symbol (snapshot-hash-table result)) + symbol-properties)))) result)) (compile 'take-snapshot) (defun snapshot-diff (x y) (let ((xh (snapshot-hash-table x)) - (yh (snapshot-hash-table y)) - (result nil)) + (yh (snapshot-hash-table y)) + (result nil)) (flet ((1way (ah bh) - (maphash (lambda (key avalue) - (declare (ignore avalue)) - (multiple-value-bind (bvalue bvalue?) (gethash key bh) - (declare (ignore bvalue)) - (unless bvalue? - (push (list key ah) - result)))) - ah))) + (maphash (lambda (key avalue) + (declare (ignore avalue)) + (multiple-value-bind (bvalue bvalue?) (gethash key bh) + (declare (ignore bvalue)) + (unless bvalue? + (push (list key ah) + result)))) + ah))) (1way xh yh) (1way yh xh)) (maphash (lambda (key xvalue) - (multiple-value-bind (yvalue yvalue?) (gethash key yh) - (when yvalue? - (unless (equalp xvalue yvalue) - (push (list key xvalue yvalue) - result))))) - xh) + (multiple-value-bind (yvalue yvalue?) (gethash key yh) + (when yvalue? + (unless (equalp xvalue yvalue) + (push (list key xvalue yvalue) + result))))) + xh) result)) (compile 'snapshot-diff) @@ -104,41 +104,41 @@ *cl-ignorable-diffs* (let ((result (make-hash-table :test 'eq))) (dolist (symbol `(;; These change regularly: - * ** *** - / // /// - + ++ +++ - - - *gensym-counter* - ;; These are bound when compiling and/or loading: - *package* - *compile-file-truename* - *compile-file-pathname* - *load-truename* - *load-pathname* - ;; These change because CMU CL uses them as internal - ;; variables: - ,@' - #-cmu nil - #+cmu (cl::*gc-trigger* - cl::inch-ptr - cl::*internal-symbol-output-function* - cl::ouch-ptr - cl::*previous-case* - cl::read-buffer - cl::read-buffer-length - cl::*string-output-streams* - cl::*available-buffers* - cl::*current-unwind-protect-block* - cl::*load-depth* - cl::*free-fop-tables* - cl::*load-symbol-buffer* - cl::*load-symbol-buffer-size* - cl::in-index - cl::in-buffer - ;; These two are changed by PURIFY. - cl::*static-space-free-pointer* - cl::*static-space-end-pointer*) - )) + * ** *** + / // /// + + ++ +++ + - + *gensym-counter* + ;; These are bound when compiling and/or loading: + *package* + *compile-file-truename* + *compile-file-pathname* + *load-truename* + *load-pathname* + ;; These change because CMU CL uses them as internal + ;; variables: + ,@' + #-cmu nil + #+cmu (cl::*gc-trigger* + cl::inch-ptr + cl::*internal-symbol-output-function* + cl::ouch-ptr + cl::*previous-case* + cl::read-buffer + cl::read-buffer-length + cl::*string-output-streams* + cl::*available-buffers* + cl::*current-unwind-protect-block* + cl::*load-depth* + cl::*free-fop-tables* + cl::*load-symbol-buffer* + cl::*load-symbol-buffer-size* + cl::in-index + cl::in-buffer + ;; These two are changed by PURIFY. + cl::*static-space-free-pointer* + cl::*static-space-end-pointer*) + )) (setf (gethash symbol result) t)) result)) @@ -153,14 +153,14 @@ (progn (defun cl-snapshot-diff (cl-snapshot) (remove-if (lambda (entry) - (gethash (first entry) *cl-ignorable-diffs*)) - (snapshot-diff cl-snapshot (take-snapshot :common-lisp)))) + (gethash (first entry) *cl-ignorable-diffs*)) + (snapshot-diff cl-snapshot (take-snapshot :common-lisp)))) (defun warn-when-cl-snapshot-diff (cl-snapshot) (let ((cl-snapshot-diff (cl-snapshot-diff cl-snapshot))) (when cl-snapshot-diff - (let ((*print-length* 30) - (*print-circle* t)) - (warn "CL snapshot differs:") - (print cl-snapshot-diff *error-output*))))) + (let ((*print-length* 30) + (*print-circle* t)) + (warn "CL snapshot differs:") + (print cl-snapshot-diff *error-output*))))) (compile 'cl-snapshot-diff) (compile 'warn-when-cl-snapshot-diff)) diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index 8ee9045..3aff541 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -14,11 +14,11 @@ ;;;; general warm init compilation policy (proclaim '(optimize (compilation-speed 1) - (debug #+sb-show 2 #-sb-show 1) - (inhibit-warnings 2) - (safety 2) - (space 1) - (speed 2))) + (debug #+sb-show 2 #-sb-show 1) + (inhibit-warnings 2) + (safety 2) + (space 1) + (speed 2))) ;;;; package hacking @@ -41,15 +41,15 @@ (dolist (package (list-all-packages)) (let ((old-package-name (package-name package))) (when (and (>= (length old-package-name) (length boot-prefix)) - (string= boot-prefix old-package-name - :end2 (length boot-prefix))) - (let ((new-package-name (concatenate 'string - perm-prefix - (subseq old-package-name - (length boot-prefix))))) - (rename-package package - new-package-name - (package-nicknames package))))))) + (string= boot-prefix old-package-name + :end2 (length boot-prefix))) + (let ((new-package-name (concatenate 'string + perm-prefix + (subseq old-package-name + (length boot-prefix))))) + (rename-package package + new-package-name + (package-nicknames package))))))) ;;; FIXME: This nickname is a deprecated hack for backwards ;;; compatibility with code which assumed the CMU-CL-style @@ -57,47 +57,47 @@ ;;; in 0.7.0, so we should get rid of this nickname after a while. (let ((package (find-package "SB-ALIEN"))) (rename-package package - (package-name package) - (cons "SB-C-CALL" (package-nicknames package)))) + (package-name package) + (cons "SB-C-CALL" (package-nicknames package)))) ;;;; compiling and loading more of the system (let* ((sys *default-pathname-defaults*) (src - (merge-pathnames - (make-pathname :directory '(:relative "src" :wild-inferiors) - :name :wild :type :wild) - sys)) + (merge-pathnames + (make-pathname :directory '(:relative "src" :wild-inferiors) + :name :wild :type :wild) + sys)) (contrib - (merge-pathnames - (make-pathname :directory '(:relative "contrib" :wild-inferiors) - :name :wild :type :wild) - sys))) + (merge-pathnames + (make-pathname :directory '(:relative "contrib" :wild-inferiors) + :name :wild :type :wild) + sys))) (setf (logical-pathname-translations "SYS") - `(("SYS:SRC;**;*.*.*" ,src) - ("SYS:CONTRIB;**;*.*.*" ,contrib)))) + `(("SYS:SRC;**;*.*.*" ,src) + ("SYS:CONTRIB;**;*.*.*" ,contrib)))) ;;; FIXME: CMU CL's pclcom.lisp had extra optional stuff wrapped around ;;; COMPILE-PCL, at least some of which we should probably have too: ;;; ;;; (with-compilation-unit ;;; (:optimize '(optimize (debug #+(and (not high-security) small) .5 -;;; #-(or high-security small) 2 -;;; #+high-security 3) -;;; (speed 2) (safety #+(and (not high-security) small) 0 -;;; #-(or high-security small) 2 -;;; #+high-security 3) -;;; (inhibit-warnings 2)) +;;; #-(or high-security small) 2 +;;; #+high-security 3) +;;; (speed 2) (safety #+(and (not high-security) small) 0 +;;; #-(or high-security small) 2 +;;; #+high-security 3) +;;; (inhibit-warnings 2)) ;;; :optimize-interface '(optimize-interface #+(and (not high-security) small) ;;; (safety 1) -;;; #+high-security (safety 3)) +;;; #+high-security (safety 3)) ;;; :context-declarations ;;; '((:external (declare (optimize-interface (safety #-high-security 2 #+high- ;;; security 3) -;;; (debug #-high-security 1 #+high-s +;;; (debug #-high-security 1 #+high-s ;;; ecurity 3)))) -;;; ((:or :macro (:match "$EARLY-") (:match "$BOOT-")) -;;; (declare (optimize (speed 0)))))) +;;; ((:or :macro (:match "$EARLY-") (:match "$BOOT-")) +;;; (declare (optimize (speed 0)))))) ;;; ;;; FIXME: This has mutated into a hack which crudely duplicates ;;; functionality from the existing mechanism to load files from @@ -106,75 +106,75 @@ ;;; parallel directory trees.) Maybe we could merge the filenames here ;;; into build-order.lisp-expr with some new flag (perhaps :WARM) to ;;; indicate that the files should be handled not in cold load but -;;; afterwards. +;;; afterwards. (dolist (stem '(;; CLOS, derived from the PCL reference implementation - ;; - ;; This PCL build order is based on a particular - ;; (arbitrary) linearization of the declared build - ;; order dependencies from the old PCL defsys.lisp - ;; dependency database. - #+nil "src/pcl/walk" ; #+NIL = moved to build-order.lisp-expr - "SRC;PCL;EARLY-LOW" - "SRC;PCL;MACROS" + ;; + ;; This PCL build order is based on a particular + ;; (arbitrary) linearization of the declared build + ;; order dependencies from the old PCL defsys.lisp + ;; dependency database. + #+nil "src/pcl/walk" ; #+NIL = moved to build-order.lisp-expr + "SRC;PCL;EARLY-LOW" + "SRC;PCL;MACROS" "SRC;PCL;COMPILER-SUPPORT" - "SRC;PCL;LOW" + "SRC;PCL;LOW" "SRC;PCL;SLOT-NAME" - "SRC;PCL;DEFCLASS" - "SRC;PCL;DEFS" - "SRC;PCL;FNGEN" - "SRC;PCL;CACHE" - "SRC;PCL;DLISP" - "SRC;PCL;DLISP2" - "SRC;PCL;BOOT" - "SRC;PCL;VECTOR" - "SRC;PCL;SLOTS-BOOT" - "SRC;PCL;COMBIN" - "SRC;PCL;DFUN" - "SRC;PCL;CTOR" - "SRC;PCL;BRAID" - "SRC;PCL;DLISP3" - "SRC;PCL;GENERIC-FUNCTIONS" - "SRC;PCL;SLOTS" - "SRC;PCL;INIT" - "SRC;PCL;STD-CLASS" - "SRC;PCL;CPL" - "SRC;PCL;FSC" - "SRC;PCL;METHODS" - "SRC;PCL;FIXUP" - "SRC;PCL;DEFCOMBIN" - "SRC;PCL;CTYPES" - "SRC;PCL;ENV" - "SRC;PCL;DOCUMENTATION" - "SRC;PCL;PRINT-OBJECT" - "SRC;PCL;PRECOM1" - "SRC;PCL;PRECOM2" + "SRC;PCL;DEFCLASS" + "SRC;PCL;DEFS" + "SRC;PCL;FNGEN" + "SRC;PCL;CACHE" + "SRC;PCL;DLISP" + "SRC;PCL;DLISP2" + "SRC;PCL;BOOT" + "SRC;PCL;VECTOR" + "SRC;PCL;SLOTS-BOOT" + "SRC;PCL;COMBIN" + "SRC;PCL;DFUN" + "SRC;PCL;CTOR" + "SRC;PCL;BRAID" + "SRC;PCL;DLISP3" + "SRC;PCL;GENERIC-FUNCTIONS" + "SRC;PCL;SLOTS" + "SRC;PCL;INIT" + "SRC;PCL;STD-CLASS" + "SRC;PCL;CPL" + "SRC;PCL;FSC" + "SRC;PCL;METHODS" + "SRC;PCL;FIXUP" + "SRC;PCL;DEFCOMBIN" + "SRC;PCL;CTYPES" + "SRC;PCL;ENV" + "SRC;PCL;DOCUMENTATION" + "SRC;PCL;PRINT-OBJECT" + "SRC;PCL;PRECOM1" + "SRC;PCL;PRECOM2" - ;; miscellaneous functionality which depends on CLOS - "SRC;CODE;FORCE-DELAYED-DEFBANGMETHODS" + ;; miscellaneous functionality which depends on CLOS + "SRC;CODE;FORCE-DELAYED-DEFBANGMETHODS" "SRC;CODE;LATE-CONDITION" - ;; CLOS-level support for the Gray OO streams - ;; extension (which is also supported by various - ;; lower-level hooks elsewhere in the code) - "SRC;PCL;GRAY-STREAMS-CLASS" - "SRC;PCL;GRAY-STREAMS" + ;; CLOS-level support for the Gray OO streams + ;; extension (which is also supported by various + ;; lower-level hooks elsewhere in the code) + "SRC;PCL;GRAY-STREAMS-CLASS" + "SRC;PCL;GRAY-STREAMS" - ;; other functionality not needed for cold init, moved - ;; to warm init to reduce peak memory requirement in - ;; cold init - "SRC;CODE;DESCRIBE" + ;; other functionality not needed for cold init, moved + ;; to warm init to reduce peak memory requirement in + ;; cold init + "SRC;CODE;DESCRIBE" "SRC;CODE;DESCRIBE-POLICY" - "SRC;CODE;INSPECT" - "SRC;CODE;PROFILE" - "SRC;CODE;NTRACE" + "SRC;CODE;INSPECT" + "SRC;CODE;PROFILE" + "SRC;CODE;NTRACE" "SRC;CODE;STEP" - "SRC;CODE;RUN-PROGRAM" + "SRC;CODE;RUN-PROGRAM" - ;; Code derived from PCL's pre-ANSI DESCRIBE-OBJECT - ;; facility is still used in our ANSI DESCRIBE - ;; facility, and should be compiled and loaded after - ;; our DESCRIBE facility is compiled and loaded. - "SRC;PCL;DESCRIBE")) + ;; Code derived from PCL's pre-ANSI DESCRIBE-OBJECT + ;; facility is still used in our ANSI DESCRIBE + ;; facility, and should be compiled and loaded after + ;; our DESCRIBE facility is compiled and loaded. + "SRC;PCL;DESCRIBE")) (let ((fullname (concatenate 'string "SYS:" stem ".LISP"))) (sb-int:/show "about to compile" fullname) @@ -182,36 +182,36 @@ (format stream "Recompile file ~S" fullname)) (report-continue-restart (stream) (format stream - "Continue, using possibly bogus file ~S" - (compile-file-pathname fullname)))) + "Continue, using possibly bogus file ~S" + (compile-file-pathname fullname)))) (tagbody retry-compile-file (multiple-value-bind (output-truename warnings-p failure-p) (compile-file fullname) (declare (ignore warnings-p)) - (sb-int:/show "done compiling" fullname) + (sb-int:/show "done compiling" fullname) (cond ((not output-truename) (error "COMPILE-FILE of ~S failed." fullname)) (failure-p - (unwind-protect - (restart-case - (error "FAILURE-P was set when creating ~S." - output-truename) - (recompile () - :report report-recompile-restart - (go retry-compile-file)) - (continue () - :report report-continue-restart - (setf failure-p nil))) - ;; Don't leave failed object files lying around. - (when (and failure-p (probe-file output-truename)) + (unwind-protect + (restart-case + (error "FAILURE-P was set when creating ~S." + output-truename) + (recompile () + :report report-recompile-restart + (go retry-compile-file)) + (continue () + :report report-continue-restart + (setf failure-p nil))) + ;; Don't leave failed object files lying around. + (when (and failure-p (probe-file output-truename)) (delete-file output-truename) (format t "~&deleted ~S~%" output-truename)))) ;; Otherwise: success, just fall through. (t nil)) - (unless (load output-truename) - (error "LOAD of ~S failed." output-truename)) - (sb-int:/show "done loading" output-truename)))))) + (unless (load output-truename) + (error "LOAD of ~S failed." output-truename)) + (sb-int:/show "done loading" output-truename)))))) ;;;; setting package documentation @@ -223,8 +223,8 @@ #+sb-doc (setf (documentation (find-package "COMMON-LISP") t) "public: home of symbols defined by the ANSI language specification") #+sb-doc (setf (documentation (find-package "COMMON-LISP-USER") t) - "public: the default package for user code and data") + "public: the default package for user code and data") #+sb-doc (setf (documentation (find-package "KEYWORD") t) - "public: home of keywords") + "public: home of keywords") diff --git a/src/cold/with-stuff.lisp b/src/cold/with-stuff.lisp index 11965fb..1c69ac2 100644 --- a/src/cold/with-stuff.lisp +++ b/src/cold/with-stuff.lisp @@ -15,52 +15,52 @@ ;;; a helper macro for WITH-ADDITIONAL-NICKNAME and WITHOUT-SOME-NICKNAME (defmacro with-given-nicknames ((package-designator nicknames) &body body) (let ((p (gensym "P")) - (n (gensym "N")) - (o (gensym "O"))) + (n (gensym "N")) + (o (gensym "O"))) `(let* ((,p ,package-designator) ; PACKAGE-DESIGNATOR, evaluated only once - (,n ,nicknames) ; NICKNAMES, evaluated only once - (,o (package-nicknames ,p))) ; old package nicknames + (,n ,nicknames) ; NICKNAMES, evaluated only once + (,o (package-nicknames ,p))) ; old package nicknames (rename-package-carefully ,p (package-name ,p) ,n) (unwind-protect - (progn ,@body) - (unless (nicknames= ,n (package-nicknames ,p)) - ;; This probably didn't happen on purpose, and it's not clear anyway - ;; what we should do when it did happen, so die noisily: - (error "package nicknames changed within WITH-GIVEN-NICKNAMES: ~ - expected ~S, found ~S" - ,n - (package-nicknames ,p))) - (rename-package-carefully ,p (package-name ,p) ,o))))) + (progn ,@body) + (unless (nicknames= ,n (package-nicknames ,p)) + ;; This probably didn't happen on purpose, and it's not clear anyway + ;; what we should do when it did happen, so die noisily: + (error "package nicknames changed within WITH-GIVEN-NICKNAMES: ~ + expected ~S, found ~S" + ,n + (package-nicknames ,p))) + (rename-package-carefully ,p (package-name ,p) ,o))))) ;;; Execute BODY with NICKNAME added as a nickname for PACKAGE-DESIGNATOR. (defmacro with-additional-nickname ((package-designator nickname) &body body) (let ((p (gensym "P")) - (n (gensym "N"))) + (n (gensym "N"))) `(let* ((,p ,package-designator) ; PACKAGE-DESIGNATOR, evaluated only once - (,n ,nickname)) ; NICKNAME, evaluated only once + (,n ,nickname)) ; NICKNAME, evaluated only once (if (find-package ,n) - (error "~S is already a package name." ,n) - (with-given-nicknames (,p (cons ,n (package-nicknames ,p))) - ,@body))))) + (error "~S is already a package name." ,n) + (with-given-nicknames (,p (cons ,n (package-nicknames ,p))) + ,@body))))) ;;; Execute BODY with NICKNAME removed as a nickname for PACKAGE-DESIGNATOR. (defmacro without-given-nickname ((package-designator nickname) &body body) (let ((p (gensym "P")) - (n (gensym "N")) - (o (gensym "O"))) + (n (gensym "N")) + (o (gensym "O"))) `(let* ((,p ,package-designator) ; PACKAGE-DESIGNATOR, evaluated only once - (,n ,nickname) ; NICKNAME, evaluated only once - (,o (package-nicknames ,p))) ; old package nicknames + (,n ,nickname) ; NICKNAME, evaluated only once + (,o (package-nicknames ,p))) ; old package nicknames (if (find ,n ,o :test #'string=) - (with-given-nicknames (,p (remove ,n ,o :test #'string=)) - ,@body) - (error "~S is not a nickname for ~S." ,n ,p))))) + (with-given-nicknames (,p (remove ,n ,o :test #'string=)) + ,@body) + (error "~S is not a nickname for ~S." ,n ,p))))) ;;; a helper function for WITH-NICKNAME: Are two collections of package ;;; nicknames the same? (defun nicknames= (x y) (equal (sort (mapcar #'string x) #'string<) - (sort (mapcar #'string y) #'string<))) + (sort (mapcar #'string y) #'string<))) (compile 'nicknames=) ;;; helper functions for WITH-ADDITIONAL-NICKNAMES and WITHOUT-GIVEN-NICKNAMES @@ -76,25 +76,25 @@ (declare (type function single-nn-fn)) (labels ((multi-nd (nd-list body-fn) ; multiple nickname descriptors (declare (type function body-fn)) - (if (null nd-list) - (funcall body-fn) - (single-nd (first nd-list) - (lambda () - (multi-nd (rest nd-list) body-fn))))) - (single-nd (nd body-fn) ; single nickname descriptor - (destructuring-bind (package-descriptor nickname-list) nd - (multi-nn package-descriptor nickname-list body-fn))) - (multi-nn (nn-list package-descriptor body-fn) ; multiple nicknames + (if (null nd-list) + (funcall body-fn) + (single-nd (first nd-list) + (lambda () + (multi-nd (rest nd-list) body-fn))))) + (single-nd (nd body-fn) ; single nickname descriptor + (destructuring-bind (package-descriptor nickname-list) nd + (multi-nn package-descriptor nickname-list body-fn))) + (multi-nn (nn-list package-descriptor body-fn) ; multiple nicknames (declare (type function body-fn)) - (if (null nn-list) - (funcall body-fn) - (funcall single-nn-fn - (first nn-list) - package-descriptor - (lambda () - (multi-nn package-descriptor - (rest nn-list) - body-fn)))))) + (if (null nn-list) + (funcall body-fn) + (funcall single-nn-fn + (first nn-list) + package-descriptor + (lambda () + (multi-nn package-descriptor + (rest nn-list) + body-fn)))))) (multi-nd nd-list body-fn))) (compile '%with-additional-nickname) (compile '%without-given-nickname) @@ -108,9 +108,9 @@ ;;; PACKAGE-DESIGNATOR NICKNAME* (defmacro with-additional-nicknames (nickname-descriptor-list &body body) `(%multi-nickname-magic ,nickname-descriptor-list - #'%with-additional-nickname - (lambda () ,@body))) + #'%with-additional-nickname + (lambda () ,@body))) (defmacro without-given-nicknames (nickname-descriptor-list &body body) `(%multi-nickname-magic ,nickname-descriptor-list - #'%without-additional-nickname - (lambda () ,@body))) + #'%without-additional-nickname + (lambda () ,@body))) diff --git a/src/compiler/alpha/alloc.lisp b/src/compiler/alpha/alloc.lisp index 4f0757b..78c3b89 100644 --- a/src/compiler/alpha/alloc.lisp +++ b/src/compiler/alpha/alloc.lisp @@ -22,7 +22,7 @@ (:temporary (:scs (descriptor-reg) :type list) ptr) (:temporary (:scs (descriptor-reg)) temp) (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result) - res) + res) (:info num) (:results (result :scs (descriptor-reg))) (:variant-vars star) @@ -30,48 +30,48 @@ (:node-var node) (:generator 0 (cond ((zerop num) - (move null-tn result)) - ((and star (= num 1)) - (move (tn-ref-tn things) result)) - (t - (macrolet - ((store-car (tn list &optional (slot cons-car-slot)) - `(let ((reg - (sc-case ,tn - ((any-reg descriptor-reg) ,tn) - (zero zero-tn) - (null null-tn) - (control-stack - (load-stack-tn temp ,tn) - temp)))) - (storew reg ,list ,slot list-pointer-lowtag)))) - (let* ((dx-p (node-stack-allocate-p node)) + (move null-tn result)) + ((and star (= num 1)) + (move (tn-ref-tn things) result)) + (t + (macrolet + ((store-car (tn list &optional (slot cons-car-slot)) + `(let ((reg + (sc-case ,tn + ((any-reg descriptor-reg) ,tn) + (zero zero-tn) + (null null-tn) + (control-stack + (load-stack-tn temp ,tn) + temp)))) + (storew reg ,list ,slot list-pointer-lowtag)))) + (let* ((dx-p (node-stack-allocate-p node)) (cons-cells (if star (1- num) num)) (space (* (pad-data-block cons-size) cons-cells))) - (pseudo-atomic (:extra (if dx-p 0 space)) + (pseudo-atomic (:extra (if dx-p 0 space)) (cond (dx-p (align-csp res) (inst bis csp-tn list-pointer-lowtag res) (inst lda csp-tn space csp-tn)) (t (inst bis alloc-tn list-pointer-lowtag res))) - (move res ptr) - (dotimes (i (1- cons-cells)) - (store-car (tn-ref-tn things) ptr) - (setf things (tn-ref-across things)) - (inst lda ptr (pad-data-block cons-size) ptr) - (storew ptr ptr - (- cons-cdr-slot cons-size) - list-pointer-lowtag)) - (store-car (tn-ref-tn things) ptr) - (cond (star - (setf things (tn-ref-across things)) - (store-car (tn-ref-tn things) ptr cons-cdr-slot)) - (t - (storew null-tn ptr - cons-cdr-slot list-pointer-lowtag))) - (aver (null (tn-ref-across things))) - (move res result)))))))) + (move res ptr) + (dotimes (i (1- cons-cells)) + (store-car (tn-ref-tn things) ptr) + (setf things (tn-ref-across things)) + (inst lda ptr (pad-data-block cons-size) ptr) + (storew ptr ptr + (- cons-cdr-slot cons-size) + list-pointer-lowtag)) + (store-car (tn-ref-tn things) ptr) + (cond (star + (setf things (tn-ref-across things)) + (store-car (tn-ref-tn things) ptr cons-cdr-slot)) + (t + (storew null-tn ptr + cons-cdr-slot list-pointer-lowtag))) + (aver (null (tn-ref-across things))) + (move res result)))))))) (define-vop (list list-or-list*) (:variant nil)) @@ -83,7 +83,7 @@ (define-vop (allocate-code-object) (:args (boxed-arg :scs (any-reg)) - (unboxed-arg :scs (any-reg))) + (unboxed-arg :scs (any-reg))) (:results (result :scs (descriptor-reg))) (:temporary (:scs (non-descriptor-reg)) ndescr) (:temporary (:scs (any-reg) :from (:argument 0)) boxed) @@ -91,14 +91,14 @@ (:generator 100 (inst li (lognot lowtag-mask) ndescr) (inst lda boxed (fixnumize (1+ code-trace-table-offset-slot)) - boxed-arg) + boxed-arg) (inst and boxed ndescr boxed) (inst srl unboxed-arg word-shift unboxed) (inst lda unboxed lowtag-mask unboxed) (inst and unboxed ndescr unboxed) (inst sll boxed (- n-widetag-bits word-shift) ndescr) (inst bis ndescr code-header-widetag ndescr) - + (pseudo-atomic () (inst bis alloc-tn other-pointer-lowtag result) (storew ndescr result 0 other-pointer-lowtag) @@ -132,16 +132,16 @@ (let* ((size (+ length closure-info-offset)) (alloc-size (pad-data-block size))) (inst li - (logior (ash (1- size) n-widetag-bits) closure-header-widetag) - temp) + (logior (ash (1- size) n-widetag-bits) closure-header-widetag) + temp) (pseudo-atomic (:extra (if stack-allocate-p 0 alloc-size)) (cond (stack-allocate-p - (align-csp result) + (align-csp result) (inst bis csp-tn fun-pointer-lowtag result) (inst lda csp-tn alloc-size csp-tn)) (t (inst bis alloc-tn fun-pointer-lowtag result))) - (storew temp result 0 fun-pointer-lowtag)) + (storew temp result 0 fun-pointer-lowtag)) (storew function result closure-fun-slot fun-pointer-lowtag)))) ;;; The compiler likes to be able to directly make value cells. @@ -151,7 +151,7 @@ (:results (result :scs (descriptor-reg))) (:generator 10 (with-fixed-allocation - (result temp value-cell-header-widetag value-cell-size) + (result temp value-cell-header-widetag value-cell-size) (storew value result value-cell-value-slot other-pointer-lowtag)))) ;;;; automatic allocators for primitive objects @@ -172,8 +172,8 @@ (pseudo-atomic (:extra (pad-data-block words)) (inst bis alloc-tn lowtag result) (when type - (inst li (logior (ash (1- words) n-widetag-bits) type) temp) - (storew temp result 0 lowtag))))) + (inst li (logior (ash (1- words) n-widetag-bits) type) temp) + (storew temp result 0 lowtag))))) (define-vop (var-alloc) (:args (extra :scs (any-reg))) diff --git a/src/compiler/alpha/arith.lisp b/src/compiler/alpha/arith.lisp index 4c3d931..919b33d 100644 --- a/src/compiler/alpha/arith.lisp +++ b/src/compiler/alpha/arith.lisp @@ -55,7 +55,7 @@ (define-vop (fast-fixnum-binop) (:args (x :target r :scs (any-reg)) - (y :target r :scs (any-reg))) + (y :target r :scs (any-reg))) (:arg-types tagged-num tagged-num) (:results (r :scs (any-reg))) (:result-types tagged-num) @@ -66,7 +66,7 @@ (define-vop (fast-unsigned-binop) (:args (x :target r :scs (unsigned-reg)) - (y :target r :scs (unsigned-reg))) + (y :target r :scs (unsigned-reg))) (:arg-types unsigned-num unsigned-num) (:results (r :scs (unsigned-reg))) (:result-types unsigned-num) @@ -77,7 +77,7 @@ (define-vop (fast-signed-binop) (:args (x :target r :scs (signed-reg)) - (y :target r :scs (signed-reg))) + (y :target r :scs (signed-reg))) (:arg-types signed-num signed-num) (:results (r :scs (signed-reg))) (:result-types signed-num) @@ -101,68 +101,68 @@ (:info y) (:arg-types unsigned-num (:constant integer))) -(defmacro define-binop (translate cost untagged-cost op - tagged-type untagged-type - &optional arg-swap restore-fixnum-mask) +(defmacro define-binop (translate cost untagged-cost op + tagged-type untagged-type + &optional arg-swap restore-fixnum-mask) `(progn (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM") - fast-fixnum-binop) + fast-fixnum-binop) ,@(when restore-fixnum-mask - `((:temporary (:sc non-descriptor-reg) temp))) + `((:temporary (:sc non-descriptor-reg) temp))) (:args (x ,@(unless restore-fixnum-mask `(:target r)) :scs (any-reg)) - (y ,@(unless restore-fixnum-mask `(:target r)) :scs (any-reg))) + (y ,@(unless restore-fixnum-mask `(:target r)) :scs (any-reg))) (:translate ,translate) (:generator ,(1+ cost) - ,(if arg-swap - `(inst ,op y x ,(if restore-fixnum-mask 'temp 'r)) - `(inst ,op x y ,(if restore-fixnum-mask 'temp 'r))) - ,@(when restore-fixnum-mask - `((inst bic temp #.(ash lowtag-mask -1) r))))) + ,(if arg-swap + `(inst ,op y x ,(if restore-fixnum-mask 'temp 'r)) + `(inst ,op x y ,(if restore-fixnum-mask 'temp 'r))) + ,@(when restore-fixnum-mask + `((inst bic temp #.(ash lowtag-mask -1) r))))) (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") - fast-signed-binop) + fast-signed-binop) (:args (x :target r :scs (signed-reg)) - (y :target r :scs (signed-reg))) + (y :target r :scs (signed-reg))) (:translate ,translate) (:generator ,(1+ untagged-cost) - ,(if arg-swap - `(inst ,op y x r) - `(inst ,op x y r)))) + ,(if arg-swap + `(inst ,op y x r) + `(inst ,op x y r)))) (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED") - fast-unsigned-binop) + fast-unsigned-binop) (:args (x :target r :scs (unsigned-reg)) - (y :target r :scs (unsigned-reg))) + (y :target r :scs (unsigned-reg))) (:translate ,translate) (:generator ,(1+ untagged-cost) - ,(if arg-swap - `(inst ,op y x r) - `(inst ,op x y r)))) + ,(if arg-swap + `(inst ,op y x r) + `(inst ,op x y r)))) ,@(when (and tagged-type (not arg-swap)) - `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM") - fast-fixnum-c-binop) - (:args (x ,@(unless restore-fixnum-mask `(:target r)) - :scs (any-reg))) - (:arg-types tagged-num (:constant ,tagged-type)) - ,@(when restore-fixnum-mask - `((:temporary (:sc non-descriptor-reg) temp))) - (:translate ,translate) - (:generator ,cost - (inst ,op x (fixnumize y) ,(if restore-fixnum-mask 'temp 'r)) - ,@(when restore-fixnum-mask - `((inst bic temp #.(ash lowtag-mask -1) r))))))) + `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM") + fast-fixnum-c-binop) + (:args (x ,@(unless restore-fixnum-mask `(:target r)) + :scs (any-reg))) + (:arg-types tagged-num (:constant ,tagged-type)) + ,@(when restore-fixnum-mask + `((:temporary (:sc non-descriptor-reg) temp))) + (:translate ,translate) + (:generator ,cost + (inst ,op x (fixnumize y) ,(if restore-fixnum-mask 'temp 'r)) + ,@(when restore-fixnum-mask + `((inst bic temp #.(ash lowtag-mask -1) r))))))) ,@(when (and untagged-type (not arg-swap)) - `((define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED") - fast-signed-c-binop) - (:arg-types signed-num (:constant ,untagged-type)) - (:translate ,translate) - (:generator ,untagged-cost - (inst ,op x y r))) - (define-vop (,(symbolicate "FAST-" translate - "-C/UNSIGNED=>UNSIGNED") - fast-unsigned-c-binop) - (:arg-types unsigned-num (:constant ,untagged-type)) - (:translate ,translate) - (:generator ,untagged-cost - (inst ,op x y r))))))) + `((define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED") + fast-signed-c-binop) + (:arg-types signed-num (:constant ,untagged-type)) + (:translate ,translate) + (:generator ,untagged-cost + (inst ,op x y r))) + (define-vop (,(symbolicate "FAST-" translate + "-C/UNSIGNED=>UNSIGNED") + fast-unsigned-c-binop) + (:arg-types unsigned-num (:constant ,untagged-type)) + (:translate ,translate) + (:generator ,untagged-cost + (inst ,op x y r))))))) (define-binop + 1 5 addq (unsigned-byte 6) (unsigned-byte 8)) (define-binop - 1 5 subq (unsigned-byte 6) (unsigned-byte 8)) @@ -179,8 +179,8 @@ (define-vop (fast-logand-c-mask/unsigned=>unsigned fast-unsigned-c-binop) (:translate logand) (:arg-types unsigned-num - (:constant (or (integer #xffffffff #xffffffff) - (integer #xffffffff00000000 #xffffffff00000000)))) + (:constant (or (integer #xffffffff #xffffffff) + (integer #xffffffff00000000 #xffffffff00000000)))) (:generator 1 (ecase y (#xffffffff (inst mskll x 4 r)) @@ -191,7 +191,7 @@ (define-vop (fast-ash/unsigned=>unsigned) (:note "inline ASH") (:args (number :scs (unsigned-reg) :to :save) - (amount :scs (signed-reg))) + (amount :scs (signed-reg))) (:arg-types unsigned-num signed-num) (:results (result :scs (unsigned-reg))) (:result-types unsigned-num) @@ -218,7 +218,7 @@ (define-vop (fast-ash/signed=>signed) (:note "inline ASH") (:args (number :scs (signed-reg) :to :save) - (amount :scs (signed-reg))) + (amount :scs (signed-reg))) (:arg-types signed-num signed-num) (:results (result :scs (signed-reg))) (:result-types signed-num) @@ -333,7 +333,7 @@ (:results (res :scs (unsigned-reg))) (:result-types positive-fixnum) (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0) - :target res) num) + :target res) num) (:temporary (:scs (non-descriptor-reg)) mask temp) (:generator 60 ;; FIXME: now this looks expensive, what with these 64bit loads. @@ -401,12 +401,12 @@ (inst not x res))) (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned - fast-ash-c/unsigned=>unsigned) + fast-ash-c/unsigned=>unsigned) (:translate ash-left-mod64)) (define-vop (fast-ash-left-mod64/unsigned=>unsigned fast-ash-left/unsigned=>unsigned)) (deftransform ash-left-mod64 ((integer count) - ((unsigned-byte 64) (unsigned-byte 6))) + ((unsigned-byte 64) (unsigned-byte 6))) (when (sb!c::constant-lvar-p count) (sb!c::give-up-ir1-transform)) '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count)) @@ -451,7 +451,7 @@ (define-vop (fast-conditional/fixnum fast-conditional) (:args (x :scs (any-reg)) - (y :scs (any-reg))) + (y :scs (any-reg))) (:arg-types tagged-num tagged-num) (:note "inline fixnum comparison")) @@ -462,7 +462,7 @@ (define-vop (fast-conditional/signed fast-conditional) (:args (x :scs (signed-reg)) - (y :scs (signed-reg))) + (y :scs (signed-reg))) (:arg-types signed-num signed-num) (:note "inline (signed-byte 64) comparison")) @@ -473,7 +473,7 @@ (define-vop (fast-conditional/unsigned fast-conditional) (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg))) + (y :scs (unsigned-reg))) (:arg-types unsigned-num unsigned-num) (:note "inline (unsigned-byte 64) comparison")) @@ -486,56 +486,56 @@ (defmacro define-conditional-vop (translate &rest generator) `(progn ,@(mapcar (lambda (suffix cost signed) - (unless (and (member suffix '(/fixnum -c/fixnum)) - (eq translate 'eql)) - `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" - translate suffix)) - ,(intern - (format nil "~:@(FAST-CONDITIONAL~A~)" - suffix))) - (:translate ,translate) - (:generator ,cost - (let* ((signed ,signed) - (-c/fixnum ,(eq suffix '-c/fixnum)) - (y (if -c/fixnum (fixnumize y) y))) - ,@generator))))) - '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) - '(3 2 5 4 5 4) - '(t t t t nil nil)))) + (unless (and (member suffix '(/fixnum -c/fixnum)) + (eq translate 'eql)) + `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" + translate suffix)) + ,(intern + (format nil "~:@(FAST-CONDITIONAL~A~)" + suffix))) + (:translate ,translate) + (:generator ,cost + (let* ((signed ,signed) + (-c/fixnum ,(eq suffix '-c/fixnum)) + (y (if -c/fixnum (fixnumize y) y))) + ,@generator))))) + '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) + '(3 2 5 4 5 4) + '(t t t t nil nil)))) (define-conditional-vop < (cond ((and signed (eql y 0)) - (if not-p - (inst bge x target) - (inst blt x target))) - (t - (if signed - (inst cmplt x y temp) - (inst cmpult x y temp)) - (if not-p - (inst beq temp target) - (inst bne temp target))))) + (if not-p + (inst bge x target) + (inst blt x target))) + (t + (if signed + (inst cmplt x y temp) + (inst cmpult x y temp)) + (if not-p + (inst beq temp target) + (inst bne temp target))))) (define-conditional-vop > (cond ((and signed (eql y 0)) - (if not-p - (inst ble x target) - (inst bgt x target))) - ((integerp y) - (let ((y (+ y (if -c/fixnum (fixnumize 1) 1)))) - (if signed - (inst cmplt x y temp) - (inst cmpult x y temp)) - (if not-p - (inst bne temp target) - (inst beq temp target)))) - (t - (if signed - (inst cmplt y x temp) - (inst cmpult y x temp)) - (if not-p - (inst beq temp target) - (inst bne temp target))))) + (if not-p + (inst ble x target) + (inst bgt x target))) + ((integerp y) + (let ((y (+ y (if -c/fixnum (fixnumize 1) 1)))) + (if signed + (inst cmplt x y temp) + (inst cmpult x y temp)) + (if not-p + (inst bne temp target) + (inst beq temp target)))) + (t + (if signed + (inst cmplt y x temp) + (inst cmpult y x temp)) + (if not-p + (inst beq temp target) + (inst bne temp target))))) ;;; EQL/FIXNUM is funny because the first arg can be of any type, not ;;; just a known fixnum. @@ -557,25 +557,25 @@ ;;; used on word integers, spuriously consing the argument. (define-vop (fast-eql/fixnum fast-conditional) (:args (x :scs (any-reg)) - (y :scs (any-reg))) + (y :scs (any-reg))) (:arg-types tagged-num tagged-num) (:note "inline fixnum comparison") (:translate eql) (:generator 3 (cond ((equal y zero-tn) - (if not-p - (inst bne x target) - (inst beq x target))) - (t - (inst cmpeq x y temp) - (if not-p - (inst beq temp target) - (inst bne temp target)))))) + (if not-p + (inst bne x target) + (inst beq x target))) + (t + (inst cmpeq x y temp) + (if not-p + (inst beq temp target) + (inst bne temp target)))))) ;;; (define-vop (generic-eql/fixnum fast-eql/fixnum) (:args (x :scs (any-reg descriptor-reg)) - (y :scs (any-reg))) + (y :scs (any-reg))) (:arg-types * tagged-num) (:variant-cost 7)) @@ -587,27 +587,27 @@ (:translate eql) (:generator 2 (let ((y (cond ((eql y 0) zero-tn) - (t - (inst li (fixnumize y) temp) - temp)))) + (t + (inst li (fixnumize y) temp) + temp)))) (inst cmpeq x y temp) (if not-p - (inst beq temp target) - (inst bne temp target))))) + (inst beq temp target) + (inst bne temp target))))) ;;; (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) (:args (x :scs (any-reg descriptor-reg))) (:arg-types * (:constant (signed-byte 6))) (:variant-cost 6)) - + ;;;; 32-bit logical operations (define-vop (merge-bits) (:translate merge-bits) (:args (shift :scs (signed-reg unsigned-reg)) - (prev :scs (unsigned-reg)) - (next :scs (unsigned-reg))) + (prev :scs (unsigned-reg)) + (next :scs (unsigned-reg))) (:arg-types tagged-num unsigned-num unsigned-num) (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res) @@ -627,7 +627,7 @@ (define-vop (shift-towards-someplace) (:policy :fast-safe) (:args (num :scs (unsigned-reg)) - (amount :scs (signed-reg))) + (amount :scs (signed-reg))) (:arg-types unsigned-num tagged-num) (:results (r :scs (unsigned-reg))) (:result-types unsigned-num)) @@ -675,18 +675,18 @@ (:generator 2 (inst sll digit 32 temp) (if not-p - (inst blt temp target) - (inst bge temp target)))) + (inst blt temp target) + (inst bge temp target)))) (define-vop (add-w/carry) (:translate sb!bignum:%add-with-carry) (:policy :fast-safe) (:args (a :scs (unsigned-reg)) - (b :scs (unsigned-reg)) - (c :scs (unsigned-reg))) + (b :scs (unsigned-reg)) + (c :scs (unsigned-reg))) (:arg-types unsigned-num unsigned-num positive-fixnum) (:results (result :scs (unsigned-reg) :from :load) - (carry :scs (unsigned-reg) :from :eval)) + (carry :scs (unsigned-reg) :from :eval)) (:result-types unsigned-num positive-fixnum) (:generator 5 (inst addq a b result) @@ -698,11 +698,11 @@ (:translate sb!bignum:%subtract-with-borrow) (:policy :fast-safe) (:args (a :scs (unsigned-reg)) - (b :scs (unsigned-reg)) - (c :scs (unsigned-reg))) + (b :scs (unsigned-reg)) + (c :scs (unsigned-reg))) (:arg-types unsigned-num unsigned-num positive-fixnum) (:results (result :scs (unsigned-reg) :from :load) - (borrow :scs (unsigned-reg) :from :eval)) + (borrow :scs (unsigned-reg) :from :eval)) (:result-types unsigned-num positive-fixnum) (:generator 4 (inst xor c 1 result) @@ -716,11 +716,11 @@ (:translate sb!bignum:%multiply-and-add) (:policy :fast-safe) (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg)) - (carry-in :scs (unsigned-reg) :to :save)) + (y :scs (unsigned-reg)) + (carry-in :scs (unsigned-reg) :to :save)) (:arg-types unsigned-num unsigned-num unsigned-num) (:results (hi :scs (unsigned-reg)) - (lo :scs (unsigned-reg))) + (lo :scs (unsigned-reg))) (:result-types unsigned-num unsigned-num) (:generator 6 (inst mulq x y lo) @@ -733,12 +733,12 @@ (:translate sb!bignum:%multiply-and-add) (:policy :fast-safe) (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg)) - (prev :scs (unsigned-reg)) - (carry-in :scs (unsigned-reg) :to :save)) + (y :scs (unsigned-reg)) + (prev :scs (unsigned-reg)) + (carry-in :scs (unsigned-reg) :to :save)) (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num) (:results (hi :scs (unsigned-reg)) - (lo :scs (unsigned-reg))) + (lo :scs (unsigned-reg))) (:result-types unsigned-num unsigned-num) (:generator 9 (inst mulq x y lo) @@ -751,10 +751,10 @@ (:translate sb!bignum:%multiply) (:policy :fast-safe) (:args (x :scs (unsigned-reg)) - (y :scs (unsigned-reg))) + (y :scs (unsigned-reg))) (:arg-types unsigned-num unsigned-num) (:results (hi :scs (unsigned-reg)) - (lo :scs (unsigned-reg))) + (lo :scs (unsigned-reg))) (:result-types unsigned-num unsigned-num) (:generator 3 (inst mulq x y lo) @@ -786,13 +786,13 @@ (:translate sb!bignum:%floor) (:policy :fast-safe) (:args (num-high :scs (unsigned-reg)) - (num-low :scs (unsigned-reg)) - (denom-arg :scs (unsigned-reg) :target denom)) + (num-low :scs (unsigned-reg)) + (denom-arg :scs (unsigned-reg) :target denom)) (:arg-types unsigned-num unsigned-num unsigned-num) (:temporary (:scs (unsigned-reg) :from (:argument 2)) denom) (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp) (:results (quo :scs (unsigned-reg) :from (:eval 0)) - (rem :scs (unsigned-reg) :from (:argument 0))) + (rem :scs (unsigned-reg) :from (:argument 0))) (:result-types unsigned-num unsigned-num) (:generator 325 ; number of inst assuming targeting works. (inst sll num-high 32 rem) @@ -804,13 +804,13 @@ SHIFT1 (dotimes (i 32) (let ((shift2 (gen-label))) - (inst srl denom 1 denom) - (inst cmpule denom rem temp) - (inst sll quo 1 quo) - (inst beq temp shift2) - (inst subq rem denom rem) - (inst bis quo 1 quo) - (emit-label shift2))))) + (inst srl denom 1 denom) + (inst cmpule denom rem temp) + (inst sll quo 1 quo) + (inst beq temp shift2) + (inst subq rem denom rem) + (inst bis quo 1 quo) + (emit-label shift2))))) (define-vop (signify-digit) (:translate sb!bignum:%fixnum-digit-with-correct-sign) @@ -833,7 +833,7 @@ (:translate sb!bignum:%ashr) (:policy :fast-safe) (:args (digit :scs (unsigned-reg)) - (count :scs (unsigned-reg))) + (count :scs (unsigned-reg))) (:arg-types unsigned-num positive-fixnum) (:results (result :scs (unsigned-reg) :from (:argument 0))) (:result-types unsigned-num) diff --git a/src/compiler/alpha/array.lisp b/src/compiler/alpha/array.lisp index d2c11d5..34be6b0 100644 --- a/src/compiler/alpha/array.lisp +++ b/src/compiler/alpha/array.lisp @@ -16,15 +16,15 @@ (:policy :fast-safe) (:translate make-array-header) (:args (type :scs (any-reg)) - (rank :scs (any-reg))) + (rank :scs (any-reg))) (:arg-types positive-fixnum positive-fixnum) (:temporary (:scs (any-reg)) bytes) (:temporary (:scs (non-descriptor-reg)) header) (:results (result :scs (descriptor-reg))) (:generator 13 (inst addq rank (+ (* array-dimensions-offset n-word-bytes) - lowtag-mask) - bytes) + lowtag-mask) + bytes) (inst li (lognot lowtag-mask) header) (inst and bytes header bytes) (inst addq rank (fixnumize (1- array-dimensions-offset)) header) @@ -62,15 +62,15 @@ (:translate %check-bound) (:policy :fast-safe) (:args (array :scs (descriptor-reg)) - (bound :scs (any-reg descriptor-reg)) - (index :scs (any-reg descriptor-reg) :target result)) + (bound :scs (any-reg descriptor-reg)) + (index :scs (any-reg descriptor-reg) :target result)) (:results (result :scs (any-reg descriptor-reg))) (:temporary (:scs (non-descriptor-reg)) temp) (:vop-var vop) (:save-p :compute-only) (:generator 5 (let ((error (generate-error-code vop invalid-array-index-error - array bound index))) + array bound index))) (inst cmpult index bound temp) (inst beq temp error) (move index result)))) @@ -83,27 +83,27 @@ (macrolet ((def-full-data-vector-frobs (type element-type &rest scs) `(progn (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) - ,type + ,type vector-data-offset other-pointer-lowtag ,(remove-if (lambda (x) (member x '(null zero))) scs) ,element-type data-vector-ref) (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) - ,type + ,type vector-data-offset other-pointer-lowtag ,scs ,element-type data-vector-set #+gengc ,(if (member 'descriptor-reg scs) - t - nil)))) + t + nil)))) (def-partial-data-vector-frobs (type element-type size signed &rest scs) `(progn (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) - ,type + ,type ,size ,signed vector-data-offset other-pointer-lowtag ,scs ,element-type data-vector-ref) (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) - ,type + ,type ,size vector-data-offset other-pointer-lowtag ,scs ,element-type data-vector-set))) (def-small-data-vector-frobs (type bits) @@ -121,7 +121,7 @@ (:result-types positive-fixnum) (:temporary (:scs (interior-reg)) lip) (:temporary (:scs (non-descriptor-reg) :to (:result 0)) - temp result) + temp result) (:generator 20 (inst srl index ,bit-shift temp) (inst sll temp n-fixnum-tag-bits temp) @@ -133,7 +133,7 @@ (inst and index ,(1- elements-per-word) temp) ,@(unless (= bits 1) `((inst sll temp - ,(1- (integer-length bits)) temp))) + ,(1- (integer-length bits)) temp))) (inst srl result temp result) (inst and result ,(1- (ash 1 bits)) result) (inst sll result n-fixnum-tag-bits value))) @@ -154,15 +154,15 @@ (:result-types positive-fixnum) (:generator 15 (multiple-value-bind (word extra) - (floor index ,elements-per-word) + (floor index ,elements-per-word) (loadw result object (+ word - vector-data-offset) + vector-data-offset) other-pointer-lowtag) (unless (zerop extra) (inst srl result (* extra ,bits) result)) (unless (= extra ,(1- elements-per-word)) (inst and result ,(1- (ash 1 bits)) - result))))) + result))))) (define-vop (,(symbolicate 'data-vector-set/ type)) (:note "inline array store") (:translate data-vector-set) @@ -170,14 +170,14 @@ (:args (object :scs (descriptor-reg)) (index :scs (unsigned-reg) :target shift) (value :scs (unsigned-reg zero immediate) - :target result)) + :target result)) (:arg-types ,type positive-fixnum positive-fixnum) (:results (result :scs (unsigned-reg))) (:result-types positive-fixnum) (:temporary (:scs (interior-reg)) lip) (:temporary (:scs (non-descriptor-reg)) temp old) (:temporary (:scs (non-descriptor-reg) - :from (:argument 1)) shift) + :from (:argument 1)) shift) (:generator 25 (inst srl index ,bit-shift temp) (inst sll temp n-fixnum-tag-bits temp) @@ -189,11 +189,11 @@ (inst and index ,(1- elements-per-word) shift) ,@(unless (= bits 1) `((inst sll shift ,(1- (integer-length - bits)) - shift))) + bits)) + shift))) (unless (and (sc-is value immediate) (= (tn-value value) - ,(1- (ash 1 bits)))) + ,(1- (ash 1 bits)))) (inst li ,(1- (ash 1 bits)) temp) (inst sll temp shift temp) (inst not temp temp) @@ -202,13 +202,13 @@ (sc-case value (immediate (inst li - (logand (tn-value value) - ,(1- (ash 1 bits))) - temp)) + (logand (tn-value value) + ,(1- (ash 1 bits))) + temp)) (unsigned-reg (inst and value - ,(1- (ash 1 bits)) - temp))) + ,(1- (ash 1 bits)) + temp))) (inst sll temp shift temp) (inst bis old temp old)) (inst stl old @@ -227,7 +227,7 @@ (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (value :scs (unsigned-reg zero immediate) - :target result)) + :target result)) (:arg-types ,type (:constant (integer 0 @@ -243,15 +243,15 @@ (:temporary (:scs (non-descriptor-reg)) temp old) (:generator 20 (multiple-value-bind (word extra) - (floor index ,elements-per-word) + (floor index ,elements-per-word) (inst ldl old (- (* (+ word vector-data-offset) - n-word-bytes) + n-word-bytes) other-pointer-lowtag) object) (unless (and (sc-is value immediate) (= (tn-value value) - ,(1- (ash 1 bits)))) + ,(1- (ash 1 bits)))) (cond #+#.(cl:if (cl:= sb-vm:n-word-bits sb-vm:n-machine-word-bits) '(and) '(or)) @@ -261,20 +261,20 @@ (t (inst li (lognot (ash ,(1- (ash 1 - bits)) - (* extra ,bits))) + bits)) + (* extra ,bits))) temp) (inst and old temp old)))) (sc-case value (zero) (immediate (let ((value - (ash (logand (tn-value - value) - ,(1- (ash 1 - bits))) + (ash (logand (tn-value + value) + ,(1- (ash 1 + bits))) (* extra - ,bits)))) + ,bits)))) (cond ((< value #x100) (inst bis old value old)) (t @@ -282,11 +282,11 @@ (inst bis old temp old))))) (unsigned-reg (inst sll value (* extra ,bits) - temp) + temp) (inst bis old temp old))) (inst stl old (- (* (+ word vector-data-offset) - n-word-bytes) + n-word-bytes) other-pointer-lowtag) object) (sc-case value @@ -298,39 +298,39 @@ (move value result)))))))))) (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg null zero) - + (def-partial-data-vector-frobs simple-base-string character :byte nil character-reg) #!+sb-unicode ; FIXME: what about when a word is 64 bits? (def-full-data-vector-frobs simple-character-string character character-reg) - + (def-partial-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum :byte nil unsigned-reg signed-reg) (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum :byte nil unsigned-reg signed-reg) - + (def-partial-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum :short nil unsigned-reg signed-reg) (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum :short nil unsigned-reg signed-reg) - + (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num unsigned-reg) (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num unsigned-reg) - + (def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num :byte t signed-reg) - + (def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num :short t signed-reg) - - (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum any-reg) + + (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum any-reg) (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg) - + (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num signed-reg) - + ;; Integer vectors whos elements are smaller than a byte. I.e. bit, ;; 2-bit, and 4-bit vectors. (def-small-data-vector-frobs simple-bit-vector 1) @@ -344,7 +344,7 @@ (:translate data-vector-ref) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg))) (:arg-types simple-array-single-float positive-fixnum) (:results (value :scs (single-reg))) (:result-types single-float) @@ -352,17 +352,17 @@ (:generator 20 (inst addq object index lip) (inst lds value - (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag) - lip))) + (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag) + lip))) (define-vop (data-vector-set/simple-array-single-float) (:note "inline array store") (:translate data-vector-set) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (single-reg) :target result)) + (index :scs (any-reg)) + (value :scs (single-reg) :target result)) (:arg-types simple-array-single-float positive-fixnum single-float) (:results (result :scs (single-reg))) (:result-types single-float) @@ -370,9 +370,9 @@ (:generator 20 (inst addq object index lip) (inst sts value - (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag) - lip) + (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag) + lip) (unless (location= result value) (inst fmove value result)))) @@ -381,7 +381,7 @@ (:translate data-vector-ref) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg))) (:arg-types simple-array-double-float positive-fixnum) (:results (value :scs (double-reg))) (:result-types double-float) @@ -390,17 +390,17 @@ (inst addq object index lip) (inst addq lip index lip) (inst ldt value - (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag) - lip))) + (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag) + lip))) (define-vop (data-vector-set/simple-array-double-float) (:note "inline array store") (:translate data-vector-set) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (double-reg) :target result)) + (index :scs (any-reg)) + (value :scs (double-reg) :target result)) (:arg-types simple-array-double-float positive-fixnum double-float) (:results (result :scs (double-reg))) (:result-types double-float) @@ -409,8 +409,8 @@ (inst addq object index lip) (inst addq lip index lip) (inst stt value - (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag) lip) + (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag) lip) (unless (location= result value) (inst fmove value result)))) @@ -421,7 +421,7 @@ (:translate data-vector-ref) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg))) (:arg-types simple-array-complex-single-float positive-fixnum) (:results (value :scs (complex-single-reg))) (:temporary (:scs (interior-reg)) lip) @@ -431,49 +431,49 @@ (inst addq object index lip) (inst addq lip index lip) (inst lds real-tn - (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - lip)) + (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + lip)) (let ((imag-tn (complex-single-reg-imag-tn value))) (inst lds imag-tn - (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag) - lip)))) + (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag) + lip)))) (define-vop (data-vector-set/simple-array-complex-single-float) (:note "inline array store") (:translate data-vector-set) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (complex-single-reg) :target result)) + (index :scs (any-reg)) + (value :scs (complex-single-reg) :target result)) (:arg-types simple-array-complex-single-float positive-fixnum - complex-single-float) + complex-single-float) (:results (result :scs (complex-single-reg))) (:result-types complex-single-float) (:temporary (:scs (interior-reg)) lip) (:generator 5 (let ((value-real (complex-single-reg-real-tn value)) - (result-real (complex-single-reg-real-tn result))) + (result-real (complex-single-reg-real-tn result))) (inst addq object index lip) (inst addq lip index lip) (inst sts value-real - (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - lip) + (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + lip) (unless (location= result-real value-real) - (inst fmove value-real result-real))) + (inst fmove value-real result-real))) (let ((value-imag (complex-single-reg-imag-tn value)) - (result-imag (complex-single-reg-imag-tn result))) + (result-imag (complex-single-reg-imag-tn result))) (inst sts value-imag - (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag) - lip) + (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag) + lip) (unless (location= result-imag value-imag) - (inst fmove value-imag result-imag))))) + (inst fmove value-imag result-imag))))) (define-vop (data-vector-ref/simple-array-complex-double-float) (:note "inline array access") (:translate data-vector-ref) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg))) (:arg-types simple-array-complex-double-float positive-fixnum) (:results (value :scs (complex-double-reg))) (:result-types complex-double-float) @@ -485,44 +485,44 @@ (inst addq lip index lip) (inst addq lip index lip) (inst ldt real-tn - (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - lip)) + (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + lip)) (let ((imag-tn (complex-double-reg-imag-tn value))) (inst ldt imag-tn - (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag) - lip)))) + (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag) + lip)))) (define-vop (data-vector-set/simple-array-complex-double-float) (:note "inline array store") (:translate data-vector-set) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs (complex-double-reg) :target result)) + (index :scs (any-reg)) + (value :scs (complex-double-reg) :target result)) (:arg-types simple-array-complex-double-float positive-fixnum - complex-double-float) + complex-double-float) (:results (result :scs (complex-double-reg))) (:result-types complex-double-float) (:temporary (:scs (interior-reg)) lip) (:generator 20 (let ((value-real (complex-double-reg-real-tn value)) - (result-real (complex-double-reg-real-tn result))) + (result-real (complex-double-reg-real-tn result))) (inst addq object index lip) (inst addq lip index lip) (inst addq lip index lip) (inst addq lip index lip) (inst stt value-real - (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - lip) + (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + lip) (unless (location= result-real value-real) - (inst fmove value-real result-real))) + (inst fmove value-real result-real))) (let ((value-imag (complex-double-reg-imag-tn value)) - (result-imag (complex-double-reg-imag-tn result))) + (result-imag (complex-double-reg-imag-tn result))) (inst stt value-imag - (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag) - lip) + (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag) + lip) (unless (location= result-imag value-imag) - (inst fmove value-imag result-imag))))) + (inst fmove value-imag result-imag))))) ;;; These VOPs are used for implementing float slots in structures @@ -545,22 +545,22 @@ (:arg-types sb!c::raw-vector positive-fixnum double-float)) (define-vop (raw-ref-complex-single - data-vector-ref/simple-array-complex-single-float) + data-vector-ref/simple-array-complex-single-float) (:translate %raw-ref-complex-single) (:arg-types sb!c::raw-vector positive-fixnum)) ;;; (define-vop (raw-set-complex-single - data-vector-set/simple-array-complex-single-float) + data-vector-set/simple-array-complex-single-float) (:translate %raw-set-complex-single) (:arg-types sb!c::raw-vector positive-fixnum complex-single-float)) ;;; (define-vop (raw-ref-complex-double - data-vector-ref/simple-array-complex-double-float) + data-vector-ref/simple-array-complex-double-float) (:translate %raw-ref-complex-double) (:arg-types sb!c::raw-vector positive-fixnum)) ;;; (define-vop (raw-set-complex-double - data-vector-set/simple-array-complex-double-float) + data-vector-set/simple-array-complex-double-float) (:translate %raw-set-complex-double) (:arg-types sb!c::raw-vector positive-fixnum complex-double-float)) diff --git a/src/compiler/alpha/c-call.lisp b/src/compiler/alpha/c-call.lisp index 6b3ead7..617c729 100644 --- a/src/compiler/alpha/c-call.lisp +++ b/src/compiler/alpha/c-call.lisp @@ -13,8 +13,8 @@ (defun my-make-wired-tn (prim-type-name sc-name offset) (make-wired-tn (primitive-type-or-lose prim-type-name ) - (sc-number-or-lose sc-name ) - offset)) + (sc-number-or-lose sc-name ) + offset)) (defstruct arg-state (stack-frame-size 0)) @@ -23,63 +23,63 @@ (let ((stack-frame-size (arg-state-stack-frame-size state))) (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) (multiple-value-bind - (ptype reg-sc stack-sc) - (if (alien-integer-type-signed type) - (values 'signed-byte-64 'signed-reg 'signed-stack) - (values 'unsigned-byte-64 'unsigned-reg 'unsigned-stack)) + (ptype reg-sc stack-sc) + (if (alien-integer-type-signed type) + (values 'signed-byte-64 'signed-reg 'signed-stack) + (values 'unsigned-byte-64 'unsigned-reg 'unsigned-stack)) (if (< stack-frame-size 4) - (my-make-wired-tn ptype reg-sc (+ stack-frame-size nl0-offset)) - (my-make-wired-tn ptype stack-sc (* 2 (- stack-frame-size 4))))))) + (my-make-wired-tn ptype reg-sc (+ stack-frame-size nl0-offset)) + (my-make-wired-tn ptype stack-sc (* 2 (- stack-frame-size 4))))))) (define-alien-type-method (system-area-pointer :arg-tn) (type state) (declare (ignore type)) (let ((stack-frame-size (arg-state-stack-frame-size state))) (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) (if (< stack-frame-size 4) - (my-make-wired-tn 'system-area-pointer - 'sap-reg - (+ stack-frame-size nl0-offset)) - (my-make-wired-tn 'system-area-pointer - 'sap-stack - (* 2 (- stack-frame-size 4)))))) + (my-make-wired-tn 'system-area-pointer + 'sap-reg + (+ stack-frame-size nl0-offset)) + (my-make-wired-tn 'system-area-pointer + 'sap-stack + (* 2 (- stack-frame-size 4)))))) (define-alien-type-method (double-float :arg-tn) (type state) (declare (ignore type)) (let ((stack-frame-size (arg-state-stack-frame-size state))) (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) (if (< stack-frame-size 6) - (my-make-wired-tn 'double-float - 'double-reg - (+ stack-frame-size nl0-offset)) - (my-make-wired-tn 'double-float - 'double-stack - (* 2 (- stack-frame-size 6)))))) + (my-make-wired-tn 'double-float + 'double-reg + (+ stack-frame-size nl0-offset)) + (my-make-wired-tn 'double-float + 'double-stack + (* 2 (- stack-frame-size 6)))))) (define-alien-type-method (single-float :arg-tn) (type state) (declare (ignore type)) (let ((stack-frame-size (arg-state-stack-frame-size state))) (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) (if (< stack-frame-size 6) - (my-make-wired-tn 'single-float - 'single-reg - (+ stack-frame-size nl0-offset)) - (my-make-wired-tn 'single-float - 'single-stack - (* 2 (- stack-frame-size 6)))))) + (my-make-wired-tn 'single-float + 'single-reg + (+ stack-frame-size nl0-offset)) + (my-make-wired-tn 'single-float + 'single-stack + (* 2 (- stack-frame-size 6)))))) (define-alien-type-method (integer :result-tn) (type state) (declare (ignore state)) (multiple-value-bind (ptype reg-sc) (if (alien-integer-type-signed type) - (values 'signed-byte-64 'signed-reg) - (values 'unsigned-byte-64 'unsigned-reg)) + (values 'signed-byte-64 'signed-reg) + (values 'unsigned-byte-64 'unsigned-reg)) (my-make-wired-tn ptype reg-sc lip-offset))) (define-alien-type-method (system-area-pointer :result-tn) (type state) (declare (ignore type state)) (my-make-wired-tn 'system-area-pointer 'sap-reg lip-offset)) - + (define-alien-type-method (double-float :result-tn) (type state) (declare (ignore type state)) (my-make-wired-tn 'double-float 'double-reg lip-offset)) @@ -99,13 +99,13 @@ (let ((arg-state (make-arg-state))) (collect ((arg-tns)) (dolist (arg-type (alien-fun-type-arg-types type)) - (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) + (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset) - (* (max (arg-state-stack-frame-size arg-state) 4) n-word-bytes) - (arg-tns) - (invoke-alien-type-method :result-tn - (alien-fun-type-result-type type) - nil))))) + (* (max (arg-state-stack-frame-size arg-state) 4) n-word-bytes) + (arg-tns) + (invoke-alien-type-method :result-tn + (alien-fun-type-result-type type) + nil))))) (define-vop (foreign-symbol-address) (:translate foreign-symbol-address) @@ -120,24 +120,24 @@ (define-vop (call-out) (:args (function :scs (sap-reg) :target cfunc) - (args :more t)) + (args :more t)) (:results (results :more t)) (:ignore args results) (:save-p t) (:temporary (:sc any-reg :offset cfunc-offset - :from (:argument 0) :to (:result 0)) cfunc) + :from (:argument 0) :to (:result 0)) cfunc) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) (:temporary (:scs (non-descriptor-reg)) temp) (:vop-var vop) (:generator 0 (let ((cur-nfp (sb!c::current-nfp-tn vop))) (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) + (store-stack-tn nfp-save cur-nfp)) (move function cfunc) (inst li (make-fixup "call_into_c" :foreign) temp) (inst jsr lip-tn temp (make-fixup "call_into_c" :foreign)) (when cur-nfp - (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))))) + (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))))) (define-vop (alloc-number-stack-space) (:info amount) @@ -146,11 +146,11 @@ (:generator 0 (unless (zerop amount) (let ((delta (logandc2 (+ amount 7) 7))) - (cond ((< delta (ash 1 15)) - (inst lda nsp-tn (- delta) nsp-tn)) - (t - (inst li delta temp) - (inst subq nsp-tn temp nsp-tn))))) + (cond ((< delta (ash 1 15)) + (inst lda nsp-tn (- delta) nsp-tn)) + (t + (inst li delta temp) + (inst subq nsp-tn temp nsp-tn))))) (move nsp-tn result))) (define-vop (dealloc-number-stack-space) @@ -160,8 +160,8 @@ (:generator 0 (unless (zerop amount) (let ((delta (logandc2 (+ amount 7) 7))) - (cond ((< delta (ash 1 15)) - (inst lda nsp-tn delta nsp-tn)) - (t - (inst li delta temp) - (inst addq nsp-tn temp nsp-tn))))))) + (cond ((< delta (ash 1 15)) + (inst lda nsp-tn delta nsp-tn)) + (t + (inst li delta temp) + (inst addq nsp-tn temp nsp-tn))))))) diff --git a/src/compiler/alpha/call.lisp b/src/compiler/alpha/call.lisp index fd82448..8a45345 100644 --- a/src/compiler/alpha/call.lisp +++ b/src/compiler/alpha/call.lisp @@ -19,10 +19,10 @@ (declare (type unsigned-byte n)) (if (< n register-arg-count) (make-wired-tn *backend-t-primitive-type* - register-arg-scn - (elt *register-arg-offsets* n)) + register-arg-scn + (elt *register-arg-offsets* n)) (make-wired-tn *backend-t-primitive-type* - control-stack-arg-scn n))) + control-stack-arg-scn n))) ;;; Make a passing location TN for a local call return PC. If standard @@ -51,8 +51,8 @@ (specify-save-tn (physenv-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) (make-wired-tn *fixnum-primitive-type* - control-stack-arg-scn - ocfp-save-offset))) + control-stack-arg-scn + ocfp-save-offset))) (!def-vm-support-routine make-return-pc-save-location (env) (let ((ptype *backend-t-primitive-type*)) (specify-save-tn @@ -82,7 +82,7 @@ ;;; unknown-values continuation within a function. (!def-vm-support-routine make-unknown-values-locations () (list (make-stack-pointer-tn) - (make-normal-tn *fixnum-primitive-type*))) + (make-normal-tn *fixnum-primitive-type*))) ;;; This function is called by the ENTRY-ANALYZE phase, allowing @@ -93,7 +93,7 @@ (declare (type component component)) (dotimes (i code-constants-offset) (vector-push-extend nil - (ir2-component-constants (component-info component)))) + (ir2-component-constants (component-info component)))) (values)) @@ -121,7 +121,7 @@ (:generator 1 (let ((nfp (current-nfp-tn vop))) (when nfp - (inst addq nfp (bytes-needed-for-non-descriptor-stack-frame) val))))) + (inst addq nfp (bytes-needed-for-non-descriptor-stack-frame) val))))) (define-vop (xep-allocate-frame) (:info start-lab copy-more-arg-follows) @@ -148,30 +148,30 @@ ) ;; Build our stack frames. (inst lda - csp-tn - (* n-word-bytes (sb-allocated-size 'control-stack)) - cfp-tn) + csp-tn + (* n-word-bytes (sb-allocated-size 'control-stack)) + cfp-tn) (let ((nfp (current-nfp-tn vop))) (when nfp - (inst subq nsp-tn (bytes-needed-for-non-descriptor-stack-frame) - nsp-tn) - (move nsp-tn nfp))) + (inst subq nsp-tn (bytes-needed-for-non-descriptor-stack-frame) + nsp-tn) + (move nsp-tn nfp))) (trace-table-entry trace-table-normal))) (define-vop (allocate-frame) (:results (res :scs (any-reg)) - (nfp :scs (any-reg))) + (nfp :scs (any-reg))) (:info callee) (:generator 2 (trace-table-entry trace-table-fun-prologue) (move csp-tn res) (inst lda - csp-tn - (* n-word-bytes (sb-allocated-size 'control-stack)) - csp-tn) + csp-tn + (* n-word-bytes (sb-allocated-size 'control-stack)) + csp-tn) (when (ir2-physenv-number-stack-p callee) (inst subq nsp-tn (bytes-needed-for-non-descriptor-stack-frame) - nsp-tn) + nsp-tn) (move nsp-tn nfp)) (trace-table-entry trace-table-normal))) @@ -213,120 +213,120 @@ ;;; ;;; The general-case code looks like this: #| - b regs-defaulted ; Skip if MVs - nop + b regs-defaulted ; Skip if MVs + nop - move a1 null-tn ; Default register values - ... - loadi nargs 1 ; Force defaulting of stack values - move ocfp csp ; Set up args for SP resetting + move a1 null-tn ; Default register values + ... + loadi nargs 1 ; Force defaulting of stack values + move ocfp csp ; Set up args for SP resetting regs-defaulted - subu temp nargs register-arg-count + subu temp nargs register-arg-count - bltz temp default-value-7 ; jump to default code + bltz temp default-value-7 ; jump to default code addu temp temp -1 - loadw move-temp ocfp-tn 6 ; Move value to correct location. - store-stack-tn val4-tn move-temp + loadw move-temp ocfp-tn 6 ; Move value to correct location. + store-stack-tn val4-tn move-temp - bltz temp default-value-8 + bltz temp default-value-8 addu temp temp -1 - loadw move-temp ocfp-tn 7 - store-stack-tn val5-tn move-temp + loadw move-temp ocfp-tn 7 + store-stack-tn val5-tn move-temp - ... + ... defaulting-done - move sp ocfp ; Reset SP. + move sp ocfp ; Reset SP. default-value-7 - store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack) + store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack) default-value-8 - store-stack-tn val5-tn null-tn ; Nil out 8'th value. + store-stack-tn val5-tn null-tn ; Nil out 8'th value. - ... + ... - br defaulting-done + br defaulting-done nop |# (defun default-unknown-values (vop values nvals move-temp temp lra-label) (declare (type (or tn-ref null) values) - (type unsigned-byte nvals) (type tn move-temp temp)) + (type unsigned-byte nvals) (type tn move-temp temp)) (if (<= nvals 1) (progn - ;; Note that this is a single-value return point. This is - ;; actually the multiple-value entry point for a single - ;; desired value, but the code location has to be here, or the - ;; debugger backtrace gets confused. - (without-scheduling () - (note-this-location vop :single-value-return) - (move ocfp-tn csp-tn) - (inst nop)) - (when lra-label - (inst compute-code-from-lra code-tn code-tn lra-label temp))) + ;; Note that this is a single-value return point. This is + ;; actually the multiple-value entry point for a single + ;; desired value, but the code location has to be here, or the + ;; debugger backtrace gets confused. + (without-scheduling () + (note-this-location vop :single-value-return) + (move ocfp-tn csp-tn) + (inst nop)) + (when lra-label + (inst compute-code-from-lra code-tn code-tn lra-label temp))) (let ((regs-defaulted (gen-label)) - (defaulting-done (gen-label)) - (default-stack-vals (gen-label))) - (without-scheduling () - ;; Note that this is an unknown-values return point. - (note-this-location vop :unknown-return) - ;; If there are no stack results, clear the stack now. - (if (> nvals register-arg-count) - (inst subq nargs-tn (fixnumize register-arg-count) temp) - (move ocfp-tn csp-tn)) - ;; Branch off to the MV case. - (inst br zero-tn regs-defaulted)) - - ;; Do the single value case. - (do ((i 1 (1+ i)) - (val (tn-ref-across values) (tn-ref-across val))) - ((= i (min nvals register-arg-count))) - (move null-tn (tn-ref-tn val))) - (when (> nvals register-arg-count) - (move csp-tn ocfp-tn) - (inst br zero-tn default-stack-vals)) - - (emit-label regs-defaulted) - - (when (> nvals register-arg-count) - ;; If there are stack results, we have to default them - ;; and clear the stack. - (collect ((defaults)) - (do ((i register-arg-count (1+ i)) - (val (do ((i 0 (1+ i)) - (val values (tn-ref-across val))) - ((= i register-arg-count) val)) - (tn-ref-across val))) - ((null val)) - - (let ((default-lab (gen-label)) - (tn (tn-ref-tn val))) - (defaults (cons default-lab tn)) - - (inst ble temp default-lab) - (inst ldl move-temp (* i n-word-bytes) ocfp-tn) - (inst subq temp (fixnumize 1) temp) - (store-stack-tn tn move-temp))) - - (emit-label defaulting-done) - (move ocfp-tn csp-tn) - - (let ((defaults (defaults))) - (aver defaults) - (assemble (*elsewhere*) - (emit-label default-stack-vals) - (do ((remaining defaults (cdr remaining))) - ((null remaining)) - (let ((def (car remaining))) - (emit-label (car def)) - (store-stack-tn (cdr def) null-tn))) - (inst br zero-tn defaulting-done))))) - - (when lra-label - (inst compute-code-from-lra code-tn code-tn lra-label temp)))) + (defaulting-done (gen-label)) + (default-stack-vals (gen-label))) + (without-scheduling () + ;; Note that this is an unknown-values return point. + (note-this-location vop :unknown-return) + ;; If there are no stack results, clear the stack now. + (if (> nvals register-arg-count) + (inst subq nargs-tn (fixnumize register-arg-count) temp) + (move ocfp-tn csp-tn)) + ;; Branch off to the MV case. + (inst br zero-tn regs-defaulted)) + + ;; Do the single value case. + (do ((i 1 (1+ i)) + (val (tn-ref-across values) (tn-ref-across val))) + ((= i (min nvals register-arg-count))) + (move null-tn (tn-ref-tn val))) + (when (> nvals register-arg-count) + (move csp-tn ocfp-tn) + (inst br zero-tn default-stack-vals)) + + (emit-label regs-defaulted) + + (when (> nvals register-arg-count) + ;; If there are stack results, we have to default them + ;; and clear the stack. + (collect ((defaults)) + (do ((i register-arg-count (1+ i)) + (val (do ((i 0 (1+ i)) + (val values (tn-ref-across val))) + ((= i register-arg-count) val)) + (tn-ref-across val))) + ((null val)) + + (let ((default-lab (gen-label)) + (tn (tn-ref-tn val))) + (defaults (cons default-lab tn)) + + (inst ble temp default-lab) + (inst ldl move-temp (* i n-word-bytes) ocfp-tn) + (inst subq temp (fixnumize 1) temp) + (store-stack-tn tn move-temp))) + + (emit-label defaulting-done) + (move ocfp-tn csp-tn) + + (let ((defaults (defaults))) + (aver defaults) + (assemble (*elsewhere*) + (emit-label default-stack-vals) + (do ((remaining defaults (cdr remaining))) + ((null remaining)) + (let ((def (car remaining))) + (emit-label (car def)) + (store-stack-tn (cdr def) null-tn))) + (inst br zero-tn defaulting-done))))) + + (when lra-label + (inst compute-code-from-lra code-tn code-tn lra-label temp)))) (values)) ;;;; unknown values receiving @@ -351,7 +351,7 @@ default-value-8 (defun receive-unknown-values (args nargs start count lra-label temp) (declare (type tn args nargs start count temp)) (let ((variable-values (gen-label)) - (done (gen-label))) + (done (gen-label))) (without-scheduling () (inst br zero-tn variable-values) (inst nop)) @@ -362,17 +362,17 @@ default-value-8 (storew (first *register-arg-tns*) csp-tn -1) (inst subq csp-tn 4 start) (inst li (fixnumize 1) count) - + (emit-label done) - + (assemble (*elsewhere*) (emit-label variable-values) (when lra-label - (inst compute-code-from-lra code-tn code-tn lra-label temp)) + (inst compute-code-from-lra code-tn code-tn lra-label temp)) (do ((arg *register-arg-tns* (rest arg)) - (i 0 (1+ i))) - ((null arg)) - (storew (first arg) args i)) + (i 0 (1+ i))) + ((null arg)) + (storew (first arg) args i)) (move args start) (move nargs count) (inst br zero-tn done))) @@ -385,11 +385,11 @@ default-value-8 (start :scs (any-reg)) (count :scs (any-reg))) (:temporary (:sc descriptor-reg :offset ocfp-offset - :from :eval :to (:result 0)) - values-start) + :from :eval :to (:result 0)) + values-start) (:temporary (:sc any-reg :offset nargs-offset - :from :eval :to (:result 1)) - nvals) + :from :eval :to (:result 1)) + nvals) (:temporary (:scs (non-descriptor-reg)) temp)) ;;;; local call with unknown values convention return @@ -413,8 +413,8 @@ default-value-8 ;;; we use MAYBE-LOAD-STACK-TN. (define-vop (call-local) (:args (fp) - (nfp) - (args :more t)) + (nfp) + (args :more t)) (:results (values :more t)) (:save-p t) (:move-args :local-call) @@ -427,15 +427,15 @@ default-value-8 (:ignore arg-locs args ocfp) (:generator 5 (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) + (cur-nfp (current-nfp-tn vop))) (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) + (store-stack-tn nfp-save cur-nfp)) (let ((callee-nfp (callee-nfp-tn callee))) - (maybe-load-stack-nfp-tn callee-nfp nfp temp)) + (maybe-load-stack-nfp-tn callee-nfp nfp temp)) (maybe-load-stack-tn cfp-tn fp) (trace-table-entry trace-table-call-site) (inst compute-lra-from-code - (callee-return-pc-tn callee) code-tn label temp) + (callee-return-pc-tn callee) code-tn label temp) (note-this-location vop :call-site) (inst br zero-tn target) (trace-table-entry trace-table-normal) @@ -453,8 +453,8 @@ default-value-8 ;;; we use MAYBE-LOAD-STACK-TN. (define-vop (multiple-call-local unknown-values-receiver) (:args (fp) - (nfp) - (args :more t)) + (nfp) + (args :more t)) (:save-p t) (:move-args :local-call) (:info save callee target) @@ -464,15 +464,15 @@ default-value-8 (:temporary (:scs (non-descriptor-reg)) temp) (:generator 20 (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) + (cur-nfp (current-nfp-tn vop))) (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) + (store-stack-tn nfp-save cur-nfp)) (let ((callee-nfp (callee-nfp-tn callee))) - (maybe-load-stack-nfp-tn callee-nfp nfp temp)) + (maybe-load-stack-nfp-tn callee-nfp nfp temp)) (maybe-load-stack-tn cfp-tn fp) (trace-table-entry trace-table-call-site) (inst compute-lra-from-code - (callee-return-pc-tn callee) code-tn label temp) + (callee-return-pc-tn callee) code-tn label temp) (note-this-location vop :call-site) (inst bsr zero-tn target) (trace-table-entry trace-table-normal) @@ -492,8 +492,8 @@ default-value-8 ;;; MAYBE-LOAD-STACK-TN. (define-vop (known-call-local) (:args (fp) - (nfp) - (args :more t)) + (nfp) + (args :more t)) (:results (res :more t)) (:move-args :local-call) (:save-p t) @@ -504,15 +504,15 @@ default-value-8 (:temporary (:scs (non-descriptor-reg)) temp) (:generator 5 (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) + (cur-nfp (current-nfp-tn vop))) (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) + (store-stack-tn nfp-save cur-nfp)) (let ((callee-nfp (callee-nfp-tn callee))) - (maybe-load-stack-nfp-tn callee-nfp nfp temp)) + (maybe-load-stack-nfp-tn callee-nfp nfp temp)) (maybe-load-stack-tn cfp-tn fp) (trace-table-entry trace-table-call-site) (inst compute-lra-from-code - (callee-return-pc-tn callee) code-tn label temp) + (callee-return-pc-tn callee) code-tn label temp) (note-this-location vop :call-site) (inst bsr zero-tn target) (trace-table-entry trace-table-normal) @@ -529,11 +529,11 @@ default-value-8 ;;; we use MAYBE-LOAD-STACK-TN. (define-vop (known-return) (:args (ocfp :target ocfp-temp) - (return-pc :target return-pc-temp) - (vals :more t)) + (return-pc :target return-pc-temp) + (vals :more t)) (:temporary (:sc any-reg :from (:argument 0)) ocfp-temp) (:temporary (:sc any-reg :from (:argument 1)) - return-pc-temp) + return-pc-temp) (:temporary (:scs (interior-reg)) lip) (:move-args :known-return) (:info val-locs) @@ -546,8 +546,8 @@ default-value-8 (move cfp-tn csp-tn) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp - (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) - nsp-tn))) + (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) + nsp-tn))) (inst subq return-pc-temp (- other-pointer-lowtag n-word-bytes) lip) (move ocfp-temp cfp-tn) (inst ret zero-tn lip 1) @@ -570,14 +570,14 @@ default-value-8 ;;; code replication in defining the cross-product VOPs. ;;; ;;; Name is the name of the VOP to define. -;;; +;;; ;;; Named is true if the first argument is a symbol whose global ;;; function definition is to be called. ;;; ;;; Return is either :FIXED, :UNKNOWN or :TAIL: ;;; -- If :FIXED, then the call is for a fixed number of values, returned ;;; in the standard passing locations (passed as result operands). -;;; -- If :UNKNOWN, then the result values are pushed on the stack, and +;;; -- If :UNKNOWN, then the result values are pushed on the stack, and ;;; the result values are specified by the Start and Count as in the ;;; unknown-values continuation representation. ;;; -- If :TAIL, then do a tail-recursive call. No values are returned. @@ -596,232 +596,232 @@ default-value-8 (defmacro define-full-call (name named return variable) (aver (not (and variable (eq return :tail)))) `(define-vop (,name - ,@(when (eq return :unknown) - '(unknown-values-receiver))) + ,@(when (eq return :unknown) + '(unknown-values-receiver))) (:args ,@(unless (eq return :tail) - '((new-fp :scs (any-reg) :to :eval))) + '((new-fp :scs (any-reg) :to :eval))) ,(if named - '(name :target name-pass) - '(arg-fun :target lexenv)) - + '(name :target name-pass) + '(arg-fun :target lexenv)) + ,@(when (eq return :tail) - '((ocfp :target ocfp-pass) - (return-pc :target return-pc-pass))) - + '((ocfp :target ocfp-pass) + (return-pc :target return-pc-pass))) + ,@(unless variable '((args :more t :scs (descriptor-reg))))) ,@(when (eq return :fixed) - '((:results (values :more t)))) - + '((:results (values :more t)))) + (:save-p ,(if (eq return :tail) :compute-only t)) ,@(unless (or (eq return :tail) variable) - '((:move-args :full-call))) + '((:move-args :full-call))) (:vop-var vop) (:info ,@(unless (or variable (eq return :tail)) '(arg-locs)) - ,@(unless variable '(nargs)) - ,@(when (eq return :fixed) '(nvals))) + ,@(unless variable '(nargs)) + ,@(when (eq return :fixed) '(nvals))) (:ignore #!+gengc ,@(unless (eq return :tail) '(return-pc-pass)) - ,@(unless (or variable (eq return :tail)) '(arg-locs)) - ,@(unless variable '(args))) + ,@(unless (or variable (eq return :tail)) '(arg-locs)) + ,@(unless variable '(args))) (:temporary (:sc descriptor-reg - :offset ocfp-offset - :from (:argument 1) - ,@(unless (eq return :fixed) - '(:to :eval))) - ocfp-pass) + :offset ocfp-offset + :from (:argument 1) + ,@(unless (eq return :fixed) + '(:to :eval))) + ocfp-pass) (:temporary (:sc descriptor-reg - :offset #!-gengc lra-offset #!+gengc ra-offset - :from (:argument ,(if (eq return :tail) 2 1)) - :to :eval) - return-pc-pass) + :offset #!-gengc lra-offset #!+gengc ra-offset + :from (:argument ,(if (eq return :tail) 2 1)) + :to :eval) + return-pc-pass) ,@(if named - `((:temporary (:sc descriptor-reg :offset fdefn-offset - :from (:argument ,(if (eq return :tail) 0 1)) - :to :eval) - name-pass)) - - `((:temporary (:sc descriptor-reg :offset lexenv-offset - :from (:argument ,(if (eq return :tail) 0 1)) - :to :eval) - lexenv) - #!-gengc - (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval) - function))) + `((:temporary (:sc descriptor-reg :offset fdefn-offset + :from (:argument ,(if (eq return :tail) 0 1)) + :to :eval) + name-pass)) + + `((:temporary (:sc descriptor-reg :offset lexenv-offset + :from (:argument ,(if (eq return :tail) 0 1)) + :to :eval) + lexenv) + #!-gengc + (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval) + function))) (:temporary (:sc any-reg :offset nargs-offset :to :eval) - nargs-pass) + nargs-pass) ,@(when variable - (mapcar (lambda (name offset) - `(:temporary (:sc descriptor-reg - :offset ,offset - :to :eval) - ,name)) - register-arg-names *register-arg-offsets*)) + (mapcar (lambda (name offset) + `(:temporary (:sc descriptor-reg + :offset ,offset + :to :eval) + ,name)) + register-arg-names *register-arg-offsets*)) ,@(when (eq return :fixed) - '((:temporary (:scs (descriptor-reg) :from :eval) move-temp))) + '((:temporary (:scs (descriptor-reg) :from :eval) move-temp))) ,@(unless (eq return :tail) - '((:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))) + '((:temporary (:scs (non-descriptor-reg)) temp) + (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))) (:temporary (:sc interior-reg :offset lip-offset) entry-point) (:generator ,(+ (if named 5 0) - (if variable 19 1) - (if (eq return :tail) 0 10) - 15 - (if (eq return :unknown) 25 0)) + (if variable 19 1) + (if (eq return :tail) 0 10) + 15 + (if (eq return :unknown) 25 0)) (let* ((cur-nfp (current-nfp-tn vop)) - ,@(unless (eq return :tail) - '((lra-label (gen-label)))) - (filler - (remove nil - (list :load-nargs - ,@(if (eq return :tail) - '((unless (location= ocfp ocfp-pass) - :load-ocfp) - (unless (location= return-pc - return-pc-pass) - :load-return-pc) - (when cur-nfp - :frob-nfp)) - '(#!-gengc - :comp-lra - (when cur-nfp - :frob-nfp) - :save-fp - :load-fp)))))) - (flet ((do-next-filler () - (let* ((next (pop filler)) - (what (if (consp next) (car next) next))) - (ecase what - (:load-nargs - ,@(if variable - `((inst subq csp-tn new-fp nargs-pass) - ,@(let ((index -1)) - (mapcar (lambda (name) - `(inst ldl ,name - ,(ash (incf index) - word-shift) - new-fp)) - register-arg-names))) - '((inst li (fixnumize nargs) nargs-pass)))) - ,@(if (eq return :tail) - '((:load-ocfp - (sc-case ocfp - (any-reg - (inst move ocfp ocfp-pass)) - (control-stack - (inst ldl ocfp-pass - (ash (tn-offset ocfp) - word-shift) - cfp-tn)))) - (:load-return-pc - (sc-case return-pc - (#!-gengc descriptor-reg #!+gengc any-reg - (inst move return-pc return-pc-pass)) - (control-stack - (inst ldl return-pc-pass - (ash (tn-offset return-pc) - word-shift) - cfp-tn)))) - (:frob-nfp - (inst addq cur-nfp - (bytes-needed-for-non-descriptor-stack-frame) - nsp-tn))) - `(#!-gengc - (:comp-lra - (inst compute-lra-from-code - return-pc-pass code-tn lra-label temp)) - (:frob-nfp - (store-stack-tn nfp-save cur-nfp)) - (:save-fp - (inst move cfp-tn ocfp-pass)) - (:load-fp - ,(if variable - '(move new-fp cfp-tn) - '(if (> nargs register-arg-count) - (move new-fp cfp-tn) - (move csp-tn cfp-tn))) - (trace-table-entry trace-table-call-site)))) - ((nil)))))) - - ,@(if named - `((sc-case name - (descriptor-reg (move name name-pass)) - (control-stack - (inst ldl name-pass - (ash (tn-offset name) word-shift) cfp-tn) - (do-next-filler)) - (constant - (inst ldl name-pass - (- (ash (tn-offset name) word-shift) - other-pointer-lowtag) code-tn) - (do-next-filler))) - (inst ldl entry-point - (- (ash fdefn-raw-addr-slot word-shift) - other-pointer-lowtag) name-pass) - (do-next-filler)) - `((sc-case arg-fun - (descriptor-reg (move arg-fun lexenv)) - (control-stack - (inst ldl lexenv - (ash (tn-offset arg-fun) word-shift) cfp-tn) - (do-next-filler)) - (constant - (inst ldl lexenv - (- (ash (tn-offset arg-fun) word-shift) - other-pointer-lowtag) code-tn) - (do-next-filler))) - #!-gengc - (inst ldl function - (- (ash closure-fun-slot word-shift) - fun-pointer-lowtag) lexenv) - #!-gengc - (do-next-filler) - #!-gengc - (inst addq function - (- (ash simple-fun-code-offset word-shift) - fun-pointer-lowtag) entry-point) - #!+gengc - (inst ldl entry-point - (- (ash closure-entry-point-slot word-shift) - fun-pointer-lowtag) lexenv) - #!+gengc - (do-next-filler))) - (loop - (if (cdr filler) - (do-next-filler) - (return))) - - (note-this-location vop :call-site) - (do-next-filler) - (inst jsr zero-tn entry-point)) - - ,@(ecase return - (:fixed - '((trace-table-entry trace-table-normal) - (emit-return-pc lra-label) - (default-unknown-values vop values nvals - move-temp temp lra-label) - (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))) - (:unknown - '((trace-table-entry trace-table-normal) - (emit-return-pc lra-label) - (note-this-location vop :unknown-return) - (receive-unknown-values values-start nvals start count - lra-label temp) - (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))) - (:tail)))))) + ,@(unless (eq return :tail) + '((lra-label (gen-label)))) + (filler + (remove nil + (list :load-nargs + ,@(if (eq return :tail) + '((unless (location= ocfp ocfp-pass) + :load-ocfp) + (unless (location= return-pc + return-pc-pass) + :load-return-pc) + (when cur-nfp + :frob-nfp)) + '(#!-gengc + :comp-lra + (when cur-nfp + :frob-nfp) + :save-fp + :load-fp)))))) + (flet ((do-next-filler () + (let* ((next (pop filler)) + (what (if (consp next) (car next) next))) + (ecase what + (:load-nargs + ,@(if variable + `((inst subq csp-tn new-fp nargs-pass) + ,@(let ((index -1)) + (mapcar (lambda (name) + `(inst ldl ,name + ,(ash (incf index) + word-shift) + new-fp)) + register-arg-names))) + '((inst li (fixnumize nargs) nargs-pass)))) + ,@(if (eq return :tail) + '((:load-ocfp + (sc-case ocfp + (any-reg + (inst move ocfp ocfp-pass)) + (control-stack + (inst ldl ocfp-pass + (ash (tn-offset ocfp) + word-shift) + cfp-tn)))) + (:load-return-pc + (sc-case return-pc + (#!-gengc descriptor-reg #!+gengc any-reg + (inst move return-pc return-pc-pass)) + (control-stack + (inst ldl return-pc-pass + (ash (tn-offset return-pc) + word-shift) + cfp-tn)))) + (:frob-nfp + (inst addq cur-nfp + (bytes-needed-for-non-descriptor-stack-frame) + nsp-tn))) + `(#!-gengc + (:comp-lra + (inst compute-lra-from-code + return-pc-pass code-tn lra-label temp)) + (:frob-nfp + (store-stack-tn nfp-save cur-nfp)) + (:save-fp + (inst move cfp-tn ocfp-pass)) + (:load-fp + ,(if variable + '(move new-fp cfp-tn) + '(if (> nargs register-arg-count) + (move new-fp cfp-tn) + (move csp-tn cfp-tn))) + (trace-table-entry trace-table-call-site)))) + ((nil)))))) + + ,@(if named + `((sc-case name + (descriptor-reg (move name name-pass)) + (control-stack + (inst ldl name-pass + (ash (tn-offset name) word-shift) cfp-tn) + (do-next-filler)) + (constant + (inst ldl name-pass + (- (ash (tn-offset name) word-shift) + other-pointer-lowtag) code-tn) + (do-next-filler))) + (inst ldl entry-point + (- (ash fdefn-raw-addr-slot word-shift) + other-pointer-lowtag) name-pass) + (do-next-filler)) + `((sc-case arg-fun + (descriptor-reg (move arg-fun lexenv)) + (control-stack + (inst ldl lexenv + (ash (tn-offset arg-fun) word-shift) cfp-tn) + (do-next-filler)) + (constant + (inst ldl lexenv + (- (ash (tn-offset arg-fun) word-shift) + other-pointer-lowtag) code-tn) + (do-next-filler))) + #!-gengc + (inst ldl function + (- (ash closure-fun-slot word-shift) + fun-pointer-lowtag) lexenv) + #!-gengc + (do-next-filler) + #!-gengc + (inst addq function + (- (ash simple-fun-code-offset word-shift) + fun-pointer-lowtag) entry-point) + #!+gengc + (inst ldl entry-point + (- (ash closure-entry-point-slot word-shift) + fun-pointer-lowtag) lexenv) + #!+gengc + (do-next-filler))) + (loop + (if (cdr filler) + (do-next-filler) + (return))) + + (note-this-location vop :call-site) + (do-next-filler) + (inst jsr zero-tn entry-point)) + + ,@(ecase return + (:fixed + '((trace-table-entry trace-table-normal) + (emit-return-pc lra-label) + (default-unknown-values vop values nvals + move-temp temp lra-label) + (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))) + (:unknown + '((trace-table-entry trace-table-normal) + (emit-return-pc lra-label) + (note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count + lra-label temp) + (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))) + (:tail)))))) (define-full-call call nil :fixed nil) (define-full-call call-named t :fixed nil) @@ -846,7 +846,7 @@ default-value-8 (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv) (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) ocfp) (:temporary (:sc any-reg :offset #!-gengc lra-offset #!+gengc ra-offset - :from (:argument 3)) lra) + :from (:argument 3)) lra) (:temporary (:scs (non-descriptor-reg)) temp) (:vop-var vop) @@ -862,8 +862,8 @@ default-value-8 ;; Clear the number stack if anything is there. (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp - (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) - nsp-tn))) + (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) + nsp-tn))) ;; And jump to the assembly-routine that does the bliting. (inst li (make-fixup 'tail-call-variable :assembly-routine) temp) @@ -874,9 +874,9 @@ default-value-8 ;;; Return a single value using the unknown-values convention. (define-vop (return-single) (:args (ocfp :scs (any-reg)) - #!-gengc (return-pc :scs (descriptor-reg)) - #!+gengc (return-pc :scs (any-reg) :target ra) - (value)) + #!-gengc (return-pc :scs (descriptor-reg)) + #!+gengc (return-pc :scs (any-reg) :target ra) + (value)) (:ignore value) #!-gengc (:temporary (:scs (interior-reg)) lip) #!+gengc (:temporary (:sc any-reg :offset ra-offset :from (:argument 1)) ra) @@ -887,8 +887,8 @@ default-value-8 (trace-table-entry trace-table-fun-epilogue) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp - (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) - nsp-tn))) + (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) + nsp-tn))) ;; Clear the control stack, and restore the frame pointer. (move cfp-tn csp-tn) (move ocfp cfp-tn) @@ -898,7 +898,7 @@ default-value-8 (progn (inst addq return-pc (* 2 n-word-bytes) temp) (unless (location= ra return-pc) - (inst move ra return-pc)) + (inst move ra return-pc)) (inst ret zero-tn temp 1)) (trace-table-entry trace-table-normal))) @@ -916,10 +916,10 @@ default-value-8 ;;; values block (which is the beginning of the current frame.) (define-vop (return) (:args (ocfp :scs (any-reg)) - (return-pc :scs (#!-gengc descriptor-reg #!+gengc any-reg) - :to (:eval 1) - #!+gengc :target #!+gengc ra) - (values :more t)) + (return-pc :scs (#!-gengc descriptor-reg #!+gengc any-reg) + :to (:eval 1) + #!+gengc :target #!+gengc ra) + (values :more t)) (:ignore values) (:info nvals) (:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0) @@ -938,8 +938,8 @@ default-value-8 (trace-table-entry trace-table-fun-epilogue) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp - (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) - nsp-tn))) + (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) + nsp-tn))) ;; Establish the values pointer and values count. (move cfp-tn val-ptr) (inst li (fixnumize nvals) nargs) @@ -955,7 +955,7 @@ default-value-8 ;; pre-default any argument register that need it. (when (< nvals register-arg-count) (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals)) - (move null-tn reg))) + (move null-tn reg))) ;; And away we go. (lisp-return return-pc lip) (trace-table-entry trace-table-normal))) @@ -967,10 +967,10 @@ default-value-8 ;;; assembly-routine. (define-vop (return-multiple) (:args (ocfp-arg :scs (any-reg) :target ocfp) - #!-gengc (lra-arg :scs (descriptor-reg) :target lra) - #!+gengc (return-pc :scs (any-reg) :target ra) - (vals-arg :scs (any-reg) :target vals) - (nvals-arg :scs (any-reg) :target nvals)) + #!-gengc (lra-arg :scs (descriptor-reg) :target lra) + #!+gengc (return-pc :scs (any-reg) :target ra) + (vals-arg :scs (any-reg) :target vals) + (nvals-arg :scs (any-reg) :target nvals)) (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) ocfp) #!-gengc @@ -991,9 +991,9 @@ default-value-8 (let ((not-single (gen-label))) ;; Clear the number stack. (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) - nsp-tn))) + (when cur-nfp + (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame) + nsp-tn))) ;; Check for the single case. (inst li (fixnumize 1) a0) @@ -1005,7 +1005,7 @@ default-value-8 (move cfp-tn csp-tn) (move ocfp-arg cfp-tn) (lisp-return lra-arg lip :offset 2) - + ;; Nope, not the single case. (emit-label not-single) (move ocfp-arg ocfp) @@ -1029,8 +1029,8 @@ default-value-8 ;;; Get the lexical environment from its passing location. (define-vop (setup-closure-environment) (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure - :to (:result 0)) - lexenv) + :to (:result 0)) + lexenv) (:results (closure :scs (descriptor-reg))) (:info label) (:ignore label) @@ -1049,25 +1049,25 @@ default-value-8 (:info fixed) (:generator 20 (let ((loop (gen-label)) - (do-regs (gen-label)) - (done (gen-label))) + (do-regs (gen-label)) + (done (gen-label))) (when (< fixed register-arg-count) - ;; Save a pointer to the results so we can fill in register - ;; args. We don't need this if there are more fixed args than - ;; reg args. - (move csp-tn result)) + ;; Save a pointer to the results so we can fill in register + ;; args. We don't need this if there are more fixed args than + ;; reg args. + (move csp-tn result)) ;; Allocate the space on the stack. (cond ((zerop fixed) - (inst addq csp-tn nargs-tn csp-tn) - (inst beq nargs-tn done)) - (t - (inst subq nargs-tn (fixnumize fixed) count) - (inst ble count done) - (inst addq csp-tn count csp-tn))) + (inst addq csp-tn nargs-tn csp-tn) + (inst beq nargs-tn done)) + (t + (inst subq nargs-tn (fixnumize fixed) count) + (inst ble count done) + (inst addq csp-tn count csp-tn))) (when (< fixed register-arg-count) - ;; We must stop when we run out of stack args, not when we run - ;; out of &MORE args. - (inst subq nargs-tn (fixnumize register-arg-count) count)) + ;; We must stop when we run out of stack args, not when we run + ;; out of &MORE args. + (inst subq nargs-tn (fixnumize register-arg-count) count)) ;; Initialize dst to be end of stack. (move csp-tn dst) ;; Everything of interest in registers. @@ -1086,18 +1086,18 @@ default-value-8 (emit-label do-regs) (when (< fixed register-arg-count) - ;; Now we have to deposit any more args that showed up in - ;; registers. We know there is at least one &MORE arg, - ;; otherwise we would have branched to DONE up at the top. - (inst subq nargs-tn (fixnumize (1+ fixed)) count) - (do ((i fixed (1+ i))) - ((>= i register-arg-count)) - ;; Store it relative to the pointer saved at the start. - (storew (nth i *register-arg-tns*) result (- i fixed)) - ;; Is this the last one? - (inst beq count done) - ;; Decrement count. - (inst subq count (fixnumize 1) count))) + ;; Now we have to deposit any more args that showed up in + ;; registers. We know there is at least one &MORE arg, + ;; otherwise we would have branched to DONE up at the top. + (inst subq nargs-tn (fixnumize (1+ fixed)) count) + (do ((i fixed (1+ i))) + ((>= i register-arg-count)) + ;; Store it relative to the pointer saved at the start. + (storew (nth i *register-arg-tns*) result (- i fixed)) + ;; Is this the last one? + (inst beq count done) + ;; Decrement count. + (inst subq count (fixnumize 1) count))) (emit-label done)))) ;;; &MORE args are stored consecutively on the stack, starting @@ -1111,7 +1111,7 @@ default-value-8 (define-vop (listify-rest-args) (:args (context-arg :target context :scs (descriptor-reg)) - (count-arg :target count :scs (any-reg))) + (count-arg :target count :scs (any-reg))) (:arg-types * tagged-num) (:temporary (:scs (any-reg) :from (:argument 0)) context) (:temporary (:scs (any-reg) :from (:argument 1)) count) @@ -1136,32 +1136,32 @@ default-value-8 (pseudo-atomic () ;; align CSP (when dx-p (align-csp temp)) - ;; Allocate a cons (2 words) for each item. - (inst bis alloc-area-tn list-pointer-lowtag result) - (move result dst) - (inst sll count 1 temp) - (inst addq alloc-area-tn temp alloc-area-tn) - (inst br zero-tn enter) - - ;; Store the current cons in the cdr of the previous cons. - (emit-label loop) - (inst addq dst (* 2 n-word-bytes) dst) - (storew dst dst -1 list-pointer-lowtag) - - (emit-label enter) - ;; Grab one value. - (loadw temp context) - (inst addq context n-word-bytes context) - - ;; Store the value in the car (in delay slot) - (storew temp dst 0 list-pointer-lowtag) - - ;; Decrement count, and if != zero, go back for more. - (inst subq count (fixnumize 1) count) - (inst bne count loop) - - ;; NIL out the last cons. - (storew null-tn dst 1 list-pointer-lowtag)) + ;; Allocate a cons (2 words) for each item. + (inst bis alloc-area-tn list-pointer-lowtag result) + (move result dst) + (inst sll count 1 temp) + (inst addq alloc-area-tn temp alloc-area-tn) + (inst br zero-tn enter) + + ;; Store the current cons in the cdr of the previous cons. + (emit-label loop) + (inst addq dst (* 2 n-word-bytes) dst) + (storew dst dst -1 list-pointer-lowtag) + + (emit-label enter) + ;; Grab one value. + (loadw temp context) + (inst addq context n-word-bytes context) + + ;; Store the value in the car (in delay slot) + (storew temp dst 0 list-pointer-lowtag) + + ;; Decrement count, and if != zero, go back for more. + (inst subq count (fixnumize 1) count) + (inst bne count loop) + + ;; NIL out the last cons. + (storew null-tn dst 1 list-pointer-lowtag)) (emit-label done)))) ;;; Return the location and size of the &MORE arg glob created by @@ -1181,7 +1181,7 @@ default-value-8 (:arg-types tagged-num (:constant fixnum)) (:info fixed) (:results (context :scs (descriptor-reg)) - (count :scs (any-reg))) + (count :scs (any-reg))) (:result-types t tagged-num) (:note "more-arg-context") (:generator 5 @@ -1200,26 +1200,26 @@ default-value-8 (:save-p :compute-only) (:generator 3 (let ((err-lab - (generate-error-code vop invalid-arg-count-error nargs))) + (generate-error-code vop invalid-arg-count-error nargs))) (cond ((zerop count) - (inst bne nargs err-lab)) - (t - (inst subq nargs (fixnumize count) temp) - (inst bne temp err-lab)))))) + (inst bne nargs err-lab)) + (t + (inst subq nargs (fixnumize count) temp) + (inst bne temp err-lab)))))) ;;; various other error signalers (macrolet ((frob (name error translate &rest args) - `(define-vop (,name) - ,@(when translate - `((:policy :fast-safe) - (:translate ,translate))) - (:args ,@(mapcar (lambda (arg) - `(,arg :scs (any-reg descriptor-reg))) - args)) - (:vop-var vop) - (:save-p :compute-only) - (:generator 1000 - (error-call vop ,error ,@args))))) + `(define-vop (,name) + ,@(when translate + `((:policy :fast-safe) + (:translate ,translate))) + (:args ,@(mapcar (lambda (arg) + `(,arg :scs (any-reg descriptor-reg))) + args)) + (:vop-var vop) + (:save-p :compute-only) + (:generator 1000 + (error-call vop ,error ,@args))))) (frob arg-count-error invalid-arg-count-error sb!c::%arg-count-error nargs) (frob type-check-error object-not-type-error sb!c::%type-check-error diff --git a/src/compiler/alpha/cell.lisp b/src/compiler/alpha/cell.lisp index 1757d9c..0a02a9f 100644 --- a/src/compiler/alpha/cell.lisp +++ b/src/compiler/alpha/cell.lisp @@ -24,15 +24,15 @@ (define-vop (set-slot) (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg null zero))) + (value :scs (descriptor-reg any-reg null zero))) (:info name offset lowtag #!+gengc remember) (:ignore name) (:results) (:generator 1 #!+gengc (if remember - (storew-and-remember-slot value object offset lowtag) - (storew value object offset lowtag)) + (storew-and-remember-slot value object offset lowtag) + (storew value object offset lowtag)) #!-gengc (storew value object offset lowtag))) @@ -79,8 +79,8 @@ (loadw value object symbol-value-slot other-pointer-lowtag) (inst xor value unbound-marker-widetag temp) (if not-p - (inst beq temp target) - (inst bne temp target)))) + (inst beq temp target) + (inst bne temp target)))) (define-vop (fast-symbol-value cell-ref) (:variant symbol-value-slot other-pointer-lowtag) @@ -124,7 +124,7 @@ (:policy :fast-safe) (:translate (setf fdefn-fun)) (:args (function :scs (descriptor-reg) :target result) - (fdefn :scs (descriptor-reg))) + (fdefn :scs (descriptor-reg))) (:temporary (:scs (interior-reg)) lip) (:temporary (:scs (non-descriptor-reg)) type) (:results (result :scs (descriptor-reg))) @@ -133,15 +133,15 @@ (load-type type function (- fun-pointer-lowtag)) (inst xor type simple-fun-header-widetag type) (inst addq function - (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag) - lip) + (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag) + lip) (inst beq type normal-fn) (inst li (make-fixup "closure_tramp" :foreign) lip) (emit-label normal-fn) (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag) (storew function fdefn fdefn-fun-slot other-pointer-lowtag) (move function result)))) - + (define-vop (fdefn-makunbound) (:policy :fast-safe) @@ -161,7 +161,7 @@ ;;; symbol on the binding stack and stuff the new value into the symbol. (define-vop (bind) (:args (val :scs (any-reg descriptor-reg)) - (symbol :scs (descriptor-reg))) + (symbol :scs (descriptor-reg))) (:temporary (:scs (descriptor-reg)) temp) (:generator 5 (loadw temp symbol symbol-value-slot other-pointer-lowtag) @@ -169,7 +169,7 @@ (storew temp bsp-tn (- binding-value-slot binding-size)) (storew symbol bsp-tn (- binding-symbol-slot binding-size)) (#!+gengc storew-and-remember-slot #!-gengc storew - val symbol symbol-value-slot other-pointer-lowtag))) + val symbol symbol-value-slot other-pointer-lowtag))) (define-vop (unbind) @@ -178,7 +178,7 @@ (loadw symbol bsp-tn (- binding-symbol-slot binding-size)) (loadw value bsp-tn (- binding-value-slot binding-size)) (#!+gengc storew-and-remember-slot #!-gengc storew - value symbol symbol-value-slot other-pointer-lowtag) + value symbol symbol-value-slot other-pointer-lowtag) (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) (inst subq bsp-tn (* 2 n-word-bytes) bsp-tn))) @@ -190,8 +190,8 @@ (:temporary (:scs (non-descriptor-reg)) temp) (:generator 0 (let ((loop (gen-label)) - (skip (gen-label)) - (done (gen-label))) + (skip (gen-label)) + (done (gen-label))) (move arg where) (inst cmpeq where bsp-tn temp) (inst bne temp done) @@ -201,7 +201,7 @@ (loadw value bsp-tn (- binding-value-slot binding-size)) (inst beq symbol skip) (#!+gengc storew-and-remember-slot #!-gengc storew - value symbol symbol-value-slot other-pointer-lowtag) + value symbol symbol-value-slot other-pointer-lowtag) (storew zero-tn bsp-tn (- binding-symbol-slot binding-size)) (emit-label skip) @@ -342,22 +342,22 @@ (offset (symbolicate "MUTATOR-" slot "-SLOT")) (fn (let ((*package* (find-package :kernel))) - (symbolicate "MUTATOR-" slot)))) + (symbolicate "MUTATOR-" slot)))) (multiple-value-bind (lisp-type ref-vop set-vop) (ecase type (:des (values t - 'mutator-descriptor-ref - 'mutator-descriptor-set)) + 'mutator-descriptor-ref + 'mutator-descriptor-set)) (:ub32 (values '(unsigned-byte 32) - 'mutator-ub32-ref - 'mutator-ub32-set)) + 'mutator-ub32-ref + 'mutator-ub32-set)) (:sap (values 'system-area-pointer - 'mutator-sap-ref - 'mutator-sap-set))) + 'mutator-sap-ref + 'mutator-sap-set))) `(progn (export ',fn :kernel) (defknown ,fn () ,lisp-type (flushable)) @@ -366,7 +366,7 @@ (:variant ,offset)) ,@(when writable `((defknown ((setf ,fn)) (,lisp-type) ,lisp-type - (unsafe)) + (unsafe)) (define-vop (,set ,set-vop) (:translate (setf ,fn)) (:variant ,offset))))))))) @@ -397,7 +397,7 @@ (:translate %raw-instance-ref/word) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg))) (:arg-types * positive-fixnum) (:results (value :scs (unsigned-reg))) (:temporary (:scs (non-descriptor-reg)) offset) @@ -411,17 +411,17 @@ (inst subq offset n-word-bytes offset) (inst addq object offset lip) (inst ldl - value - (- (* instance-slots-offset n-word-bytes) + value + (- (* instance-slots-offset n-word-bytes) instance-pointer-lowtag) - lip) + lip) (inst mskll value 4 value))) (define-vop (raw-instance-set/word) (:translate %raw-instance-set/word) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) + (index :scs (any-reg)) (value :scs (unsigned-reg))) (:arg-types * positive-fixnum unsigned-num) (:results (result :scs (unsigned-reg))) @@ -436,17 +436,17 @@ (inst subq offset n-word-bytes offset) (inst addq object offset lip) (inst stl - value - (- (* instance-slots-offset n-word-bytes) + value + (- (* instance-slots-offset n-word-bytes) instance-pointer-lowtag) - lip) + lip) (move value result))) (define-vop (raw-instance-ref/single) (:translate %raw-instance-ref/single) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg))) (:arg-types * positive-fixnum) (:results (value :scs (single-reg))) (:temporary (:scs (non-descriptor-reg)) offset) @@ -460,16 +460,16 @@ (inst subq offset n-word-bytes offset) (inst addq object offset lip) (inst lds - value - (- (* instance-slots-offset n-word-bytes) + value + (- (* instance-slots-offset n-word-bytes) instance-pointer-lowtag) - lip))) + lip))) (define-vop (raw-instance-set/single) (:translate %raw-instance-set/single) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) + (index :scs (any-reg)) (value :scs (single-reg))) (:arg-types * positive-fixnum single-float) (:results (result :scs (single-reg))) @@ -484,10 +484,10 @@ (inst subq offset n-word-bytes offset) (inst addq object offset lip) (inst sts - value - (- (* instance-slots-offset n-word-bytes) + value + (- (* instance-slots-offset n-word-bytes) instance-pointer-lowtag) - lip) + lip) (unless (location= result value) (inst fmove value result)))) @@ -495,7 +495,7 @@ (:translate %raw-instance-ref/double) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg))) (:arg-types * positive-fixnum) (:results (value :scs (double-reg))) (:temporary (:scs (non-descriptor-reg)) offset) @@ -509,16 +509,16 @@ (inst subq offset (* 2 n-word-bytes) offset) (inst addq object offset lip) (inst ldt - value - (- (* instance-slots-offset n-word-bytes) + value + (- (* instance-slots-offset n-word-bytes) instance-pointer-lowtag) - lip))) + lip))) (define-vop (raw-instance-set/double) (:translate %raw-instance-set/double) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) + (index :scs (any-reg)) (value :scs (double-reg))) (:arg-types * positive-fixnum double-float) (:results (result :scs (double-reg))) @@ -533,10 +533,10 @@ (inst subq offset (* 2 n-word-bytes) offset) (inst addq object offset lip) (inst stt - value - (- (* instance-slots-offset n-word-bytes) + value + (- (* instance-slots-offset n-word-bytes) instance-pointer-lowtag) - lip) + lip) (unless (location= result value) (inst fmove value result)))) @@ -544,7 +544,7 @@ (:translate %raw-instance-ref/complex-single) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg))) (:arg-types * positive-fixnum) (:results (value :scs (complex-single-reg))) (:temporary (:scs (non-descriptor-reg)) offset) @@ -558,21 +558,21 @@ (inst subq offset (* 2 n-word-bytes) offset) (inst addq object offset lip) (inst lds - (complex-double-reg-real-tn value) - (- (* instance-slots-offset n-word-bytes) + (complex-double-reg-real-tn value) + (- (* instance-slots-offset n-word-bytes) instance-pointer-lowtag) - lip) + lip) (inst lds - (complex-double-reg-imag-tn value) - (- (* (1+ instance-slots-offset) n-word-bytes) + (complex-double-reg-imag-tn value) + (- (* (1+ instance-slots-offset) n-word-bytes) instance-pointer-lowtag) - lip))) + lip))) (define-vop (raw-instance-set/complex-single) (:translate %raw-instance-set/complex-single) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) + (index :scs (any-reg)) (value :scs (complex-single-reg))) (:arg-types * positive-fixnum complex-single-float) (:results (result :scs (complex-single-reg))) @@ -589,27 +589,27 @@ (let ((value-real (complex-single-reg-real-tn value)) (result-real (complex-single-reg-real-tn result))) (inst sts - value-real - (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag) - lip) + value-real + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) (unless (location= result-real value-real) - (inst fmove value-real result-real))) + (inst fmove value-real result-real))) (let ((value-imag (complex-single-reg-imag-tn value)) (result-imag (complex-single-reg-imag-tn result))) (inst sts - value-imag - (- (* (1+ instance-slots-offset) n-word-bytes) - instance-pointer-lowtag) - lip) + value-imag + (- (* (1+ instance-slots-offset) n-word-bytes) + instance-pointer-lowtag) + lip) (unless (location= result-imag value-imag) - (inst fmove value-imag result-imag))))) + (inst fmove value-imag result-imag))))) (define-vop (raw-instance-ref/complex-double) (:translate %raw-instance-ref/complex-double) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg))) (:arg-types * positive-fixnum) (:results (value :scs (complex-double-reg))) (:temporary (:scs (non-descriptor-reg)) offset) @@ -623,21 +623,21 @@ (inst subq offset (* 4 n-word-bytes) offset) (inst addq object offset lip) (inst ldt - (complex-double-reg-real-tn value) - (- (* instance-slots-offset n-word-bytes) + (complex-double-reg-real-tn value) + (- (* instance-slots-offset n-word-bytes) instance-pointer-lowtag) - lip) + lip) (inst ldt - (complex-double-reg-imag-tn value) - (- (* (+ instance-slots-offset 2) n-word-bytes) + (complex-double-reg-imag-tn value) + (- (* (+ instance-slots-offset 2) n-word-bytes) instance-pointer-lowtag) - lip))) + lip))) (define-vop (raw-instance-set/complex-double) (:translate %raw-instance-set/complex-double) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) + (index :scs (any-reg)) (value :scs (complex-double-reg))) (:arg-types * positive-fixnum complex-double-float) (:results (result :scs (complex-double-reg))) @@ -654,18 +654,18 @@ (let ((value-real (complex-double-reg-real-tn value)) (result-real (complex-double-reg-real-tn result))) (inst stt - value-real - (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag) - lip) + value-real + (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag) + lip) (unless (location= result-real value-real) - (inst fmove value-real result-real))) + (inst fmove value-real result-real))) (let ((value-imag (complex-double-reg-imag-tn value)) (result-imag (complex-double-reg-imag-tn result))) (inst stt - value-imag - (- (* (+ instance-slots-offset 2) n-word-bytes) - instance-pointer-lowtag) - lip) + value-imag + (- (* (+ instance-slots-offset 2) n-word-bytes) + instance-pointer-lowtag) + lip) (unless (location= result-imag value-imag) - (inst fmove value-imag result-imag))))) + (inst fmove value-imag result-imag))))) diff --git a/src/compiler/alpha/char.lisp b/src/compiler/alpha/char.lisp index 8bc0ac8..48825d3 100644 --- a/src/compiler/alpha/char.lisp +++ b/src/compiler/alpha/char.lisp @@ -35,10 +35,10 @@ ;;; Move untagged character values. (define-vop (character-move) (:args (x :target y - :scs (character-reg) - :load-if (not (location= x y)))) + :scs (character-reg) + :load-if (not (location= x y)))) (:results (y :scs (character-reg) - :load-if (not (location= x y)))) + :load-if (not (location= x y)))) (:effects) (:affected) (:generator 0 @@ -49,9 +49,9 @@ ;;; Move untagged character arguments/return-values. (define-vop (move-character-arg) (:args (x :target y - :scs (character-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y character-reg)))) + :scs (character-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y character-reg)))) (:results (y)) (:generator 0 (sc-case y @@ -93,7 +93,7 @@ (define-vop (character-compare) (:args (x :scs (character-reg)) - (y :scs (character-reg))) + (y :scs (character-reg))) (:arg-types character character) (:temporary (:scs (non-descriptor-reg)) temp) (:conditional) @@ -107,8 +107,8 @@ (:lt (inst cmplt x y temp)) (:gt (inst cmplt y x temp))) (if not-p - (inst beq temp target) - (inst bne temp target)))) + (inst beq temp target) + (inst bne temp target)))) (define-vop (fast-char=/character character-compare) (:translate char=) @@ -137,12 +137,12 @@ (:lt (inst cmplt x (sb!xc:char-code y) temp)) (:gt (inst cmple x (sb!xc:char-code y) temp))) (if not-p - (if (eq cond :gt) - (inst bne temp target) - (inst beq temp target)) (if (eq cond :gt) - (inst beq temp target) - (inst bne temp target))))) + (inst bne temp target) + (inst beq temp target)) + (if (eq cond :gt) + (inst beq temp target) + (inst bne temp target))))) (define-vop (fast-char=/character/c character-compare/c) (:translate char=) diff --git a/src/compiler/alpha/debug.lisp b/src/compiler/alpha/debug.lisp index 0f309e8..73702d3 100644 --- a/src/compiler/alpha/debug.lisp +++ b/src/compiler/alpha/debug.lisp @@ -31,7 +31,7 @@ (:translate stack-ref) (:policy :fast-safe) (:args (object :scs (sap-reg) :target sap) - (offset :scs (any-reg))) + (offset :scs (any-reg))) (:arg-types system-area-pointer positive-fixnum) (:temporary (:scs (sap-reg) :from :eval) sap) (:results (result :scs (descriptor-reg))) @@ -55,8 +55,8 @@ (:translate %set-stack-ref) (:policy :fast-safe) (:args (object :scs (sap-reg) :target sap) - (offset :scs (any-reg)) - (value :scs (descriptor-reg) :target result)) + (offset :scs (any-reg)) + (value :scs (descriptor-reg) :target result)) (:arg-types system-area-pointer positive-fixnum *) (:results (result :scs (descriptor-reg))) (:result-types *) @@ -70,7 +70,7 @@ (:translate %set-stack-ref) (:policy :fast-safe) (:args (sap :scs (sap-reg)) - (value :scs (descriptor-reg) :target result)) + (value :scs (descriptor-reg) :target result)) (:info offset) (:arg-types system-area-pointer (:constant (signed-byte 14)) *) (:results (result :scs (descriptor-reg))) @@ -88,19 +88,19 @@ (:variant-vars lowtag) (:generator 5 (let ((bogus (gen-label)) - (done (gen-label))) + (done (gen-label))) (loadw temp thing 0 lowtag) (inst srl temp n-widetag-bits temp) (inst beq temp bogus) (inst sll temp (1- (integer-length n-word-bytes)) temp) (unless (= lowtag other-pointer-lowtag) - (inst subq temp (- other-pointer-lowtag lowtag) temp)) + (inst subq temp (- other-pointer-lowtag lowtag) temp)) (inst subq thing temp code) (emit-label done) (assemble (*elsewhere*) - (emit-label bogus) - (move null-tn code) - (inst br zero-tn done))))) + (emit-label bogus) + (move null-tn code) + (inst br zero-tn done))))) (define-vop (code-from-lra code-from-mumble) (:translate lra-code-header) diff --git a/src/compiler/alpha/float.lisp b/src/compiler/alpha/float.lisp index 4f33837..6ed495c 100644 --- a/src/compiler/alpha/float.lisp +++ b/src/compiler/alpha/float.lisp @@ -29,30 +29,30 @@ (define-move-fun (load-double 2) (vop x y) ((double-stack) (double-reg)) (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset x) n-word-bytes))) + (offset (* (tn-offset x) n-word-bytes))) (inst ldt y offset nfp))) (define-move-fun (store-double 2) (vop x y) ((double-reg) (double-stack)) (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset y) n-word-bytes))) + (offset (* (tn-offset y) n-word-bytes))) (inst stt x offset nfp))) ;;;; float move VOPs (macrolet ((frob (vop sc) - `(progn - (define-vop (,vop) - (:args (x :scs (,sc) - :target y - :load-if (not (location= x y)))) - (:results (y :scs (,sc) - :load-if (not (location= x y)))) - (:note "float move") - (:generator 0 - (unless (location= y x) - (inst fmove x y)))) - (define-move-vop ,vop :move (,sc) (,sc))))) + `(progn + (define-vop (,vop) + (:args (x :scs (,sc) + :target y + :load-if (not (location= x y)))) + (:results (y :scs (,sc) + :load-if (not (location= x y)))) + (:note "float move") + (:generator 0 + (unless (location= y x) + (inst fmove x y)))) + (define-move-vop ,vop :move (,sc) (,sc))))) (frob single-move single-reg) (frob double-move double-reg)) @@ -66,60 +66,60 @@ (:generator 13 (with-fixed-allocation (y ndescr type size) (if double-p - (inst stt x (- (* data n-word-bytes) other-pointer-lowtag) y) - (inst sts x (- (* data n-word-bytes) other-pointer-lowtag) y))))) + (inst stt x (- (* data n-word-bytes) other-pointer-lowtag) y) + (inst sts x (- (* data n-word-bytes) other-pointer-lowtag) y))))) (macrolet ((frob (name sc &rest args) - `(progn - (define-vop (,name move-from-float) - (:args (x :scs (,sc) :to :save)) - (:results (y :scs (descriptor-reg))) - (:variant ,@args)) - (define-move-vop ,name :move (,sc) (descriptor-reg))))) + `(progn + (define-vop (,name move-from-float) + (:args (x :scs (,sc) :to :save)) + (:results (y :scs (descriptor-reg))) + (:variant ,@args)) + (define-move-vop ,name :move (,sc) (descriptor-reg))))) (frob move-from-single single-reg nil single-float-size single-float-widetag single-float-value-slot) (frob move-from-double double-reg t double-float-size double-float-widetag double-float-value-slot)) (macrolet ((frob (name sc double-p value) - `(progn - (define-vop (,name) - (:args (x :scs (descriptor-reg))) - (:results (y :scs (,sc))) - (:note "pointer to float coercion") - (:generator 2 + `(progn + (define-vop (,name) + (:args (x :scs (descriptor-reg))) + (:results (y :scs (,sc))) + (:note "pointer to float coercion") + (:generator 2 ,@(if double-p - `((inst ldt y (- (* ,value n-word-bytes) - other-pointer-lowtag) - x)) - `((inst lds y (- (* ,value n-word-bytes) - other-pointer-lowtag) - x))))) - (define-move-vop ,name :move (descriptor-reg) (,sc))))) + `((inst ldt y (- (* ,value n-word-bytes) + other-pointer-lowtag) + x)) + `((inst lds y (- (* ,value n-word-bytes) + other-pointer-lowtag) + x))))) + (define-move-vop ,name :move (descriptor-reg) (,sc))))) (frob move-to-single single-reg nil single-float-value-slot) (frob move-to-double double-reg t double-float-value-slot)) (macrolet ((frob (name sc stack-sc double-p) - `(progn - (define-vop (,name) - (:args (x :scs (,sc) :target y) - (nfp :scs (any-reg) - :load-if (not (sc-is y ,sc)))) - (:results (y)) - (:note "float argument move") - (:generator ,(if double-p 2 1) - (sc-case y - (,sc - (unless (location= x y) - (inst fmove x y))) - (,stack-sc - (let ((offset (* (tn-offset y) n-word-bytes))) - ,@(if double-p - '((inst stt x offset nfp)) - '((inst sts x offset nfp)))))))) - (define-move-vop ,name :move-arg - (,sc descriptor-reg) (,sc))))) + `(progn + (define-vop (,name) + (:args (x :scs (,sc) :target y) + (nfp :scs (any-reg) + :load-if (not (sc-is y ,sc)))) + (:results (y)) + (:note "float argument move") + (:generator ,(if double-p 2 1) + (sc-case y + (,sc + (unless (location= x y) + (inst fmove x y))) + (,stack-sc + (let ((offset (* (tn-offset y) n-word-bytes))) + ,@(if double-p + '((inst stt x offset nfp)) + '((inst sts x offset nfp)))))))) + (define-move-vop ,name :move-arg + (,sc descriptor-reg) (,sc))))) (frob move-single-float-arg single-reg single-stack nil) (frob move-double-float-arg double-reg double-stack t)) @@ -127,23 +127,23 @@ (defun complex-single-reg-real-tn (x) (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg ) - :offset (tn-offset x))) + :offset (tn-offset x))) (defun complex-single-reg-imag-tn (x) (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg ) - :offset (1+ (tn-offset x)))) + :offset (1+ (tn-offset x)))) (defun complex-double-reg-real-tn (x) (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg ) - :offset (tn-offset x))) + :offset (tn-offset x))) (defun complex-double-reg-imag-tn (x) (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg ) - :offset (1+ (tn-offset x)))) + :offset (1+ (tn-offset x)))) (define-move-fun (load-complex-single 2) (vop x y) ((complex-single-stack) (complex-single-reg)) (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset x) n-word-bytes))) + (offset (* (tn-offset x) n-word-bytes))) (let ((real-tn (complex-single-reg-real-tn y))) (inst lds real-tn offset nfp)) (let ((imag-tn (complex-single-reg-imag-tn y))) @@ -152,7 +152,7 @@ (define-move-fun (store-complex-single 2) (vop x y) ((complex-single-reg) (complex-single-stack)) (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset y) n-word-bytes))) + (offset (* (tn-offset y) n-word-bytes))) (let ((real-tn (complex-single-reg-real-tn x))) (inst sts real-tn offset nfp)) (let ((imag-tn (complex-single-reg-imag-tn x))) @@ -162,7 +162,7 @@ (define-move-fun (load-complex-double 4) (vop x y) ((complex-double-stack) (complex-double-reg)) (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset x) n-word-bytes))) + (offset (* (tn-offset x) n-word-bytes))) (let ((real-tn (complex-double-reg-real-tn y))) (inst ldt real-tn offset nfp)) (let ((imag-tn (complex-double-reg-imag-tn y))) @@ -171,7 +171,7 @@ (define-move-fun (store-complex-double 4) (vop x y) ((complex-double-reg) (complex-double-stack)) (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset y) n-word-bytes))) + (offset (* (tn-offset y) n-word-bytes))) (let ((real-tn (complex-double-reg-real-tn x))) (inst stt real-tn offset nfp)) (let ((imag-tn (complex-double-reg-imag-tn x))) @@ -182,7 +182,7 @@ ;;; (define-vop (complex-single-move) (:args (x :scs (complex-single-reg) :target y - :load-if (not (location= x y)))) + :load-if (not (location= x y)))) (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))) (:note "complex single float move") (:generator 0 @@ -190,18 +190,18 @@ ;; Note the complex-float-regs are aligned to every second ;; float register so there is not need to worry about overlap. (let ((x-real (complex-single-reg-real-tn x)) - (y-real (complex-single-reg-real-tn y))) - (inst fmove x-real y-real)) + (y-real (complex-single-reg-real-tn y))) + (inst fmove x-real y-real)) (let ((x-imag (complex-single-reg-imag-tn x)) - (y-imag (complex-single-reg-imag-tn y))) - (inst fmove x-imag y-imag))))) + (y-imag (complex-single-reg-imag-tn y))) + (inst fmove x-imag y-imag))))) ;;; (define-move-vop complex-single-move :move (complex-single-reg) (complex-single-reg)) (define-vop (complex-double-move) (:args (x :scs (complex-double-reg) - :target y :load-if (not (location= x y)))) + :target y :load-if (not (location= x y)))) (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))) (:note "complex double float move") (:generator 0 @@ -209,11 +209,11 @@ ;; Note the complex-float-regs are aligned to every second ;; float register so there is not need to worry about overlap. (let ((x-real (complex-double-reg-real-tn x)) - (y-real (complex-double-reg-real-tn y))) - (inst fmove x-real y-real)) + (y-real (complex-double-reg-real-tn y))) + (inst fmove x-real y-real)) (let ((x-imag (complex-double-reg-imag-tn x)) - (y-imag (complex-double-reg-imag-tn y))) - (inst fmove x-imag y-imag))))) + (y-imag (complex-double-reg-imag-tn y))) + (inst fmove x-imag y-imag))))) ;;; (define-move-vop complex-double-move :move (complex-double-reg) (complex-double-reg)) @@ -229,17 +229,17 @@ (:note "complex single float to pointer coercion") (:generator 13 (with-fixed-allocation (y ndescr complex-single-float-widetag - complex-single-float-size) + complex-single-float-size) (let ((real-tn (complex-single-reg-real-tn x))) - (inst sts real-tn (- (* complex-single-float-real-slot - n-word-bytes) - other-pointer-lowtag) - y)) + (inst sts real-tn (- (* complex-single-float-real-slot + n-word-bytes) + other-pointer-lowtag) + y)) (let ((imag-tn (complex-single-reg-imag-tn x))) - (inst sts imag-tn (- (* complex-single-float-imag-slot - n-word-bytes) - other-pointer-lowtag) - y))))) + (inst sts imag-tn (- (* complex-single-float-imag-slot + n-word-bytes) + other-pointer-lowtag) + y))))) ;;; (define-move-vop move-from-complex-single :move (complex-single-reg) (descriptor-reg)) @@ -251,17 +251,17 @@ (:note "complex double float to pointer coercion") (:generator 13 (with-fixed-allocation (y ndescr complex-double-float-widetag - complex-double-float-size) + complex-double-float-size) (let ((real-tn (complex-double-reg-real-tn x))) - (inst stt real-tn (- (* complex-double-float-real-slot - n-word-bytes) - other-pointer-lowtag) - y)) + (inst stt real-tn (- (* complex-double-float-real-slot + n-word-bytes) + other-pointer-lowtag) + y)) (let ((imag-tn (complex-double-reg-imag-tn x))) - (inst stt imag-tn (- (* complex-double-float-imag-slot - n-word-bytes) - other-pointer-lowtag) - y))))) + (inst stt imag-tn (- (* complex-double-float-imag-slot + n-word-bytes) + other-pointer-lowtag) + y))))) ;;; (define-move-vop move-from-complex-double :move (complex-double-reg) (descriptor-reg)) @@ -276,14 +276,14 @@ (:generator 2 (let ((real-tn (complex-single-reg-real-tn y))) (inst lds real-tn (- (* complex-single-float-real-slot - n-word-bytes) - other-pointer-lowtag) - x)) + n-word-bytes) + other-pointer-lowtag) + x)) (let ((imag-tn (complex-single-reg-imag-tn y))) (inst lds imag-tn (- (* complex-single-float-imag-slot - n-word-bytes) - other-pointer-lowtag) - x)))) + n-word-bytes) + other-pointer-lowtag) + x)))) (define-move-vop move-to-complex-single :move (descriptor-reg) (complex-single-reg)) @@ -294,14 +294,14 @@ (:generator 2 (let ((real-tn (complex-double-reg-real-tn y))) (inst ldt real-tn (- (* complex-double-float-real-slot - n-word-bytes) - other-pointer-lowtag) - x)) + n-word-bytes) + other-pointer-lowtag) + x)) (let ((imag-tn (complex-double-reg-imag-tn y))) (inst ldt imag-tn (- (* complex-double-float-imag-slot - n-word-bytes) - other-pointer-lowtag) - x)))) + n-word-bytes) + other-pointer-lowtag) + x)))) (define-move-vop move-to-complex-double :move (descriptor-reg) (complex-double-reg)) @@ -310,49 +310,49 @@ ;;; (define-vop (move-complex-single-float-arg) (:args (x :scs (complex-single-reg) :target y) - (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg)))) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg)))) (:results (y)) (:note "complex single float argument move") (:generator 1 (sc-case y (complex-single-reg (unless (location= x y) - (let ((x-real (complex-single-reg-real-tn x)) - (y-real (complex-single-reg-real-tn y))) - (inst fmove x-real y-real)) - (let ((x-imag (complex-single-reg-imag-tn x)) - (y-imag (complex-single-reg-imag-tn y))) - (inst fmove x-imag y-imag)))) + (let ((x-real (complex-single-reg-real-tn x)) + (y-real (complex-single-reg-real-tn y))) + (inst fmove x-real y-real)) + (let ((x-imag (complex-single-reg-imag-tn x)) + (y-imag (complex-single-reg-imag-tn y))) + (inst fmove x-imag y-imag)))) (complex-single-stack (let ((offset (* (tn-offset y) n-word-bytes))) - (let ((real-tn (complex-single-reg-real-tn x))) - (inst sts real-tn offset nfp)) - (let ((imag-tn (complex-single-reg-imag-tn x))) - (inst sts imag-tn (+ offset n-word-bytes) nfp))))))) + (let ((real-tn (complex-single-reg-real-tn x))) + (inst sts real-tn offset nfp)) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (inst sts imag-tn (+ offset n-word-bytes) nfp))))))) (define-move-vop move-complex-single-float-arg :move-arg (complex-single-reg descriptor-reg) (complex-single-reg)) (define-vop (move-complex-double-float-arg) (:args (x :scs (complex-double-reg) :target y) - (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg)))) + (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg)))) (:results (y)) (:note "complex double float argument move") (:generator 2 (sc-case y (complex-double-reg (unless (location= x y) - (let ((x-real (complex-double-reg-real-tn x)) - (y-real (complex-double-reg-real-tn y))) - (inst fmove x-real y-real)) - (let ((x-imag (complex-double-reg-imag-tn x)) - (y-imag (complex-double-reg-imag-tn y))) - (inst fmove x-imag y-imag)))) + (let ((x-real (complex-double-reg-real-tn x)) + (y-real (complex-double-reg-real-tn y))) + (inst fmove x-real y-real)) + (let ((x-imag (complex-double-reg-imag-tn x)) + (y-imag (complex-double-reg-imag-tn y))) + (inst fmove x-imag y-imag)))) (complex-double-stack (let ((offset (* (tn-offset y) n-word-bytes))) - (let ((real-tn (complex-double-reg-real-tn x))) - (inst stt real-tn offset nfp)) - (let ((imag-tn (complex-double-reg-imag-tn x))) - (inst stt imag-tn (+ offset (* 2 n-word-bytes)) nfp))))))) + (let ((real-tn (complex-double-reg-real-tn x))) + (inst stt real-tn offset nfp)) + (let ((imag-tn (complex-double-reg-imag-tn x))) + (inst stt imag-tn (+ offset (* 2 n-word-bytes)) nfp))))))) (define-move-vop move-complex-double-float-arg :move-arg (complex-double-reg descriptor-reg) (complex-double-reg)) @@ -377,33 +377,33 @@ ;;; handler can re-execute the instruction and produce correct IEEE ;;; result. The :from :load hopefully does that. (macrolet ((frob (name sc ptype) - `(define-vop (,name float-op) - (:args (x :scs (,sc)) - (y :scs (,sc))) - (:results (r :scs (,sc) :from :load)) - (:arg-types ,ptype ,ptype) - (:result-types ,ptype)))) + `(define-vop (,name float-op) + (:args (x :scs (,sc)) + (y :scs (,sc))) + (:results (r :scs (,sc) :from :load)) + (:arg-types ,ptype ,ptype) + (:result-types ,ptype)))) (frob single-float-op single-reg single-float) (frob double-float-op double-reg double-float)) ;; This is resumption-safe with underflow traps enabled, ;; with software handling and (notyet) dynamic rounding mode. (macrolet ((frob (op sinst sname scost dinst dname dcost) - `(progn - (define-vop (,sname single-float-op) - (:translate ,op) - (:variant-cost ,scost) - (:generator ,scost + `(progn + (define-vop (,sname single-float-op) + (:translate ,op) + (:variant-cost ,scost) + (:generator ,scost (inst ,sinst x y r) - (note-this-location vop :internal-error) - (inst trapb))) - (define-vop (,dname double-float-op) - (:translate ,op) - (:variant-cost ,dcost) - (:generator ,dcost - (inst ,dinst x y r) - (note-this-location vop :internal-error) - (inst trapb)))))) + (note-this-location vop :internal-error) + (inst trapb))) + (define-vop (,dname double-float-op) + (:translate ,op) + (:variant-cost ,dcost) + (:generator ,dcost + (inst ,dinst x y r) + (note-this-location vop :internal-error) + (inst trapb)))))) ;; Not sure these cost number are right. +*- about same / is 4x (frob + adds_su +/single-float 1 addt_su +/double-float 1) (frob - subs_su -/single-float 1 subt_su -/double-float 1) @@ -411,19 +411,19 @@ (frob / divs_su //single-float 4 divt_su //double-float 4)) (macrolet ((frob (name inst translate sc type) - `(define-vop (,name) - (:args (x :scs (,sc) :target y)) - (:results (y :scs (,sc))) - (:translate ,translate) - (:policy :fast-safe) - (:arg-types ,type) - (:result-types ,type) - (:note "inline float arithmetic") - (:vop-var vop) - (:save-p :compute-only) - (:generator 1 - (note-this-location vop :internal-error) - (inst ,inst x y))))) + `(define-vop (,name) + (:args (x :scs (,sc) :target y)) + (:results (y :scs (,sc))) + (:translate ,translate) + (:policy :fast-safe) + (:arg-types ,type) + (:result-types ,type) + (:note "inline float arithmetic") + (:vop-var vop) + (:save-p :compute-only) + (:generator 1 + (note-this-location vop :internal-error) + (inst ,inst x y))))) (frob abs/single-float fabs abs single-reg single-float) (frob abs/double-float fabs abs double-reg double-float) (frob %negate/single-float fneg %negate single-reg single-float) @@ -445,31 +445,31 @@ (:generator 3 (note-this-location vop :internal-error) (if eq - (inst cmpteq x y temp) - (if complement - (inst cmptle x y temp) - (inst cmptlt x y temp))) + (inst cmpteq x y temp) + (if complement + (inst cmptle x y temp) + (inst cmptlt x y temp))) (inst trapb) (if (if complement (not not-p) not-p) - (inst fbeq temp target) - (inst fbne temp target)))) + (inst fbeq temp target) + (inst fbne temp target)))) (macrolet ((frob (name sc ptype) - `(define-vop (,name float-compare) - (:args (x :scs (,sc)) - (y :scs (,sc))) - (:arg-types ,ptype ,ptype)))) + `(define-vop (,name float-compare) + (:args (x :scs (,sc)) + (y :scs (,sc))) + (:arg-types ,ptype ,ptype)))) (frob single-float-compare single-reg single-float) (frob double-float-compare double-reg double-float)) (macrolet ((frob (translate complement sname dname eq) - `(progn - (define-vop (,sname single-float-compare) - (:translate ,translate) - (:variant ,eq ,complement)) - (define-vop (,dname double-float-compare) - (:translate ,translate) - (:variant ,eq ,complement))))) + `(progn + (define-vop (,sname single-float-compare) + (:translate ,translate) + (:variant ,eq ,complement)) + (define-vop (,dname double-float-compare) + (:translate ,translate) + (:variant ,eq ,complement))))) (frob < nil t >/single-float >/double-float nil) (frob = nil =/single-float =/double-float t)) @@ -482,11 +482,11 @@ `(define-vop (,name) (:args (x :scs (signed-reg) :target temp :load-if (not (sc-is x signed-stack)))) - (:temporary (:scs (,to-sc)) freg1) - (:temporary (:scs (,to-sc)) freg2) - (:temporary (:scs (single-stack)) temp) - - (:results (y :scs (,to-sc))) + (:temporary (:scs (,to-sc)) freg1) + (:temporary (:scs (,to-sc)) freg2) + (:temporary (:scs (single-stack)) temp) + + (:results (y :scs (,to-sc))) (:arg-types signed-num) (:result-types ,to-type) (:policy :fast-safe) @@ -500,7 +500,7 @@ (signed-reg (inst stl x (* (tn-offset temp) - n-word-bytes) + n-word-bytes) (current-nfp-tn vop)) temp) (signed-stack @@ -509,70 +509,70 @@ (* (tn-offset stack-tn) n-word-bytes) (current-nfp-tn vop)) (note-this-location vop :internal-error) - (inst cvtlq freg1 freg2) - (inst ,inst freg2 y) - (inst excb) - ))))) + (inst cvtlq freg1 freg2) + (inst ,inst freg2 y) + (inst excb) + ))))) (frob %single-float/signed %single-float cvtqs_sui lds single-reg single-float) (frob %double-float/signed %double-float cvtqt_sui lds double-reg double-float)) ;;; see previous comment about software trap handlers: also applies here (macrolet ((frob (name translate inst from-sc from-type to-sc to-type) `(define-vop (,name) - (:args (x :scs (,from-sc))) - (:results (y :scs (,to-sc) :from :load)) - (:arg-types ,from-type) - (:result-types ,to-type) - (:policy :fast-safe) - (:note "inline float coercion") - (:translate ,translate) - (:vop-var vop) - (:save-p :compute-only) - (:generator 2 - (note-this-location vop :internal-error) - (inst ,inst x y) - (inst excb) - )))) + (:args (x :scs (,from-sc))) + (:results (y :scs (,to-sc) :from :load)) + (:arg-types ,from-type) + (:result-types ,to-type) + (:policy :fast-safe) + (:note "inline float coercion") + (:translate ,translate) + (:vop-var vop) + (:save-p :compute-only) + (:generator 2 + (note-this-location vop :internal-error) + (inst ,inst x y) + (inst excb) + )))) (frob %single-float/double-float %single-float cvtts_su - double-reg double-float single-reg single-float) + double-reg double-float single-reg single-float) (frob %double-float/single-float %double-float fmove - single-reg single-float double-reg double-float)) + single-reg single-float double-reg double-float)) (macrolet ((frob (trans from-sc from-type inst &optional single) (declare (ignorable single)) `(define-vop (,(symbolicate trans "/" from-type)) - (:args (x :scs (,from-sc) :target temp)) - (:temporary (:from :load ;(:argument 0) - :sc single-reg) temp) - (:temporary (:scs (signed-stack)) stack-temp) - (:results (y :scs (signed-reg) - :load-if (not (sc-is y signed-stack)))) - (:arg-types ,from-type) - (:result-types signed-num) - (:translate ,trans) - (:policy :fast-safe) - (:note "inline float truncate") - (:vop-var vop) - (:save-p :compute-only) - (:generator 5 - (note-this-location vop :internal-error) - (inst ,inst x temp) - (sc-case y - (signed-stack - (inst stt temp - (* (tn-offset y) n-word-bytes) - (current-nfp-tn vop))) - (signed-reg - (inst stt temp - (* (tn-offset stack-temp) - n-word-bytes) - (current-nfp-tn vop)) - (inst ldq y - (* (tn-offset stack-temp) n-word-bytes) - (current-nfp-tn vop)))) - (inst excb) - )))) + (:args (x :scs (,from-sc) :target temp)) + (:temporary (:from :load ;(:argument 0) + :sc single-reg) temp) + (:temporary (:scs (signed-stack)) stack-temp) + (:results (y :scs (signed-reg) + :load-if (not (sc-is y signed-stack)))) + (:arg-types ,from-type) + (:result-types signed-num) + (:translate ,trans) + (:policy :fast-safe) + (:note "inline float truncate") + (:vop-var vop) + (:save-p :compute-only) + (:generator 5 + (note-this-location vop :internal-error) + (inst ,inst x temp) + (sc-case y + (signed-stack + (inst stt temp + (* (tn-offset y) n-word-bytes) + (current-nfp-tn vop))) + (signed-reg + (inst stt temp + (* (tn-offset stack-temp) + n-word-bytes) + (current-nfp-tn vop)) + (inst ldq y + (* (tn-offset stack-temp) n-word-bytes) + (current-nfp-tn vop)))) + (inst excb) + )))) (frob %unary-truncate single-reg single-float cvttq/c_sv t) (frob %unary-truncate double-reg double-float cvttq/c_sv) (frob %unary-round single-reg single-float cvttq_sv t) @@ -580,9 +580,9 @@ (define-vop (make-single-float) (:args (bits :scs (signed-reg) :target res - :load-if (not (sc-is bits signed-stack)))) + :load-if (not (sc-is bits signed-stack)))) (:results (res :scs (single-reg) - :load-if (not (sc-is res single-stack)))) + :load-if (not (sc-is res single-stack)))) (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp) (:temporary (:scs (signed-stack)) stack-temp) (:arg-types signed-num) @@ -594,37 +594,37 @@ (sc-case bits (signed-reg (sc-case res - (single-reg - (inst stl bits - (* (tn-offset stack-temp) n-word-bytes) - (current-nfp-tn vop)) - (inst lds res - (* (tn-offset stack-temp) n-word-bytes) - (current-nfp-tn vop))) - (single-stack - (inst stl bits - (* (tn-offset res) n-word-bytes) - (current-nfp-tn vop))))) + (single-reg + (inst stl bits + (* (tn-offset stack-temp) n-word-bytes) + (current-nfp-tn vop)) + (inst lds res + (* (tn-offset stack-temp) n-word-bytes) + (current-nfp-tn vop))) + (single-stack + (inst stl bits + (* (tn-offset res) n-word-bytes) + (current-nfp-tn vop))))) (signed-stack (sc-case res - (single-reg - (inst lds res - (* (tn-offset bits) n-word-bytes) - (current-nfp-tn vop))) - (single-stack - (unless (location= bits res) - (inst ldl temp - (* (tn-offset bits) n-word-bytes) - (current-nfp-tn vop)) - (inst stl temp - (* (tn-offset res) n-word-bytes) - (current-nfp-tn vop))))))))) + (single-reg + (inst lds res + (* (tn-offset bits) n-word-bytes) + (current-nfp-tn vop))) + (single-stack + (unless (location= bits res) + (inst ldl temp + (* (tn-offset bits) n-word-bytes) + (current-nfp-tn vop)) + (inst stl temp + (* (tn-offset res) n-word-bytes) + (current-nfp-tn vop))))))))) (define-vop (make-double-float) (:args (hi-bits :scs (signed-reg)) - (lo-bits :scs (unsigned-reg))) + (lo-bits :scs (unsigned-reg))) (:results (res :scs (double-reg) - :load-if (not (sc-is res double-stack)))) + :load-if (not (sc-is res double-stack)))) (:temporary (:scs (double-stack)) temp) (:arg-types signed-num unsigned-num) (:result-types double-float) @@ -633,25 +633,25 @@ (:vop-var vop) (:generator 2 (let ((stack-tn (sc-case res - (double-stack res) - (double-reg temp)))) + (double-stack res) + (double-reg temp)))) (inst stl hi-bits - (* (1+ (tn-offset stack-tn)) n-word-bytes) - (current-nfp-tn vop)) + (* (1+ (tn-offset stack-tn)) n-word-bytes) + (current-nfp-tn vop)) (inst stl lo-bits - (* (tn-offset stack-tn) n-word-bytes) - (current-nfp-tn vop))) + (* (tn-offset stack-tn) n-word-bytes) + (current-nfp-tn vop))) (when (sc-is res double-reg) (inst ldt res - (* (tn-offset temp) n-word-bytes) - (current-nfp-tn vop))))) + (* (tn-offset temp) n-word-bytes) + (current-nfp-tn vop))))) (define-vop (single-float-bits) (:args (float :scs (single-reg descriptor-reg) - :load-if (not (sc-is float single-stack)))) + :load-if (not (sc-is float single-stack)))) (:results (bits :scs (signed-reg) - :load-if (or (sc-is float descriptor-reg single-stack) - (not (sc-is bits signed-stack))))) + :load-if (or (sc-is float descriptor-reg single-stack) + (not (sc-is bits signed-stack))))) (:temporary (:scs (signed-stack)) stack-temp) (:arg-types single-float) (:result-types signed-num) @@ -662,30 +662,30 @@ (sc-case bits (signed-reg (sc-case float - (single-reg - (inst sts float - (* (tn-offset stack-temp) n-word-bytes) - (current-nfp-tn vop)) - (inst ldl bits - (* (tn-offset stack-temp) n-word-bytes) - (current-nfp-tn vop))) - (single-stack - (inst ldl bits - (* (tn-offset float) n-word-bytes) - (current-nfp-tn vop))) - (descriptor-reg - (loadw bits float single-float-value-slot - other-pointer-lowtag)))) + (single-reg + (inst sts float + (* (tn-offset stack-temp) n-word-bytes) + (current-nfp-tn vop)) + (inst ldl bits + (* (tn-offset stack-temp) n-word-bytes) + (current-nfp-tn vop))) + (single-stack + (inst ldl bits + (* (tn-offset float) n-word-bytes) + (current-nfp-tn vop))) + (descriptor-reg + (loadw bits float single-float-value-slot + other-pointer-lowtag)))) (signed-stack (sc-case float - (single-reg - (inst sts float - (* (tn-offset bits) n-word-bytes) - (current-nfp-tn vop)))))))) + (single-reg + (inst sts float + (* (tn-offset bits) n-word-bytes) + (current-nfp-tn vop)))))))) (define-vop (double-float-high-bits) (:args (float :scs (double-reg descriptor-reg) - :load-if (not (sc-is float double-stack)))) + :load-if (not (sc-is float double-stack)))) (:results (hi-bits :scs (signed-reg))) (:temporary (:scs (double-stack)) stack-temp) (:arg-types double-float) @@ -697,22 +697,22 @@ (sc-case float (double-reg (inst stt float - (* (tn-offset stack-temp) n-word-bytes) - (current-nfp-tn vop)) + (* (tn-offset stack-temp) n-word-bytes) + (current-nfp-tn vop)) (inst ldl hi-bits - (* (1+ (tn-offset stack-temp)) n-word-bytes) - (current-nfp-tn vop))) + (* (1+ (tn-offset stack-temp)) n-word-bytes) + (current-nfp-tn vop))) (double-stack (inst ldl hi-bits - (* (1+ (tn-offset float)) n-word-bytes) - (current-nfp-tn vop))) + (* (1+ (tn-offset float)) n-word-bytes) + (current-nfp-tn vop))) (descriptor-reg (loadw hi-bits float (1+ double-float-value-slot) - other-pointer-lowtag))))) + other-pointer-lowtag))))) (define-vop (double-float-low-bits) (:args (float :scs (double-reg descriptor-reg) - :load-if (not (sc-is float double-stack)))) + :load-if (not (sc-is float double-stack)))) (:results (lo-bits :scs (unsigned-reg))) (:temporary (:scs (double-stack)) stack-temp) (:arg-types double-float) @@ -724,18 +724,18 @@ (sc-case float (double-reg (inst stt float - (* (tn-offset stack-temp) n-word-bytes) - (current-nfp-tn vop)) - (inst ldl lo-bits - (* (tn-offset stack-temp) n-word-bytes) - (current-nfp-tn vop))) + (* (tn-offset stack-temp) n-word-bytes) + (current-nfp-tn vop)) + (inst ldl lo-bits + (* (tn-offset stack-temp) n-word-bytes) + (current-nfp-tn vop))) (double-stack (inst ldl lo-bits - (* (tn-offset float) n-word-bytes) - (current-nfp-tn vop))) + (* (tn-offset float) n-word-bytes) + (current-nfp-tn vop))) (descriptor-reg (loadw lo-bits float double-float-value-slot - other-pointer-lowtag))) + other-pointer-lowtag))) (inst mskll lo-bits 4 lo-bits))) @@ -747,10 +747,10 @@ (define-vop (make-complex-single-float) (:translate complex) (:args (real :scs (single-reg) :target r) - (imag :scs (single-reg) :to :save)) + (imag :scs (single-reg) :to :save)) (:arg-types single-float single-float) (:results (r :scs (complex-single-reg) :from (:argument 0) - :load-if (not (sc-is r complex-single-stack)))) + :load-if (not (sc-is r complex-single-stack)))) (:result-types complex-single-float) (:note "inline complex single-float creation") (:policy :fast-safe) @@ -759,24 +759,24 @@ (sc-case r (complex-single-reg (let ((r-real (complex-single-reg-real-tn r))) - (unless (location= real r-real) - (inst fmove real r-real))) + (unless (location= real r-real) + (inst fmove real r-real))) (let ((r-imag (complex-single-reg-imag-tn r))) - (unless (location= imag r-imag) - (inst fmove imag r-imag)))) + (unless (location= imag r-imag) + (inst fmove imag r-imag)))) (complex-single-stack (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset r) n-word-bytes))) - (inst sts real offset nfp) - (inst sts imag (+ offset n-word-bytes) nfp)))))) + (offset (* (tn-offset r) n-word-bytes))) + (inst sts real offset nfp) + (inst sts imag (+ offset n-word-bytes) nfp)))))) (define-vop (make-complex-double-float) (:translate complex) (:args (real :scs (double-reg) :target r) - (imag :scs (double-reg) :to :save)) + (imag :scs (double-reg) :to :save)) (:arg-types double-float double-float) (:results (r :scs (complex-double-reg) :from (:argument 0) - :load-if (not (sc-is r complex-double-stack)))) + :load-if (not (sc-is r complex-double-stack)))) (:result-types complex-double-float) (:note "inline complex double-float creation") (:policy :fast-safe) @@ -785,20 +785,20 @@ (sc-case r (complex-double-reg (let ((r-real (complex-double-reg-real-tn r))) - (unless (location= real r-real) - (inst fmove real r-real))) + (unless (location= real r-real) + (inst fmove real r-real))) (let ((r-imag (complex-double-reg-imag-tn r))) - (unless (location= imag r-imag) - (inst fmove imag r-imag)))) + (unless (location= imag r-imag) + (inst fmove imag r-imag)))) (complex-double-stack (let ((nfp (current-nfp-tn vop)) - (offset (* (tn-offset r) n-word-bytes))) - (inst stt real offset nfp) - (inst stt imag (+ offset (* 2 n-word-bytes)) nfp)))))) + (offset (* (tn-offset r) n-word-bytes))) + (inst stt real offset nfp) + (inst stt imag (+ offset (* 2 n-word-bytes)) nfp)))))) (define-vop (complex-single-float-value) (:args (x :scs (complex-single-reg) :target r - :load-if (not (sc-is x complex-single-stack)))) + :load-if (not (sc-is x complex-single-stack)))) (:arg-types complex-single-float) (:results (r :scs (single-reg))) (:result-types single-float) @@ -809,14 +809,14 @@ (sc-case x (complex-single-reg (let ((value-tn (ecase slot - (:real (complex-single-reg-real-tn x)) - (:imag (complex-single-reg-imag-tn x))))) - (unless (location= value-tn r) - (inst fmove value-tn r)))) + (:real (complex-single-reg-real-tn x)) + (:imag (complex-single-reg-imag-tn x))))) + (unless (location= value-tn r) + (inst fmove value-tn r)))) (complex-single-stack (inst lds r (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x)) - n-word-bytes) - (current-nfp-tn vop)))))) + n-word-bytes) + (current-nfp-tn vop)))))) (define-vop (realpart/complex-single-float complex-single-float-value) (:translate realpart) @@ -830,7 +830,7 @@ (define-vop (complex-double-float-value) (:args (x :scs (complex-double-reg) :target r - :load-if (not (sc-is x complex-double-stack)))) + :load-if (not (sc-is x complex-double-stack)))) (:arg-types complex-double-float) (:results (r :scs (double-reg))) (:result-types double-float) @@ -841,14 +841,14 @@ (sc-case x (complex-double-reg (let ((value-tn (ecase slot - (:real (complex-double-reg-real-tn x)) - (:imag (complex-double-reg-imag-tn x))))) - (unless (location= value-tn r) - (inst fmove value-tn r)))) + (:real (complex-double-reg-real-tn x)) + (:imag (complex-double-reg-imag-tn x))))) + (unless (location= value-tn r) + (inst fmove value-tn r)))) (complex-double-stack (inst ldt r (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x)) - n-word-bytes) - (current-nfp-tn vop)))))) + n-word-bytes) + (current-nfp-tn vop)))))) (define-vop (realpart/complex-double-float complex-double-float-value) (:translate realpart) diff --git a/src/compiler/alpha/insts.lisp b/src/compiler/alpha/insts.lisp index a06ca47..549bf7d 100644 --- a/src/compiler/alpha/insts.lisp +++ b/src/compiler/alpha/insts.lisp @@ -50,20 +50,20 @@ (defparameter reg-symbols (map 'vector (lambda (name) - (cond ((null name) nil) - (t (make-symbol (concatenate 'string "$" name))))) + (cond ((null name) nil) + (t (make-symbol (concatenate 'string "$" name))))) *register-names*)) (sb!disassem:define-arg-type reg :printer (lambda (value stream dstate) - (declare (stream stream) (fixnum value)) - (let ((regname (aref reg-symbols value))) - (princ regname stream) - (sb!disassem:maybe-note-associated-storage-ref - value - 'registers - regname - dstate)))) + (declare (stream stream) (fixnum value)) + (let ((regname (aref reg-symbols value))) + (princ regname stream) + (sb!disassem:maybe-note-associated-storage-ref + value + 'registers + regname + dstate)))) (defparameter float-reg-symbols #.(coerce @@ -72,21 +72,21 @@ (sb!disassem:define-arg-type fp-reg :printer (lambda (value stream dstate) - (declare (stream stream) (fixnum value)) - (let ((regname (aref float-reg-symbols value))) - (princ regname stream) - (sb!disassem:maybe-note-associated-storage-ref - value - 'float-registers - regname - dstate)))) + (declare (stream stream) (fixnum value)) + (let ((regname (aref float-reg-symbols value))) + (princ regname stream) + (sb!disassem:maybe-note-associated-storage-ref + value + 'float-registers + regname + dstate)))) (sb!disassem:define-arg-type relative-label :sign-extend t :use-label (lambda (value dstate) - (declare (type (signed-byte 21) value) - (type sb!disassem:disassem-state dstate)) - (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate)))) + (declare (type (signed-byte 21) value) + (type sb!disassem:disassem-state dstate)) + (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate)))) @@ -237,7 +237,7 @@ (define-jump jsr 1) (define-jump ret 2) (define-jump jsr-coroutine 3)) - + (macrolet ((define-branch (name op &optional (float nil)) `(define-instruction ,name (segment ra target) @@ -249,13 +249,13 @@ (:emitter (emit-back-patch segment 4 (lambda (segment posn) - (emit-branch segment ,op - ,@(if float - '((fp-reg-tn-encoding ra)) + (emit-branch segment ,op + ,@(if float + '((fp-reg-tn-encoding ra)) '((reg-tn-encoding ra))) - (ash (- (label-position target) - (+ posn 4)) - -2)))))))) + (ash (- (label-position target) + (+ posn 4)) + -2)))))))) (define-branch br #x30) (define-branch bsr #x34) (define-branch blbc #x38) @@ -314,7 +314,7 @@ (define-operate s8addq #x10 #x32) (define-operate s8subl #x10 #x1b) (define-operate s8subq #x10 #x3b) - + (define-operate and #x11 #x00) (define-operate bic #x11 #x08) (define-operate cmoveq #x11 #x24) @@ -329,7 +329,7 @@ (define-operate eqv #x11 #x48) (define-operate cmovle #x11 #x64) (define-operate cmovgt #x11 #x66) - + (define-operate sll #x12 #x39) (define-operate extbl #x12 #x06) (define-operate extwl #x12 #x16) @@ -356,7 +356,7 @@ (define-operate mskqh #x12 #x72) (define-operate zap #x12 #x30) (define-operate zapnot #x12 #x31) - + (define-operate mull #x13 #x00) (define-operate mulq/v #x13 #x60) (define-operate mull/v #x13 #x40) @@ -417,11 +417,11 @@ (define-fp-operate subt #x16 #x0a1) ;;; IEEE support - (def!constant +su+ #x500) ; software, underflow enabled - (def!constant +sui+ #x700) ; software, inexact & underflow enabled - (def!constant +sv+ #x500) ; software, interger overflow enabled + (def!constant +su+ #x500) ; software, underflow enabled + (def!constant +sui+ #x700) ; software, inexact & underflow enabled + (def!constant +sv+ #x500) ; software, interger overflow enabled (def!constant +svi+ #x700) - (def!constant +rnd+ #x0c0) ; dynamic rounding mode + (def!constant +rnd+ #x0c0) ; dynamic rounding mode (def!constant +sud+ #x5c0) (def!constant +svid+ #x7c0) (def!constant +suid+ #x7c0) @@ -434,7 +434,7 @@ (define-fp-operate cvttq_sv #x16 (logior +su+ #x0af) 2) (define-fp-operate cvttq/c_sv #x16 (logior +su+ #x02f) 2) - + (define-fp-operate adds_su #x16 (logior +su+ #x080)) (define-fp-operate addt_su #x16 (logior +su+ #x0a0)) (define-fp-operate divs_su #x16 (logior +su+ #x083)) @@ -446,7 +446,7 @@ (define-instruction excb (segment) (:emitter (emit-lword segment #x63ff0400))) - + (define-instruction trapb (segment) (:emitter (emit-lword segment #x63ff0000))) @@ -483,40 +483,40 @@ (inst lda reg value zero-tn)) ((signed-byte 32) (flet ((se (x n) - (let ((x (logand x (lognot (ash -1 n))))) - (if (logbitp (1- n) x) - (logior (ash -1 (1- n)) x) - x)))) + (let ((x (logand x (lognot (ash -1 n))))) + (if (logbitp (1- n) x) + (logior (ash -1 (1- n)) x) + x)))) (let* ((value (se value 32)) - (low (ldb (byte 16 0) value)) - (tmp1 (- value (se low 16))) - (high (ldb (byte 16 16) tmp1)) - (tmp2 (- tmp1 (se (ash high 16) 32))) - (extra 0)) - (unless (= tmp2 0) - (setf extra #x4000) - (setf tmp1 (- tmp1 #x40000000)) - (setf high (ldb (byte 16 16) tmp1))) - (inst lda reg low zero-tn) - (unless (= extra 0) - (inst ldah reg extra reg)) - (unless (= high 0) - (inst ldah reg high reg))))) + (low (ldb (byte 16 0) value)) + (tmp1 (- value (se low 16))) + (high (ldb (byte 16 16) tmp1)) + (tmp2 (- tmp1 (se (ash high 16) 32))) + (extra 0)) + (unless (= tmp2 0) + (setf extra #x4000) + (setf tmp1 (- tmp1 #x40000000)) + (setf high (ldb (byte 16 16) tmp1))) + (inst lda reg low zero-tn) + (unless (= extra 0) + (inst ldah reg extra reg)) + (unless (= high 0) + (inst ldah reg high reg))))) ((or (unsigned-byte 32) (signed-byte 64) (unsigned-byte 64)) ;; Since it took NJF and CSR a good deal of puzzling to work out ;; (a) what a previous version of this was doing and (b) why it ;; was wrong: ;; - ;; write VALUE = a_63 * 2^63 + a_48-62 * 2^48 + ;; write VALUE = a_63 * 2^63 + a_48-62 * 2^48 ;; + a_47 * 2^47 + a_32-46 * 2^32 ;; + a_31 * 2^31 + a_16-30 * 2^16 ;; + a_15 * 2^15 + a_0-14 ;; ;; then, because of the wonders of sign-extension and ;; twos-complement arithmetic modulo 2^64, if a_15 is set, LDA - ;; (which sign-extends its argument) will add + ;; (which sign-extends its argument) will add ;; - ;; (a_15 * 2^15 + a_0-14 - 65536). + ;; (a_15 * 2^15 + a_0-14 - 65536). ;; ;; So we need to add that 65536 back on, which is what this ;; LOGBITP business is doing. The same applies for bits 31 and @@ -526,28 +526,28 @@ ;; ;; I think, anyway. -- CSR, 2003-09-26 (let* ((value1 (if (logbitp 15 value) (+ value (ash 1 16)) value)) - (value2 (if (logbitp 31 value1) (+ value1 (ash 1 32)) value1)) - (value3 (if (logbitp 47 value2) (+ value2 (ash 1 48)) value2))) + (value2 (if (logbitp 31 value1) (+ value1 (ash 1 32)) value1)) + (value3 (if (logbitp 47 value2) (+ value2 (ash 1 48)) value2))) (inst lda reg (ldb (byte 16 32) value2) zero-tn) ;; FIXME: Don't yet understand these conditionals. If I'm ;; right, surely we can just consider the zeroness of the ;; particular bitfield, not the zeroness of the whole thing? ;; -- CSR, 2003-09-26 (unless (= value3 0) - (inst ldah reg (ldb (byte 16 48) value3) reg)) + (inst ldah reg (ldb (byte 16 48) value3) reg)) (unless (and (= value2 0) (= value3 0)) - (inst sll reg 32 reg)) + (inst sll reg 32 reg)) (unless (= value 0) - (inst lda reg (ldb (byte 16 0) value) reg)) + (inst lda reg (ldb (byte 16 0) value) reg)) (unless (= value1 0) - (inst ldah reg (ldb (byte 16 16) value1) reg)))) + (inst ldah reg (ldb (byte 16 16) value1) reg)))) (fixup (inst lda reg value zero-tn :bits-47-32) (inst ldah reg value reg :bits-63-48) (inst sll reg 32 reg) (inst lda reg value reg) (inst ldah reg value reg)))) - + (define-instruction-macro li (value reg) `(%li ,value ,reg)) @@ -577,9 +577,9 @@ segment 4 (lambda (segment posn) (emit-lword segment - (logior type - (ash (+ posn (component-header-length)) - (- n-widetag-bits word-shift))))))) + (logior type + (ash (+ posn (component-header-length)) + (- n-widetag-bits word-shift))))))) (define-instruction simple-fun-header-word (segment) (:cost 0) @@ -599,33 +599,33 @@ (lambda (segment posn delta-if-after) (let ((delta (funcall calc label posn delta-if-after))) (when (<= (- (ash 1 15)) delta (1- (ash 1 15))) - (emit-back-patch segment 4 - (lambda (segment posn) - (assemble (segment vop) - (inst lda dst - (funcall calc label posn 0) - src)))) - t))) + (emit-back-patch segment 4 + (lambda (segment posn) + (assemble (segment vop) + (inst lda dst + (funcall calc label posn 0) + src)))) + t))) (lambda (segment posn) (assemble (segment vop) - (flet ((se (x n) - (let ((x (logand x (lognot (ash -1 n))))) - (if (logbitp (1- n) x) - (logior (ash -1 (1- n)) x) - x)))) - (let* ((value (se (funcall calc label posn 0) 32)) - (low (ldb (byte 16 0) value)) - (tmp1 (- value (se low 16))) - (high (ldb (byte 16 16) tmp1)) - (tmp2 (- tmp1 (se (ash high 16) 32))) - (extra 0)) - (unless (= tmp2 0) - (setf extra #x4000) - (setf tmp1 (- tmp1 #x40000000)) - (setf high (ldb (byte 16 16) tmp1))) - (inst lda dst low src) - (inst ldah dst extra dst) - (inst ldah dst high dst))))))) + (flet ((se (x n) + (let ((x (logand x (lognot (ash -1 n))))) + (if (logbitp (1- n) x) + (logior (ash -1 (1- n)) x) + x)))) + (let* ((value (se (funcall calc label posn 0) 32)) + (low (ldb (byte 16 0) value)) + (tmp1 (- value (se low 16))) + (high (ldb (byte 16 16) tmp1)) + (tmp2 (- tmp1 (se (ash high 16) 32))) + (extra 0)) + (unless (= tmp2 0) + (setf extra #x4000) + (setf tmp1 (- tmp1 #x40000000)) + (setf high (ldb (byte 16 16) tmp1))) + (inst lda dst low src) + (inst ldah dst extra dst) + (inst ldah dst high dst))))))) ;; code = fn - header - label-offset + other-pointer-tag (define-instruction compute-code-from-fn (segment dst src label temp) @@ -633,10 +633,10 @@ (:vop-var vop) (:emitter (emit-compute-inst segment vop dst src label temp - (lambda (label posn delta-if-after) - (- other-pointer-lowtag - (label-position label posn delta-if-after) - (component-header-length)))))) + (lambda (label posn delta-if-after) + (- other-pointer-lowtag + (label-position label posn delta-if-after) + (component-header-length)))))) ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag ;; = lra - (header + label-offset) @@ -645,9 +645,9 @@ (:vop-var vop) (:emitter (emit-compute-inst segment vop dst src label temp - (lambda (label posn delta-if-after) - (- (+ (label-position label posn delta-if-after) - (component-header-length))))))) + (lambda (label posn delta-if-after) + (- (+ (label-position label posn delta-if-after) + (component-header-length))))))) ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag (define-instruction compute-lra-from-code (segment dst src label temp) @@ -655,6 +655,6 @@ (:vop-var vop) (:emitter (emit-compute-inst segment vop dst src label temp - (lambda (label posn delta-if-after) - (+ (label-position label posn delta-if-after) - (component-header-length)))))) + (lambda (label posn delta-if-after) + (+ (label-position label posn delta-if-after) + (component-header-length)))))) diff --git a/src/compiler/alpha/macros.lisp b/src/compiler/alpha/macros.lisp index 7aaebf6..2132345 100644 --- a/src/compiler/alpha/macros.lisp +++ b/src/compiler/alpha/macros.lisp @@ -16,8 +16,8 @@ (defmacro expand (expr) (let ((gensym (gensym))) `(macrolet - ((,gensym () - ,expr)) + ((,gensym () + ,expr)) (,gensym)))) ;;; instruction-like macros @@ -59,27 +59,27 @@ (defmacro load-symbol-value (reg symbol) `(inst ldl ,reg - (+ (static-symbol-offset ',symbol) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag)) - null-tn)) + (+ (static-symbol-offset ',symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag)) + null-tn)) (defmacro store-symbol-value (reg symbol) `(inst stl ,reg - (+ (static-symbol-offset ',symbol) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag)) - null-tn)) + (+ (static-symbol-offset ',symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag)) + null-tn)) (defmacro load-type (target source &optional (offset 0)) "Loads the type bits of a pointer into target independent of byte-ordering issues." (once-only ((n-target target) - (n-source source) - (n-offset offset)) + (n-source source) + (n-offset offset)) `(progn - (inst ldl ,n-target ,n-offset ,n-source) - (inst and ,n-target #xff ,n-target)))) + (inst ldl ,n-target ,n-offset ,n-source) + (inst and ,n-target #xff ,n-target)))) ;;; macros to handle the fact that we cannot use the machine native ;;; call and return instructions @@ -88,19 +88,19 @@ "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." `(progn (inst lda ,lip (- (ash simple-fun-code-offset word-shift) - fun-pointer-lowtag) - ,function) + fun-pointer-lowtag) + ,function) (move ,function code-tn) (inst jsr zero-tn ,lip 1))) (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t)) "Return to RETURN-PC. LIP is an interior-reg temporary." `(progn - (inst lda ,lip - (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag) - ,return-pc) + (inst lda ,lip + (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag) + ,return-pc) ,@(when frob-code - `((move ,return-pc code-tn))) + `((move ,return-pc code-tn))) (inst ret zero-tn ,lip 1))) @@ -119,45 +119,45 @@ ;;; Move a stack TN to a register and vice-versa. (defmacro load-stack-tn (reg stack) `(let ((reg ,reg) - (stack ,stack)) + (stack ,stack)) (let ((offset (tn-offset stack))) (sc-case stack - ((control-stack) - (loadw reg cfp-tn offset)))))) + ((control-stack) + (loadw reg cfp-tn offset)))))) (defmacro store-stack-tn (stack reg) `(let ((stack ,stack) - (reg ,reg)) + (reg ,reg)) (let ((offset (tn-offset stack))) (sc-case stack - ((control-stack) - (storew reg cfp-tn offset)))))) + ((control-stack) + (storew reg cfp-tn offset)))))) ;;; Move the TN Reg-Or-Stack into Reg if it isn't already there. (defmacro maybe-load-stack-tn (reg reg-or-stack) (once-only ((n-reg reg) - (n-stack reg-or-stack)) + (n-stack reg-or-stack)) `(sc-case ,n-reg ((any-reg descriptor-reg) - (sc-case ,n-stack - ((any-reg descriptor-reg) - (move ,n-stack ,n-reg)) - ((control-stack) - (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) + (sc-case ,n-stack + ((any-reg descriptor-reg) + (move ,n-stack ,n-reg)) + ((control-stack) + (loadw ,n-reg cfp-tn (tn-offset ,n-stack)))))))) ;;; Move the TN Reg-Or-Stack into Reg if it isn't already there. (defmacro maybe-load-stack-nfp-tn (reg reg-or-stack temp) (once-only ((n-reg reg) - (n-stack reg-or-stack)) + (n-stack reg-or-stack)) `(when ,reg - (sc-case ,n-reg - ((any-reg descriptor-reg) - (sc-case ,n-stack - ((any-reg descriptor-reg) - (move ,n-stack ,n-reg)) - ((control-stack) - (loadw ,n-reg cfp-tn (tn-offset ,n-stack)) - (inst mskll nsp-tn 0 ,temp) - (inst bis ,temp ,n-reg ,n-reg)))))))) + (sc-case ,n-reg + ((any-reg descriptor-reg) + (sc-case ,n-stack + ((any-reg descriptor-reg) + (move ,n-stack ,n-reg)) + ((control-stack) + (loadw ,n-reg cfp-tn (tn-offset ,n-stack)) + (inst mskll nsp-tn 0 ,temp) + (inst bis ,temp ,n-reg ,n-reg)))))))) ;;;; storage allocation @@ -168,7 +168,7 @@ ;;; the body.) The body is placed inside the PSEUDO-ATOMIC, and ;;; presumably initializes the object. (defmacro with-fixed-allocation ((result-tn temp-tn widetag size) - &body body) + &body body) (unless body (bug "empty &body in WITH-FIXED-ALLOCATION")) (once-only ((result-tn result-tn) (temp-tn temp-tn) (size size)) @@ -188,31 +188,31 @@ (emit-label aligned))) ;;;; error code -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (:compile-toplevel :load-toplevel :execute) (defun emit-error-break (vop kind code values) (let ((vector (gensym))) `((let ((vop ,vop)) - (when vop - (note-this-location vop :internal-error))) - (inst gentrap ,kind) - (with-adjustable-vector (,vector) - (write-var-integer (error-number-or-lose ',code) ,vector) - ,@(mapcar (lambda (tn) - `(let ((tn ,tn)) - (write-var-integer (make-sc-offset (sc-number - (tn-sc tn)) - (tn-offset tn)) - ,vector))) - values) - (inst byte (length ,vector)) - (dotimes (i (length ,vector)) - (inst byte (aref ,vector i)))) - (align word-shift))))) + (when vop + (note-this-location vop :internal-error))) + (inst gentrap ,kind) + (with-adjustable-vector (,vector) + (write-var-integer (error-number-or-lose ',code) ,vector) + ,@(mapcar (lambda (tn) + `(let ((tn ,tn)) + (write-var-integer (make-sc-offset (sc-number + (tn-sc tn)) + (tn-offset tn)) + ,vector))) + values) + (inst byte (length ,vector)) + (dotimes (i (length ,vector)) + (inst byte (aref ,vector i)))) + (align word-shift))))) (defmacro error-call (vop error-code &rest values) "Cause an error. ERROR-CODE is the error to cause." (cons 'progn - (emit-error-break vop error-trap error-code values))) + (emit-error-break vop error-trap error-code values))) (defmacro cerror-call (vop label error-code &rest values) @@ -240,10 +240,10 @@ `(let ((,continue (gen-label))) (emit-label ,continue) (assemble (*elsewhere*) - (let ((,error (gen-label))) - (emit-label ,error) - (cerror-call ,vop ,continue ,error-code ,@values) - ,error))))) + (let ((,error (gen-label))) + (emit-label ,error) + (cerror-call ,vop ,continue ,error-code ,@values) + ,error))))) ;;; a handy macro for making sequences look atomic @@ -257,272 +257,272 @@ ;;;; memory accessor vop generators (defmacro define-full-reffer (name type offset lowtag scs el-type - &optional translate) + &optional translate) `(progn (define-vop (,name) ,@(when translate - `((:translate ,translate))) + `((:translate ,translate))) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg))) + (index :scs (any-reg))) (:arg-types ,type tagged-num) (:temporary (:scs (interior-reg)) lip) (:results (value :scs ,scs)) (:result-types ,el-type) (:generator 5 - (inst addq object index lip) - (inst ldl value (- (* ,offset n-word-bytes) ,lowtag) lip) - ,@(when (equal scs '(unsigned-reg)) - '((inst mskll value 4 value))))) + (inst addq object index lip) + (inst ldl value (- (* ,offset n-word-bytes) ,lowtag) lip) + ,@(when (equal scs '(unsigned-reg)) + '((inst mskll value 4 value))))) (define-vop (,(symbolicate name "-C")) ,@(when translate - `((:translate ,translate))) + `((:translate ,translate))) (:policy :fast-safe) (:args (object :scs (descriptor-reg))) (:info index) (:arg-types ,type - (:constant (load/store-index ,n-word-bytes ,(eval lowtag) - ,(eval offset)))) + (:constant (load/store-index ,n-word-bytes ,(eval lowtag) + ,(eval offset)))) (:results (value :scs ,scs)) (:result-types ,el-type) (:generator 4 - (inst ldl value (- (* (+ ,offset index) n-word-bytes) ,lowtag) - object) - ,@(when (equal scs '(unsigned-reg)) - '((inst mskll value 4 value))))))) + (inst ldl value (- (* (+ ,offset index) n-word-bytes) ,lowtag) + object) + ,@(when (equal scs '(unsigned-reg)) + '((inst mskll value 4 value))))))) (defmacro define-full-setter (name type offset lowtag scs el-type - &optional translate #!+gengc (remember t)) + &optional translate #!+gengc (remember t)) `(progn (define-vop (,name) ,@(when translate - `((:translate ,translate))) + `((:translate ,translate))) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (any-reg)) - (value :scs ,scs :target result)) + (index :scs (any-reg)) + (value :scs ,scs :target result)) (:arg-types ,type tagged-num ,el-type) (:temporary (:scs (interior-reg)) lip) (:results (result :scs ,scs)) (:result-types ,el-type) (:generator 2 - (inst addq index object lip) - (inst stl value (- (* ,offset n-word-bytes) ,lowtag) lip) - (move value result))) + (inst addq index object lip) + (inst stl value (- (* ,offset n-word-bytes) ,lowtag) lip) + (move value result))) (define-vop (,(symbolicate name "-C")) ,@(when translate - `((:translate ,translate))) + `((:translate ,translate))) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (value :scs ,scs)) + (value :scs ,scs)) (:info index) (:arg-types ,type - (:constant (load/store-index ,n-word-bytes ,(eval lowtag) - ,(eval offset))) - ,el-type) + (:constant (load/store-index ,n-word-bytes ,(eval lowtag) + ,(eval offset))) + ,el-type) (:results (result :scs ,scs)) (:result-types ,el-type) (:generator 1 - (inst stl value (- (* (+ ,offset index) n-word-bytes) ,lowtag) - object) - (move value result))))) + (inst stl value (- (* (+ ,offset index) n-word-bytes) ,lowtag) + object) + (move value result))))) (defmacro define-partial-reffer (name type size signed offset lowtag scs - el-type &optional translate) + el-type &optional translate) (let ((scale (ecase size (:byte 1) (:short 2)))) `(progn (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) - (:arg-types ,type positive-fixnum) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:sc non-descriptor-reg) temp) - (:temporary (:sc non-descriptor-reg) temp1) - (:generator 5 - (inst addq object index lip) - ,@(when (eq size :short) - '((inst addq index lip lip))) - ,@(ecase size - (:byte - (if signed - `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag) - lip) - (inst lda temp1 (1+ (- (* ,offset n-word-bytes) ,lowtag)) - lip) - (inst extqh temp temp1 temp) - (inst sra temp 56 value)) - `((inst ldq_u - temp - (- (* ,offset n-word-bytes) ,lowtag) - lip) - (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) - lip) - (inst extbl temp temp1 value)))) - (:short - (if signed - `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag) - lip) - (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) - lip) - (inst extwl temp temp1 temp) - (inst sll temp 48 temp) - (inst sra temp 48 value)) - `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag) - lip) - (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) - (inst extwl temp temp1 value))))))) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg))) + (:arg-types ,type positive-fixnum) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:sc non-descriptor-reg) temp) + (:temporary (:sc non-descriptor-reg) temp1) + (:generator 5 + (inst addq object index lip) + ,@(when (eq size :short) + '((inst addq index lip lip))) + ,@(ecase size + (:byte + (if signed + `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag) + lip) + (inst lda temp1 (1+ (- (* ,offset n-word-bytes) ,lowtag)) + lip) + (inst extqh temp temp1 temp) + (inst sra temp 56 value)) + `((inst ldq_u + temp + (- (* ,offset n-word-bytes) ,lowtag) + lip) + (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) + lip) + (inst extbl temp temp1 value)))) + (:short + (if signed + `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag) + lip) + (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) + lip) + (inst extwl temp temp1 temp) + (inst sll temp 48 temp) + (inst sra temp 48 value)) + `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag) + lip) + (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) + (inst extwl temp temp1 value))))))) (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg))) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,scale - ,(eval lowtag) - ,(eval offset)))) - (:results (value :scs ,scs)) - (:result-types ,el-type) - (:temporary (:sc non-descriptor-reg) temp) - (:temporary (:sc non-descriptor-reg) temp1) - (:generator 4 - ,@(ecase size - (:byte - (if signed - `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst lda temp1 (1+ (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag)) - object) - (inst extqh temp temp1 temp) - (inst sra temp 56 value)) - `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst lda temp1 (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst extbl temp temp1 value)))) - (:short - (if signed - `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst lda temp1 (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst extwl temp temp1 temp) - (inst sll temp 48 temp) - (inst sra temp 48 value)) - `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst lda temp1 (- (+ (* ,offset n-word-bytes) - (* index ,scale)) ,lowtag) - object) - (inst extwl temp temp1 value)))))))))) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types ,type + (:constant (load/store-index ,scale + ,(eval lowtag) + ,(eval offset)))) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:temporary (:sc non-descriptor-reg) temp) + (:temporary (:sc non-descriptor-reg) temp1) + (:generator 4 + ,@(ecase size + (:byte + (if signed + `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) + (* index ,scale)) ,lowtag) + object) + (inst lda temp1 (1+ (- (+ (* ,offset n-word-bytes) + (* index ,scale)) ,lowtag)) + object) + (inst extqh temp temp1 temp) + (inst sra temp 56 value)) + `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) + (* index ,scale)) ,lowtag) + object) + (inst lda temp1 (- (+ (* ,offset n-word-bytes) + (* index ,scale)) ,lowtag) + object) + (inst extbl temp temp1 value)))) + (:short + (if signed + `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) + (* index ,scale)) ,lowtag) + object) + (inst lda temp1 (- (+ (* ,offset n-word-bytes) + (* index ,scale)) ,lowtag) + object) + (inst extwl temp temp1 temp) + (inst sll temp 48 temp) + (inst sra temp 48 value)) + `((inst ldq_u temp (- (+ (* ,offset n-word-bytes) + (* index ,scale)) ,lowtag) + object) + (inst lda temp1 (- (+ (* ,offset n-word-bytes) + (* index ,scale)) ,lowtag) + object) + (inst extwl temp temp1 value)))))))))) (defmacro define-partial-setter (name type size offset lowtag scs el-type - &optional translate) + &optional translate) (let ((scale (ecase size (:byte 1) (:short 2)))) `(progn (define-vop (,name) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg)) - (value :scs ,scs :target result)) - (:arg-types ,type positive-fixnum ,el-type) - (:temporary (:scs (interior-reg)) lip) - (:temporary (:sc non-descriptor-reg) temp) - (:temporary (:sc non-descriptor-reg) temp1) - (:temporary (:sc non-descriptor-reg) temp2) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 5 - (inst addq object index lip) - ,@(when (eq size :short) - '((inst addq lip index lip))) - ,@(ecase size - (:byte - `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip) - (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) - (inst insbl value temp temp2) - (inst mskbl temp1 temp temp1) - (inst bis temp1 temp2 temp1) - (inst stq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip))) - (:short - `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip) - (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) - (inst mskwl temp1 temp temp1) - (inst inswl value temp temp2) - (inst bis temp1 temp2 temp) - (inst stq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip)))) - (move value result))) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (unsigned-reg)) + (value :scs ,scs :target result)) + (:arg-types ,type positive-fixnum ,el-type) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:sc non-descriptor-reg) temp) + (:temporary (:sc non-descriptor-reg) temp1) + (:temporary (:sc non-descriptor-reg) temp2) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 5 + (inst addq object index lip) + ,@(when (eq size :short) + '((inst addq lip index lip))) + ,@(ecase size + (:byte + `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip) + (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) + (inst insbl value temp temp2) + (inst mskbl temp1 temp temp1) + (inst bis temp1 temp2 temp1) + (inst stq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip))) + (:short + `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip) + (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip) + (inst mskwl temp1 temp temp1) + (inst inswl value temp temp2) + (inst bis temp1 temp2 temp) + (inst stq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip)))) + (move value result))) (define-vop (,(symbolicate name "-C")) - ,@(when translate - `((:translate ,translate))) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (value :scs ,scs :target result)) - (:info index) - (:arg-types ,type - (:constant (load/store-index ,scale - ,(eval lowtag) - ,(eval offset))) - ,el-type) - (:temporary (:sc non-descriptor-reg) temp) - (:temporary (:sc non-descriptor-reg) temp1) - (:temporary (:sc non-descriptor-reg) temp2) - (:results (result :scs ,scs)) - (:result-types ,el-type) - (:generator 4 - ,@(ecase size - (:byte - `((inst lda temp (- (+ (* ,offset n-word-bytes) - (* index ,scale)) - ,lowtag) - object) - (inst ldq_u temp1 (- (+ (* ,offset n-word-bytes) - (* index ,scale)) - ,lowtag) - object) - (inst insbl value temp temp2) - (inst mskbl temp1 temp temp1) - (inst bis temp1 temp2 temp1) - (inst stq_u temp1 (- (+ (* ,offset n-word-bytes) - (* index ,scale)) - ,lowtag) object))) - (:short - `((inst lda temp (- (+ (* ,offset n-word-bytes) - (* index ,scale)) - ,lowtag) - object) - (inst ldq_u temp1 (- (+ (* ,offset n-word-bytes) - (* index ,scale)) - ,lowtag) - object) - (inst mskwl temp1 temp temp1) - (inst inswl value temp temp2) - (inst bis temp1 temp2 temp) - (inst stq_u temp (- (+ (* ,offset n-word-bytes) - (* index ,scale)) - ,lowtag) object)))) - (move value result)))))) + ,@(when translate + `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs ,scs :target result)) + (:info index) + (:arg-types ,type + (:constant (load/store-index ,scale + ,(eval lowtag) + ,(eval offset))) + ,el-type) + (:temporary (:sc non-descriptor-reg) temp) + (:temporary (:sc non-descriptor-reg) temp1) + (:temporary (:sc non-descriptor-reg) temp2) + (:results (result :scs ,scs)) + (:result-types ,el-type) + (:generator 4 + ,@(ecase size + (:byte + `((inst lda temp (- (+ (* ,offset n-word-bytes) + (* index ,scale)) + ,lowtag) + object) + (inst ldq_u temp1 (- (+ (* ,offset n-word-bytes) + (* index ,scale)) + ,lowtag) + object) + (inst insbl value temp temp2) + (inst mskbl temp1 temp temp1) + (inst bis temp1 temp2 temp1) + (inst stq_u temp1 (- (+ (* ,offset n-word-bytes) + (* index ,scale)) + ,lowtag) object))) + (:short + `((inst lda temp (- (+ (* ,offset n-word-bytes) + (* index ,scale)) + ,lowtag) + object) + (inst ldq_u temp1 (- (+ (* ,offset n-word-bytes) + (* index ,scale)) + ,lowtag) + object) + (inst mskwl temp1 temp temp1) + (inst inswl value temp temp2) + (inst bis temp1 temp2 temp) + (inst stq_u temp (- (+ (* ,offset n-word-bytes) + (* index ,scale)) + ,lowtag) object)))) + (move value result)))))) (defmacro sb!sys::with-pinned-objects ((&rest objects) &body body) "Arrange with the garbage collector that the pages occupied by OBJECTS will not be moved in memory for the duration of BODY. Useful for e.g. foreign calls where another thread may trigger garbage collection. This is currently implemented by disabling GC" - (declare (ignore objects)) ;should we eval these for side-effect? + (declare (ignore objects)) ;should we eval these for side-effect? `(without-gcing ,@body)) diff --git a/src/compiler/alpha/memory.lisp b/src/compiler/alpha/memory.lisp index 426d580..fef2a83 100644 --- a/src/compiler/alpha/memory.lisp +++ b/src/compiler/alpha/memory.lisp @@ -41,7 +41,7 @@ (loadw value object (+ base offset) lowtag))) (define-vop (slot-set) (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg null zero))) + (value :scs (descriptor-reg any-reg null zero))) (:variant-vars base lowtag) (:info offset) (:generator 4 diff --git a/src/compiler/alpha/move.lisp b/src/compiler/alpha/move.lisp index abf30ae..bfdb4fe 100644 --- a/src/compiler/alpha/move.lisp +++ b/src/compiler/alpha/move.lisp @@ -24,7 +24,7 @@ (load-symbol y val)) (character (inst li (logior (ash (char-code val) n-widetag-bits) character-widetag) - y))))) + y))))) (define-move-fun (load-number 1) (vop x y) ((zero immediate) @@ -79,19 +79,19 @@ (define-vop (move) (:args (x :target y - :scs (any-reg descriptor-reg zero null) - :load-if (not (location= x y)))) + :scs (any-reg descriptor-reg zero null) + :load-if (not (location= x y)))) (:results (y :scs (any-reg descriptor-reg control-stack) - :load-if (not (location= x y)))) + :load-if (not (location= x y)))) (:effects) (:affected) (:generator 0 (unless (location= x y) (sc-case y - ((any-reg descriptor-reg) - (inst move x y)) - (control-stack - (store-stack-tn y x)))))) + ((any-reg descriptor-reg) + (inst move x y)) + (control-stack + (store-stack-tn y x)))))) (define-move-vop move :move (any-reg descriptor-reg zero null) @@ -106,9 +106,9 @@ ;;; another frame for argument or known value passing. (define-vop (move-arg) (:args (x :target y - :scs (any-reg descriptor-reg null zero)) - (fp :scs (any-reg) - :load-if (not (sc-is y any-reg descriptor-reg)))) + :scs (any-reg descriptor-reg null zero)) + (fp :scs (any-reg) + :load-if (not (sc-is y any-reg descriptor-reg)))) (:results (y)) (:generator 0 (sc-case y @@ -229,7 +229,7 @@ (inst cmoveq temp 1 header) (inst sll header n-widetag-bits header) (inst bis header bignum-widetag header) - + (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3))) (inst bis alloc-tn other-pointer-lowtag y) (storew header y 0 other-pointer-lowtag) @@ -254,7 +254,7 @@ (inst srl x n-positive-fixnum-bits temp) (inst sll x n-fixnum-tag-bits y) (inst beq temp done) - + (inst li 3 temp) (inst cmovge x 2 temp) (inst srl x 31 temp1) @@ -275,10 +275,10 @@ ;;; Move untagged numbers. (define-vop (word-move) (:args (x :target y - :scs (signed-reg unsigned-reg) - :load-if (not (location= x y)))) + :scs (signed-reg unsigned-reg) + :load-if (not (location= x y)))) (:results (y :scs (signed-reg unsigned-reg) - :load-if (not (location= x y)))) + :load-if (not (location= x y)))) (:effects) (:affected) (:note "word integer move") @@ -290,9 +290,9 @@ ;;; Move untagged number arguments/return-values. (define-vop (move-word-arg) (:args (x :target y - :scs (signed-reg unsigned-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y sap-reg)))) + :scs (signed-reg unsigned-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y sap-reg)))) (:results (y)) (:note "word integer argument move") (:generator 0 diff --git a/src/compiler/alpha/nlx.lisp b/src/compiler/alpha/nlx.lisp index 89c2e8d..14c3516 100644 --- a/src/compiler/alpha/nlx.lisp +++ b/src/compiler/alpha/nlx.lisp @@ -36,20 +36,20 @@ (define-vop (save-dynamic-state) (:results (catch :scs (descriptor-reg)) - (nfp :scs (descriptor-reg)) - (nsp :scs (descriptor-reg))) + (nfp :scs (descriptor-reg)) + (nsp :scs (descriptor-reg))) (:vop-var vop) (:generator 13 (load-symbol-value catch *current-catch-block*) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp - (inst mskll cur-nfp 4 nfp))) + (inst mskll cur-nfp 4 nfp))) (inst mskll nsp-tn 4 nsp))) (define-vop (restore-dynamic-state) (:args (catch :scs (descriptor-reg)) - (nfp :scs (descriptor-reg)) - (nsp :scs (descriptor-reg))) + (nfp :scs (descriptor-reg)) + (nsp :scs (descriptor-reg))) (:vop-var vop) (:temporary (:sc any-reg) temp) (:generator 10 @@ -57,7 +57,7 @@ (inst mskll nsp-tn 0 temp) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp - (inst bis nfp temp cur-nfp))) + (inst bis nfp temp cur-nfp))) (inst bis nsp temp nsp-tn))) (define-vop (current-stack-pointer) @@ -94,7 +94,7 @@ ;;; specified tag, and link the block into the Current-Catch list. (define-vop (make-catch-block) (:args (tn) - (tag :scs (any-reg descriptor-reg))) + (tag :scs (any-reg descriptor-reg))) (:info entry-label) (:results (block :scs (any-reg))) (:temporary (:scs (descriptor-reg)) temp) @@ -147,9 +147,9 @@ (define-vop (nlx-entry) (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops - ; would be inserted before the LRA. - (start) - (count)) + ; would be inserted before the LRA. + (start) + (count)) (:results (values :more t)) (:temporary (:scs (descriptor-reg)) move-temp) (:temporary (:sc non-descriptor-reg) temp) @@ -160,45 +160,45 @@ (emit-return-pc label) (note-this-location vop :non-local-entry) (cond ((zerop nvals)) - ((= nvals 1) - (let ((no-values (gen-label))) - (move null-tn (tn-ref-tn values)) - (inst beq count no-values) - (loadw (tn-ref-tn values) start) - (emit-label no-values))) - (t - (collect ((defaults)) - (do ((i 0 (1+ i)) - (tn-ref values (tn-ref-across tn-ref))) - ((null tn-ref)) - (let ((default-lab (gen-label)) - (tn (tn-ref-tn tn-ref))) - (defaults (cons default-lab tn)) - - (inst move count temp) - (inst lda count (fixnumize -1) count) - (inst beq temp default-lab) - (sc-case tn - ((descriptor-reg any-reg) - (loadw tn start i)) - (control-stack - (loadw move-temp start i) - (store-stack-tn tn move-temp))))) - - (let ((defaulting-done (gen-label))) - - (emit-label defaulting-done) - - (assemble (*elsewhere*) - (dolist (def (defaults)) - (emit-label (car def)) - (let ((tn (cdr def))) - (sc-case tn - ((descriptor-reg any-reg) - (move null-tn tn)) - (control-stack - (store-stack-tn tn null-tn))))) - (inst br zero-tn defaulting-done)))))) + ((= nvals 1) + (let ((no-values (gen-label))) + (move null-tn (tn-ref-tn values)) + (inst beq count no-values) + (loadw (tn-ref-tn values) start) + (emit-label no-values))) + (t + (collect ((defaults)) + (do ((i 0 (1+ i)) + (tn-ref values (tn-ref-across tn-ref))) + ((null tn-ref)) + (let ((default-lab (gen-label)) + (tn (tn-ref-tn tn-ref))) + (defaults (cons default-lab tn)) + + (inst move count temp) + (inst lda count (fixnumize -1) count) + (inst beq temp default-lab) + (sc-case tn + ((descriptor-reg any-reg) + (loadw tn start i)) + (control-stack + (loadw move-temp start i) + (store-stack-tn tn move-temp))))) + + (let ((defaulting-done (gen-label))) + + (emit-label defaulting-done) + + (assemble (*elsewhere*) + (dolist (def (defaults)) + (emit-label (car def)) + (let ((tn (cdr def))) + (sc-case tn + ((descriptor-reg any-reg) + (move null-tn tn)) + (control-stack + (store-stack-tn tn null-tn))))) + (inst br zero-tn defaulting-done)))))) (load-stack-tn csp-tn sp))) (define-vop (nlx-entry-multiple) @@ -217,7 +217,7 @@ (emit-return-pc label) (note-this-location vop :non-local-entry) (let ((loop (gen-label)) - (done (gen-label))) + (done (gen-label))) ;; Copy args. (load-stack-tn dst top) @@ -226,11 +226,11 @@ ;; Establish results. (sc-case new-start - (any-reg (move dst new-start)) - (control-stack (store-stack-tn new-start dst))) + (any-reg (move dst new-start)) + (control-stack (store-stack-tn new-start dst))) (sc-case new-count - (any-reg (inst move num new-count)) - (control-stack (store-stack-tn new-count num))) + (any-reg (inst move num new-count)) + (control-stack (store-stack-tn new-count num))) (inst beq num done) ;; Copy stuff on stack. diff --git a/src/compiler/alpha/parms.lisp b/src/compiler/alpha/parms.lisp index e7299a2..fce7a3f 100644 --- a/src/compiler/alpha/parms.lisp +++ b/src/compiler/alpha/parms.lisp @@ -77,11 +77,11 @@ (def!constant float-overflow-trap-bit (ash 1 2)) ; ro (def!constant float-divide-by-zero-trap-bit (ash 1 1)) ; ro (def!constant float-invalid-trap-bit (ash 1 0)) ; ro -(defconstant-eqx float-traps-byte (byte 6 1) #'equalp) +(defconstant-eqx float-traps-byte (byte 6 1) #'equalp) ;;; exceptions are also read/written in software (by syscalls, no less). ;;; This is kind of dumb, but has to be done -(defconstant-eqx float-sticky-bits (byte 6 17) #'equalp) ; fp_control +(defconstant-eqx float-sticky-bits (byte 6 17) #'equalp) ; fp_control ;;; (We don't actually _have_ "current exceptions" on Alpha; the ;;; hardware only ever sets bits. So, set this the same as accrued @@ -93,7 +93,7 @@ (def!constant float-round-to-negative 1) (def!constant float-round-to-nearest 2) (def!constant float-round-to-positive 3) -(defconstant-eqx float-rounding-mode (byte 2 58) #'equalp) +(defconstant-eqx float-rounding-mode (byte 2 58) #'equalp) ;;; Miscellaneous stuff - I think it's far to say that you deserve ;;; what you get if you ask for fast mode. @@ -211,8 +211,8 @@ sb!kernel:two-arg-> sb!kernel:two-arg-= ;; FIXME: Is this - ;; probably need the following as they are defined in - ;; arith.lisp: two-arg-<= two-arg->= two-arg-/= + ;; probably need the following as they are defined in + ;; arith.lisp: two-arg-<= two-arg->= two-arg-/= ;; a comment from old CMU CL or old old CMU CL or ;; the SBCL alpha port or what? Do we need to worry about it, ;; or can we delete it? diff --git a/src/compiler/alpha/pred.lisp b/src/compiler/alpha/pred.lisp index d8296b7..88e5fa7 100644 --- a/src/compiler/alpha/pred.lisp +++ b/src/compiler/alpha/pred.lisp @@ -25,7 +25,7 @@ (define-vop (if-eq) (:args (x :scs (any-reg descriptor-reg zero null)) - (y :scs (any-reg descriptor-reg zero null))) + (y :scs (any-reg descriptor-reg zero null))) (:conditional) (:temporary (:scs (non-descriptor-reg)) temp) (:info target not-p) @@ -34,5 +34,5 @@ (:generator 3 (inst cmpeq x y temp) (if not-p - (inst beq temp target) - (inst bne temp target)))) + (inst beq temp target) + (inst bne temp target)))) diff --git a/src/compiler/alpha/sanctify.lisp b/src/compiler/alpha/sanctify.lisp index 2f3627d..1abc6e0 100644 --- a/src/compiler/alpha/sanctify.lisp +++ b/src/compiler/alpha/sanctify.lisp @@ -7,7 +7,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. diff --git a/src/compiler/alpha/sap.lisp b/src/compiler/alpha/sap.lisp index e6c39c5..6fa3a7d 100644 --- a/src/compiler/alpha/sap.lisp +++ b/src/compiler/alpha/sap.lisp @@ -40,10 +40,10 @@ ;;; Move untagged SAP values. (define-vop (sap-move) (:args (x :target y - :scs (sap-reg) - :load-if (not (location= x y)))) + :scs (sap-reg) + :load-if (not (location= x y)))) (:results (y :scs (sap-reg) - :load-if (not (location= x y)))) + :load-if (not (location= x y)))) (:effects) (:affected) (:generator 0 @@ -54,9 +54,9 @@ ;;; Move untagged SAP arguments/return-values. (define-vop (move-sap-arg) (:args (x :target y - :scs (sap-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y sap-reg)))) + :scs (sap-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y sap-reg)))) (:results (y)) (:generator 0 (sc-case y @@ -99,7 +99,7 @@ (define-vop (pointer+) (:translate sap+) (:args (ptr :scs (sap-reg)) - (offset :scs (signed-reg immediate))) + (offset :scs (signed-reg immediate))) (:arg-types system-area-pointer signed-num) (:results (res :scs (sap-reg))) (:result-types system-area-pointer) @@ -114,7 +114,7 @@ (define-vop (pointer-) (:translate sap-) (:args (ptr1 :scs (sap-reg)) - (ptr2 :scs (sap-reg))) + (ptr2 :scs (sap-reg))) (:arg-types system-area-pointer system-area-pointer) (:policy :fast-safe) (:results (res :scs (signed-reg))) @@ -220,9 +220,9 @@ '((inst lds result offset object))) (:double '((inst ldt - result - (+ offset n-word-bytes) - object)))))) + result + (+ offset n-word-bytes) + object)))))) (define-vop (,set-name) (:translate ,set-name) (:policy :fast-safe) @@ -354,5 +354,5 @@ (:result-types system-area-pointer) (:generator 2 (inst lda sap - (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) - vector))) + (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) + vector))) diff --git a/src/compiler/alpha/show.lisp b/src/compiler/alpha/show.lisp index 468718b..9d1a74d 100644 --- a/src/compiler/alpha/show.lisp +++ b/src/compiler/alpha/show.lisp @@ -16,7 +16,7 @@ (:results (result :scs (descriptor-reg))) (:save-p t) (:temporary (:sc any-reg :offset cfunc-offset :target result :to (:result 0)) - cfunc) + cfunc) (:temporary (:sc descriptor-reg :offset nl0-offset :from (:argument 0)) a0) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) (:temporary (:scs (non-descriptor-reg)) temp) @@ -25,10 +25,10 @@ (let ((cur-nfp (current-nfp-tn vop))) (move object a0) (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) + (store-stack-tn nfp-save cur-nfp)) (inst li (make-fixup "debug_print" :foreign) cfunc) (inst li (make-fixup "call_into_c" :foreign) temp) (inst jsr lip-tn temp (make-fixup "call_into_c" :foreign)) (when cur-nfp - (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)) + (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)) (move cfunc result)))) diff --git a/src/compiler/alpha/static-fn.lisp b/src/compiler/alpha/static-fn.lisp index faf2758..e69de29 100644 --- a/src/compiler/alpha/static-fn.lisp +++ b/src/compiler/alpha/static-fn.lisp @@ -1,131 +0,0 @@ -;;;; VOPs and macro magic for calling static functions - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB!VM") - -(define-vop (static-fun-template) - (:save-p t) - (:policy :safe) - (:variant-vars symbol) - (:vop-var vop) - (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:scs (descriptor-reg)) move-temp) - (:temporary (:sc descriptor-reg :offset lra-offset) lra) - (:temporary (:sc interior-reg :offset lip-offset) entry-point) - (:temporary (:sc any-reg :offset nargs-offset) nargs) - (:temporary (:sc any-reg :offset ocfp-offset) ocfp) - (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - -(defun static-fun-template-name (num-args num-results) - (intern (format nil "~:@(~R-arg-~R-result-static-fun~)" - num-args num-results))) - -(defun moves (src dst) - (collect ((moves)) - (do ((dst dst (cdr dst)) - (src src (cdr src))) - ((or (null dst) (null src))) - (moves `(move ,(car src) ,(car dst)))) - (moves))) - -(defun static-fun-template-vop (num-args num-results) - (unless (and (<= num-args register-arg-count) - (<= num-results register-arg-count)) - (error "either too many args (~W) or too many results (~W); max = ~W" - num-args num-results register-arg-count)) - (let ((num-temps (max num-args num-results))) - (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results)) - (dotimes (i num-results) - (let ((result-name (intern (format nil "RESULT-~D" i)))) - (result-names result-name) - (results `(,result-name :scs (any-reg descriptor-reg))))) - (dotimes (i num-temps) - (let ((temp-name (intern (format nil "TEMP-~D" i)))) - (temp-names temp-name) - (temps `(:temporary (:sc descriptor-reg - :offset ,(nth i *register-arg-offsets*) - ,@(when (< i num-args) - `(:from (:argument ,i))) - ,@(when (< i num-results) - `(:to (:result ,i) - :target ,(nth i (result-names))))) - ,temp-name)))) - (dotimes (i num-args) - (let ((arg-name (intern (format nil "ARG-~D" i)))) - (arg-names arg-name) - (args `(,arg-name - :scs (any-reg descriptor-reg null zero) - :target ,(nth i (temp-names)))))) - `(define-vop (,(static-fun-template-name num-args num-results) - static-fun-template) - (:args ,@(args)) - ,@(temps) - (:results ,@(results)) - (:generator ,(+ 50 num-args num-results) - (let ((lra-label (gen-label)) - (cur-nfp (current-nfp-tn vop))) - ,@(moves (arg-names) (temp-names)) - (inst li (fixnumize ,num-args) nargs) - (inst ldl entry-point (static-fun-offset symbol) null-tn) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (inst move cfp-tn ocfp) - (inst compute-lra-from-code lra code-tn lra-label temp) - (note-this-location vop :call-site) - (inst move csp-tn cfp-tn) - (inst jsr zero-tn entry-point) - (emit-return-pc lra-label) - ,(collect ((bindings) (links)) - (do ((temp (temp-names) (cdr temp)) - (name 'values (gensym)) - (prev nil name) - (i 0 (1+ i))) - ((= i num-results)) - (bindings `(,name - (make-tn-ref ,(car temp) nil))) - (when prev - (links `(setf (tn-ref-across ,prev) ,name)))) - `(let ,(bindings) - ,@(links) - (default-unknown-values vop - ,(if (zerop num-results) nil 'values) - ,num-results move-temp temp lra-label))) - (when cur-nfp - (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)) - ,@(moves (temp-names) (result-names)))))))) - -) ; EVAL-WHEN - -(expand - (collect ((templates (list 'progn))) - (dotimes (i register-arg-count) - (templates (static-fun-template-vop i 1))) - (templates))) - -(defmacro define-static-fun (name args &key (results '(x)) translate - policy cost arg-types result-types) - `(define-vop (,name - ,(static-fun-template-name (length args) - (length results))) - (:variant ',name) - (:note ,(format nil "static-fun ~@(~S~)" name)) - ,@(when translate - `((:translate ,translate))) - ,@(when policy - `((:policy ,policy))) - ,@(when cost - `((:generator-cost ,cost))) - ,@(when arg-types - `((:arg-types ,@arg-types))) - ,@(when result-types - `((:result-types ,@result-types))))) diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp index c800e80..8984f7d 100644 --- a/tests/alien.impure.lisp +++ b/tests/alien.impure.lisp @@ -10,7 +10,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -49,10 +49,10 @@ ;;; This used to break due to too eager auxiliary type twiddling in ;;; parse-alien-record-type. (defparameter *maybe* nil) -(defun with-alien-test-for-struct-plus-funcall () +(defun with-alien-test-for-struct-plus-funcall () (with-alien ((x (struct bar (x unsigned) (y unsigned))) - ;; bogus definition, but we just need the symbol - (f (function int (* (struct bar))) :extern "printf")) + ;; bogus definition, but we just need the symbol + (f (function int (* (struct bar))) :extern "printf")) (when *maybe* (alien-funcall f (addr x))))) @@ -62,16 +62,16 @@ (let ((s1 (make-alien struct.1)) (s2 (make-alien struct.2))) (setf (slot s1 'x) s2 - (slot s2 'x) s1 - (slot (slot s1 'x) 'y) 1 - (slot (slot s2 'x) 'y) 2) + (slot s2 'x) s1 + (slot (slot s1 'x) 'y) 1 + (slot (slot s2 'x) 'y) 2) (assert (= 1 (slot (slot s1 'x) 'y))) (assert (= 2 (slot (slot s2 'x) 'y)))) ;;; "Alien bug" on sbcl-devel 2004-10-11 by Thomas F. Burdick caused ;;; by recursive struct definition. (let ((fname "alien-bug-2004-10-11.tmp.lisp")) - (unwind-protect + (unwind-protect (progn (with-open-file (f fname :direction :output) (mapc (lambda (form) (print form f)) @@ -80,7 +80,7 @@ (in-package :alien-bug) (define-alien-type objc-class (struct objc-class - (protocols + (protocols (* (struct protocol-list (list (array (* (struct objc-class)))))))))))) (load fname) diff --git a/tests/arith.impure.lisp b/tests/arith.impure.lisp index fb6b7d9..dc11f8b 100644 --- a/tests/arith.impure.lisp +++ b/tests/arith.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -70,8 +70,8 @@ (defun are-we-getting-ash-right (x y) (declare (optimize speed) - (type (unsigned-byte 32) x) - (type (integer -40 0) y)) + (type (unsigned-byte 32) x) + (type (integer -40 0) y)) (ash x y)) (defun what-about-with-constants (x) (declare (optimize speed) (type (unsigned-byte 32) x)) @@ -79,14 +79,14 @@ (dotimes (i 41) (assert (= (are-we-getting-ash-right (1- (ash 1 32)) (- i)) - (if (< i 32) - (1- (ash 1 (- 32 i))) - 0)))) + (if (< i 32) + (1- (ash 1 (- 32 i))) + 0)))) (assert (= (what-about-with-constants (1- (ash 1 32))) 0)) (defun one-more-test-case-to-catch-sparc (x y) (declare (optimize speed (safety 0)) - (type (unsigned-byte 32) x) (type (integer -40 2) y)) + (type (unsigned-byte 32) x) (type (integer -40 2) y)) (the (unsigned-byte 32) (ash x y))) (assert (= (one-more-test-case-to-catch-sparc (1- (ash 1 32)) -40) 0)) @@ -94,54 +94,54 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *n-fixnum-bits* (- sb-vm::n-word-bits sb-vm::n-fixnum-tag-bits)) (defvar *shifts* (let ((list (list 0 - 1 - (1- sb-vm::n-word-bits) - sb-vm::n-word-bits - (1+ sb-vm::n-word-bits)))) - (append list (mapcar #'- list))))) + 1 + (1- sb-vm::n-word-bits) + sb-vm::n-word-bits + (1+ sb-vm::n-word-bits)))) + (append list (mapcar #'- list))))) (macrolet ((nc-list () - `(list ,@(loop for i from 0 below (length *shifts*) - collect `(frob (nth ,i *shifts*))))) - (c-list () - `(list ,@(loop for i from 0 below (length *shifts*) - collect `(frob ,(nth i *shifts*)))))) + `(list ,@(loop for i from 0 below (length *shifts*) + collect `(frob (nth ,i *shifts*))))) + (c-list () + `(list ,@(loop for i from 0 below (length *shifts*) + collect `(frob ,(nth i *shifts*)))))) (defun nc-ash (x) (macrolet ((frob (y) - `(list x ,y (ash x ,y)))) + `(list x ,y (ash x ,y)))) (nc-list))) (defun c-ash (x) (macrolet ((frob (y) - `(list x ,y (ash x ,y)))) + `(list x ,y (ash x ,y)))) (c-list))) (defun nc-modular-ash-ub (x) (macrolet ((frob (y) - `(list x ,y (logand most-positive-fixnum (ash x ,y))))) + `(list x ,y (logand most-positive-fixnum (ash x ,y))))) (nc-list))) (defun c-modular-ash-ub (x) (declare (type (and fixnum unsigned-byte) x) - (optimize speed)) + (optimize speed)) (macrolet ((frob (y) - `(list x ,y (logand most-positive-fixnum (ash x ,y))))) + `(list x ,y (logand most-positive-fixnum (ash x ,y))))) (c-list)))) (let* ((values (list 0 1 most-positive-fixnum)) (neg-values (cons most-negative-fixnum - (mapcar #'- values)))) + (mapcar #'- values)))) (labels ((test (value fun1 fun2) - (let ((res1 (funcall fun1 value)) - (res2 (funcall fun2 value))) - (mapcar (lambda (a b) - (unless (equalp a b) - (error "ash failure for ~A vs ~A: ~A not EQUALP ~A" - fun1 fun2 - a b))) - res1 res2)))) + (let ((res1 (funcall fun1 value)) + (res2 (funcall fun2 value))) + (mapcar (lambda (a b) + (unless (equalp a b) + (error "ash failure for ~A vs ~A: ~A not EQUALP ~A" + fun1 fun2 + a b))) + res1 res2)))) (loop for x in values do - (test x 'nc-ash 'c-ash) - (test x 'nc-modular-ash-ub 'c-modular-ash-ub)) + (test x 'nc-ash 'c-ash) + (test x 'nc-modular-ash-ub 'c-modular-ash-ub)) (loop for x in neg-values do - (test x 'nc-ash 'c-ash)))) + (test x 'nc-ash 'c-ash)))) (defun 64-bit-logcount (x) diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp index 3cc17fa..630c0a8 100644 --- a/tests/arith.pure.lisp +++ b/tests/arith.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -18,13 +18,13 @@ ;;; unlikely that anything with such fundamental arithmetic errors as ;;; these are going to get this far, it's probably worth checking. (macrolet ((test (op res1 res2) - `(progn - (assert (= (,op 4 2) ,res1)) - (assert (= (,op 2 4) ,res2)) - (assert (= (funcall (compile nil (lambda (x y) (,op x y))) 4 2) - ,res1)) - (assert (= (funcall (compile nil (lambda (x y) (,op x y))) 2 4) - ,res2))))) + `(progn + (assert (= (,op 4 2) ,res1)) + (assert (= (,op 2 4) ,res2)) + (assert (= (funcall (compile nil (lambda (x y) (,op x y))) 4 2) + ,res1)) + (assert (= (funcall (compile nil (lambda (x y) (,op x y))) 2 4) + ,res2))))) (test + 6 6) (test - 2 -2) (test * 8 8) @@ -108,21 +108,21 @@ ;;; checkins later, we'll have doubled the coverage. (dotimes (i 100) (let* ((x (random most-positive-fixnum)) - (x2 (* x 2)) - (x3 (* x 3))) + (x2 (* x 2)) + (x3 (* x 3))) (let ((fn (handler-bind ((sb-ext:compiler-note (lambda (c) (when (<= x3 most-positive-fixnum) (error c))))) - (compile nil - `(lambda (y) - (declare (optimize speed) (type (integer 0 3) y)) - (* y ,x)))))) + (compile nil + `(lambda (y) + (declare (optimize speed) (type (integer 0 3) y)) + (* y ,x)))))) (unless (and (= (funcall fn 0) 0) - (= (funcall fn 1) x) - (= (funcall fn 2) x2) - (= (funcall fn 3) x3)) - (error "bad results for ~D" x))))) + (= (funcall fn 1) x) + (= (funcall fn 2) x2) + (= (funcall fn 3) x3)) + (error "bad results for ~D" x))))) ;;; Bugs reported by Paul Dietz: @@ -141,21 +141,21 @@ ;;; x86 LEA bug: (assert (= (funcall - (compile nil '(lambda (x) (declare (bit x)) (+ x #xf0000000))) - 1) - #xf0000001)) + (compile nil '(lambda (x) (declare (bit x)) (+ x #xf0000000))) + 1) + #xf0000001)) ;;; LOGBITP on bignums: (dolist (x '(((1+ most-positive-fixnum) 1 nil) - ((1+ most-positive-fixnum) -1 t) - ((1+ most-positive-fixnum) (1+ most-positive-fixnum) nil) - ((1+ most-positive-fixnum) (1- most-negative-fixnum) t) - (1 (ash most-negative-fixnum 1) nil) - (#.(- sb-vm:n-word-bits sb-vm:n-lowtag-bits) most-negative-fixnum t) - (#.(1+ (- sb-vm:n-word-bits sb-vm:n-lowtag-bits)) (ash most-negative-fixnum 1) t) - (#.(+ 2 (- sb-vm:n-word-bits sb-vm:n-lowtag-bits)) (ash most-negative-fixnum 1) t) - (#.(+ sb-vm:n-word-bits 32) (ash most-negative-fixnum #.(+ 32 sb-vm:n-lowtag-bits 1)) nil) - (#.(+ sb-vm:n-word-bits 33) (ash most-negative-fixnum #.(+ 32 sb-vm:n-lowtag-bits 1)) t))) + ((1+ most-positive-fixnum) -1 t) + ((1+ most-positive-fixnum) (1+ most-positive-fixnum) nil) + ((1+ most-positive-fixnum) (1- most-negative-fixnum) t) + (1 (ash most-negative-fixnum 1) nil) + (#.(- sb-vm:n-word-bits sb-vm:n-lowtag-bits) most-negative-fixnum t) + (#.(1+ (- sb-vm:n-word-bits sb-vm:n-lowtag-bits)) (ash most-negative-fixnum 1) t) + (#.(+ 2 (- sb-vm:n-word-bits sb-vm:n-lowtag-bits)) (ash most-negative-fixnum 1) t) + (#.(+ sb-vm:n-word-bits 32) (ash most-negative-fixnum #.(+ 32 sb-vm:n-lowtag-bits 1)) nil) + (#.(+ sb-vm:n-word-bits 33) (ash most-negative-fixnum #.(+ 32 sb-vm:n-lowtag-bits 1)) t))) (destructuring-bind (index int result) x (assert (eq (eval `(logbitp ,index ,int)) result)))) @@ -169,8 +169,8 @@ ;;; type inference leading to an internal compiler error: (let ((f (compile nil '(lambda (x) - (declare (type fixnum x)) - (ldb (byte 0 0) x))))) + (declare (type fixnum x)) + (ldb (byte 0 0) x))))) (assert (= (funcall f 1) 0)) (assert (= (funcall f most-positive-fixnum) 0)) (assert (= (funcall f -1) 0))) @@ -214,10 +214,10 @@ ;;; Whoops. Too much optimization in division operators for 0 ;;; divisor. (macrolet ((frob (name) - `(let ((fn (compile nil '(lambda (x) - (declare (optimize speed) (fixnum x)) - (,name x 0))))) - (assert (raises-error? (funcall fn 1) division-by-zero))))) + `(let ((fn (compile nil '(lambda (x) + (declare (optimize speed) (fixnum x)) + (,name x 0))))) + (assert (raises-error? (funcall fn 1) division-by-zero))))) (frob mod) (frob truncate) (frob rem) @@ -229,31 +229,31 @@ ;; comparisons without rationalizing the floats still gives the right anwers ;; in the edge cases (had a fencepost error). (macrolet ((test (range type sign) - `(let (ints - floats - (start (- ,(find-symbol (format nil - "MOST-~A-EXACTLY-~A-FIXNUM" - sign type) - :sb-kernel) - ,range))) - (dotimes (i (1+ (* ,range 2))) - (let* ((x (+ start i)) - (y (coerce x ',type))) - (push x ints) - (push y floats))) - (dolist (i ints) - (dolist (f floats) - (dolist (op '(< <= = >= >)) - (unless (eq (funcall op i f) - (funcall op i (rationalize f))) - (error "(not (eq (~a ~a ~f) (~a ~a ~a)))~%" - op i f - op i (rationalize f))) - (unless (eq (funcall op f i) - (funcall op (rationalize f) i)) - (error "(not (eq (~a ~f ~a) (~a ~a ~a)))~%" - op f i - op (rationalize f) i)))))))) + `(let (ints + floats + (start (- ,(find-symbol (format nil + "MOST-~A-EXACTLY-~A-FIXNUM" + sign type) + :sb-kernel) + ,range))) + (dotimes (i (1+ (* ,range 2))) + (let* ((x (+ start i)) + (y (coerce x ',type))) + (push x ints) + (push y floats))) + (dolist (i ints) + (dolist (f floats) + (dolist (op '(< <= = >= >)) + (unless (eq (funcall op i f) + (funcall op i (rationalize f))) + (error "(not (eq (~a ~a ~f) (~a ~a ~a)))~%" + op i f + op i (rationalize f))) + (unless (eq (funcall op f i) + (funcall op (rationalize f) i)) + (error "(not (eq (~a ~f ~a) (~a ~a ~a)))~%" + op f i + op (rationalize f) i)))))))) (test 32 double-float negative) (test 32 double-float positive) (test 32 single-float negative) @@ -261,6 +261,6 @@ ;; x86-64 sign-extension bug found using pfdietz's random tester. (assert (= 286142502 - (funcall (lambda () - (declare (notinline logxor)) - (min (logxor 0 0 0 286142502)))))) + (funcall (lambda () + (declare (notinline logxor)) + (min (logxor 0 0 0 286142502)))))) diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp index 5068878..a44193b 100644 --- a/tests/array.pure.lisp +++ b/tests/array.pure.lisp @@ -4,7 +4,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -14,78 +14,78 @@ ;;; Array initialization has complicated defaulting for :ELEMENT-TYPE, ;;; and both compile-time and run-time logic takes a whack at it. (let ((testcases '(;; Bug 126, confusion between high-level default string - ;; initial element #\SPACE and low-level default array - ;; element #\NULL, is gone. - (#\null (make-array 11 :element-type 'character) simple-string) - (#\space (make-string 11 :initial-element #\space) string) - (#\* (make-string 11 :initial-element #\*)) - (#\null (make-string 11)) - (#\null (make-string 11 :initial-element #\null)) - (#\x (make-string 11 :initial-element #\x)) - ;; And the other tweaks made when fixing bug 126 didn't - ;; mess things up too badly either. - (0 (make-array 11) simple-vector) - (nil (make-array 11 :initial-element nil)) - (12 (make-array 11 :initial-element 12)) - (0 (make-array 11 :element-type '(unsigned-byte 4)) (simple-array (unsigned-byte 4) (*))) - (12 (make-array 11 - :element-type '(unsigned-byte 4) - :initial-element 12))))) + ;; initial element #\SPACE and low-level default array + ;; element #\NULL, is gone. + (#\null (make-array 11 :element-type 'character) simple-string) + (#\space (make-string 11 :initial-element #\space) string) + (#\* (make-string 11 :initial-element #\*)) + (#\null (make-string 11)) + (#\null (make-string 11 :initial-element #\null)) + (#\x (make-string 11 :initial-element #\x)) + ;; And the other tweaks made when fixing bug 126 didn't + ;; mess things up too badly either. + (0 (make-array 11) simple-vector) + (nil (make-array 11 :initial-element nil)) + (12 (make-array 11 :initial-element 12)) + (0 (make-array 11 :element-type '(unsigned-byte 4)) (simple-array (unsigned-byte 4) (*))) + (12 (make-array 11 + :element-type '(unsigned-byte 4) + :initial-element 12))))) (dolist (testcase testcases) (destructuring-bind (expected-result form &optional type) testcase (unless (eql expected-result (aref (eval form) 3)) (error "expected ~S in EVAL ~S" expected-result form)) (unless (eql expected-result - (aref (funcall (compile nil `(lambda () ,form))) 3)) + (aref (funcall (compile nil `(lambda () ,form))) 3)) (error "expected ~S in FUNCALL COMPILE ~S" expected-result form)) ;; also do some testing of compilation and verification that ;; errors are thrown appropriately. (unless (eql expected-result - (funcall (compile nil `(lambda () (aref ,form 3))))) - (error "expected ~S in COMPILED-AREF ~S" expected-result form)) + (funcall (compile nil `(lambda () (aref ,form 3))))) + (error "expected ~S in COMPILED-AREF ~S" expected-result form)) (when type - (unless (eql expected-result - (funcall (compile nil `(lambda () (let ((x ,form)) - (declare (type ,type x)) - (aref x 3)))))) - (error "expected ~S in COMPILED-DECLARED-AREF ~S" expected-result form))) + (unless (eql expected-result + (funcall (compile nil `(lambda () (let ((x ,form)) + (declare (type ,type x)) + (aref x 3)))))) + (error "expected ~S in COMPILED-DECLARED-AREF ~S" expected-result form))) (when (ignore-errors (aref (eval form) 12)) - (error "error not thrown in EVAL ~S" form)) + (error "error not thrown in EVAL ~S" form)) (when (ignore-errors (aref (funcall (compile nil `(lambda () ,form))) 12)) - (error "error not thrown in FUNCALL COMPILE ~S")) + (error "error not thrown in FUNCALL COMPILE ~S")) (when (ignore-errors (funcall (compile nil `(lambda () (aref ,form 12))))) - (error "error not thrown in COMPILED-AREF ~S" form)) + (error "error not thrown in COMPILED-AREF ~S" form)) (when type - (when (ignore-errors (funcall - (compile nil `(lambda () (let ((x ,form)) - (declare (type ,type x)) - (aref x 12)))))) - (error "error not thrown in COMPILED-DECLARED-AREF ~S" form)))))) + (when (ignore-errors (funcall + (compile nil `(lambda () (let ((x ,form)) + (declare (type ,type x)) + (aref x 12)))))) + (error "error not thrown in COMPILED-DECLARED-AREF ~S" form)))))) ;;; On the SPARC, until sbcl-0.7.7.20, there was a bug in array ;;; references for small vector elements (spotted by Raymond Toy); the ;;; bug persisted on the PPC until sbcl-0.7.8.20. (let (vector) (loop for i below 64 - for list = (make-list 64 :initial-element 1) - do (setf (nth i list) 0) - do (setf vector (make-array 64 :element-type 'bit - :initial-contents list)) - do (assert (= (funcall - (compile nil - `(lambda (rmdr) - (declare (type (simple-array bit (*)) rmdr) - (optimize (speed 3) (safety 0))) - (aref rmdr ,i))) - vector) - 0)))) + for list = (make-list 64 :initial-element 1) + do (setf (nth i list) 0) + do (setf vector (make-array 64 :element-type 'bit + :initial-contents list)) + do (assert (= (funcall + (compile nil + `(lambda (rmdr) + (declare (type (simple-array bit (*)) rmdr) + (optimize (speed 3) (safety 0))) + (aref rmdr ,i))) + vector) + 0)))) ;;; Following refactoring of sequence functions to detect bad type ;;; specifiers, REVERSE was left broken on vectors with fill pointers. (let ((a (make-array 10 - :fill-pointer 5 - :element-type 'character - :initial-contents "abcdefghij"))) + :fill-pointer 5 + :element-type 'character + :initial-contents "abcdefghij"))) (assert (string= (reverse a) "edcba"))) ;;; ARRAY-IN-BOUNDS-P should work when given non-INDEXes as its @@ -139,7 +139,7 @@ ;; an array with more than 2^24 elements, since that was a symptom ;; from the CLISP and OpenMCL hosts. (let ((big-array (opaque-identity - (make-array (expt 2 26) :element-type 'bit)))) + (make-array (expt 2 26) :element-type 'bit)))) (assert (= (length big-array) (expt 2 26))))) ;;; Bug reported by Kalle Olavi Niemitalo for CMUCL through Debian BTS @@ -147,13 +147,13 @@ (assert (eql (aref array) nil))) (let ((f (compile nil '(lambda () - (let ((a (make-array '(4) - :element-type 'base-char - :initial-element #\z))) - (setf (aref a 0) #\a) - (setf (aref a 1) #\b) - (setf (aref a 2) #\c) - a))))) + (let ((a (make-array '(4) + :element-type 'base-char + :initial-element #\z))) + (setf (aref a 0) #\a) + (setf (aref a 1) #\b) + (setf (aref a 2) #\c) + a))))) (assert (= (length (funcall f)) 4))) (let ((x (make-array nil :initial-element 'foo))) @@ -166,12 +166,12 @@ (multiple-value-bind (val err) (ignore-errors (locally (declare (optimize (safety 3) (speed 0))) - (let* ((x (make-array 10 :fill-pointer 4 :element-type 'character - :initial-element #\space :adjustable t)) - (y (make-array 10 :fill-pointer 4 :element-type 'character - :displaced-to x))) - (adjust-array x '(5)) - (char y 5)))) + (let* ((x (make-array 10 :fill-pointer 4 :element-type 'character + :initial-element #\space :adjustable t)) + (y (make-array 10 :fill-pointer 4 :element-type 'character + :displaced-to x))) + (adjust-array x '(5)) + (char y 5)))) (assert (and (not val) (typep err 'sb-kernel:displaced-to-array-too-small-error)))) ;;; MISC.527: bit-vector bitwise operations used LENGTH to get a size diff --git a/tests/assertoid.lisp b/tests/assertoid.lisp index 0e76532..6f75873 100644 --- a/tests/assertoid.lisp +++ b/tests/assertoid.lisp @@ -7,7 +7,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -31,7 +31,7 @@ ;;; expression to be tested in other than the default optimization ;;; level(s). ;;; -;;; The messiness with the various flavors of EXPECTED stuff is +;;; The messiness with the various flavors of EXPECTED stuff is ;;; to handle various issues: ;;; * Some things are expected to signal errors instead of returning ;;; ordinary values. @@ -48,68 +48,68 @@ ;;; EXPECTED-ERROR-LAMBDA to require that an error be signalled and ;;; that further it satisfies the given lambda. (defmacro assertoid (expr - &key - extra-optimizations - (expected-eql nil expected-eql-p) - (expected-equal nil expected-equal-p) - (expected-equalp nil expected-equalp-p) - (expected-lambda (cond - (expected-eql-p - (lambda (x) - (eql x (eval expected-eql)))) - (expected-equal-p - (lambda (x) - (equal x (eval expected-equal)))) - (expected-equalp-p - (lambda (x) - (equalp x (eval expected-equalp)))) - (t - (lambda (x) - x))) - expected-lambda-p) - (expected-error-type nil expected-error-type-p) - (expected-error-lambda (if expected-error-type - (lambda (condition) - (typep condition - expected-error-type)) - nil) - expected-error-lambda-p)) + &key + extra-optimizations + (expected-eql nil expected-eql-p) + (expected-equal nil expected-equal-p) + (expected-equalp nil expected-equalp-p) + (expected-lambda (cond + (expected-eql-p + (lambda (x) + (eql x (eval expected-eql)))) + (expected-equal-p + (lambda (x) + (equal x (eval expected-equal)))) + (expected-equalp-p + (lambda (x) + (equalp x (eval expected-equalp)))) + (t + (lambda (x) + x))) + expected-lambda-p) + (expected-error-type nil expected-error-type-p) + (expected-error-lambda (if expected-error-type + (lambda (condition) + (typep condition + expected-error-type)) + nil) + expected-error-lambda-p)) (when (> (count-if #'identity - (vector expected-eql-p - expected-equal-p - expected-equalp-p - expected-lambda-p - expected-error-type-p - expected-error-lambda-p)) - 1) + (vector expected-eql-p + expected-equal-p + expected-equalp-p + expected-lambda-p + expected-error-type-p + expected-error-lambda-p)) + 1) (error "multiple EXPECTED-FOO arguments")) (when expected-error-lambda (error "stub: expected-error functionality not supported yet")) (let ((eval-expected-lambda (eval expected-lambda))) (flet ((frob (evaloid) - (let ((result (funcall evaloid expr))) - (unless (funcall eval-expected-lambda result) - (error "failed assertoid ~S" expr)))) - (compile-as-evaloid (optimizations) + (let ((result (funcall evaloid expr))) + (unless (funcall eval-expected-lambda result) + (error "failed assertoid ~S" expr)))) + (compile-as-evaloid (optimizations) (lambda (expr) - (funcall (compile nil - `(lambda () - (declare (optimize ,@optimizations)) - ,expr)))))) + (funcall (compile nil + `(lambda () + (declare (optimize ,@optimizations)) + ,expr)))))) (frob #'eval) (frob (compile-as-evaloid ())) (dolist (i extra-optimizations) - (frob (compile-as-evaloid i)))))) + (frob (compile-as-evaloid i)))))) ;;; examples (assertoid (= 2 (length (list 1 2)))) (assertoid (= 2 (length (list 1 2))) - :extra-optimizations (((speed 2) (space 3)) - ((speed 1) (space 3)))) + :extra-optimizations (((speed 2) (space 3)) + ((speed 1) (space 3)))) (assertoid (cons 1 2) - :expected-lambda (lambda (x) (equal x '(1 . 2)))) + :expected-lambda (lambda (x) (equal x '(1 . 2)))) (assertoid (cons (list 1 2) (list 1 2)) - :expected-equal '((1 2) 1 2)) + :expected-equal '((1 2) 1 2)) ;;; not implemented yet: #+nil (assertoid (length (eval (find-package :cl))) - :expected-error-type 'type-error) + :expected-error-type 'type-error) diff --git a/tests/backq.impure.lisp b/tests/backq.impure.lisp index 65583f5..cd70cea 100644 --- a/tests/backq.impure.lisp +++ b/tests/backq.impure.lisp @@ -6,13 +6,13 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. (in-package "CL-USER") - + (defparameter *qq* '(*rr* *ss*)) (defparameter *rr* '(3 5)) (defparameter *ss* '(4 6)) @@ -33,7 +33,7 @@ value)) (format t "Ok. Look at PPRINTed version: ") (pprint (read-from-string expression))) - + (defparameter *backquote-tests* '(("``(,,*QQ*)" . (24)) ("``(,@,*QQ*)" . 24) @@ -52,12 +52,12 @@ ("``(,@,@*QQ*)" . (3 5 4 6)))) (mapc (lambda (test) - (test-double-backquote (car test) (cdr test))) + (test-double-backquote (car test) (cdr test))) *backquote-tests*) (let ((string "`(foobar a b ,c ,'(e f g) d ,@'(e f g) (h i j) ,@foo)")) (assert (equal (print (read-from-string string)) (read-from-string string)))) - + (let ((a '`(1 ,@a ,@b ,.c ,.d))) (let ((*print-circle* t)) (assert (equal (read-from-string (write-to-string a)) a)))) diff --git a/tests/bit-vector.impure-cload.lisp b/tests/bit-vector.impure-cload.lisp index 87a9556..ac2b7b3 100644 --- a/tests/bit-vector.impure-cload.lisp +++ b/tests/bit-vector.impure-cload.lisp @@ -4,7 +4,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -19,13 +19,13 @@ (defun test-small-bit-vectors () ;; deal with the potential length 0 special case (let ((a (make-array 0 :element-type 'bit)) - (b (make-array 0 :element-type 'bit))) + (b (make-array 0 :element-type 'bit))) (assert (equal (bit-not a) #*)) (assert (equal (bit-xor a b a) #*)) (assert (equal (bit-and a a b) #*))) ;; also test some return values for sanity (let ((a (make-array 33 :element-type 'bit :initial-element 0)) - (b (make-array 33 :element-type 'bit :initial-element 0))) + (b (make-array 33 :element-type 'bit :initial-element 0))) (assert (equal (bit-not a a) #*111111111111111111111111111111111)) (setf (aref a 0) 0) ; a = #*011..1 (setf (aref b 1) 1) ; b = #*010..0 @@ -35,8 +35,8 @@ (locally (declare (optimize (speed 3) (space 1))) (let ((bv1 (make-array 5 :element-type 'bit)) - (bv2 (make-array 0 :element-type 'bit)) - (bv3 (make-array 68 :element-type 'bit))) + (bv2 (make-array 0 :element-type 'bit)) + (bv3 (make-array 68 :element-type 'bit))) (declare (type simple-bit-vector bv1 bv2 bv3)) (setf (sbit bv3 42) 1) ;; bitvector smaller than the word size @@ -55,14 +55,14 @@ (defun test-big-bit-vectors () ;; now test the biggy, mostly that it works... - (let ((a (progn - (inform :make-array-1) - (make-array (1- array-dimension-limit) - :element-type 'bit :initial-element 0))) - (b (progn - (inform :make-array-2) - (make-array (1- array-dimension-limit) - :element-type 'bit :initial-element 0)))) + (let ((a (progn + (inform :make-array-1) + (make-array (1- array-dimension-limit) + :element-type 'bit :initial-element 0))) + (b (progn + (inform :make-array-2) + (make-array (1- array-dimension-limit) + :element-type 'bit :initial-element 0)))) (inform :bit-not) (bit-not a a) (inform :aref-1) @@ -80,7 +80,7 @@ (test-small-bit-vectors) -#-x86-64 +#-x86-64 ;; except on machines where addressable space is likely to be ;; much bigger than physical memory (test-big-bit-vectors) diff --git a/tests/bivalent-stream.impure.lisp b/tests/bivalent-stream.impure.lisp index faf21e3..56b5893 100644 --- a/tests/bivalent-stream.impure.lisp +++ b/tests/bivalent-stream.impure.lisp @@ -10,23 +10,23 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. ;;; Test character decode restarts. (with-open-file (s "bivalent-stream-test.txt" :direction :output - :if-exists :supersede - :element-type :default :external-format :utf-8) + :if-exists :supersede + :element-type :default :external-format :utf-8) (write-byte 65 s) (write-char #\B s) (write-byte #xe0 s) (write-char #\C s)) (with-open-file (s "bivalent-stream-test.txt" :direction :input - :element-type :default - :external-format :utf-8) + :element-type :default + :external-format :utf-8) (assert (eql (read-char s nil s) #\A)) (assert (eql (read-byte s nil s) 66)) (assert (eql (read-byte s nil s) #xe0)) diff --git a/tests/bug-doug-mcnaught-20030914.lisp b/tests/bug-doug-mcnaught-20030914.lisp index 6c4a8e2..1b14dd6 100644 --- a/tests/bug-doug-mcnaught-20030914.lisp +++ b/tests/bug-doug-mcnaught-20030914.lisp @@ -4,7 +4,7 @@ (set-macro-character #\] (get-macro-character #\))) (set-dispatch-macro-character #\# #\[ - #'(lambda (s c n) (declare (ignore c)) + #'(lambda (s c n) (declare (ignore c)) (let* ((type (if n `(unsigned-byte ,n) '(unsigned-byte 8))) (list (read-delimited-list #\] s nil)) diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp index 82b033d..fe25040 100644 --- a/tests/callback.impure.lisp +++ b/tests/callback.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -15,26 +15,26 @@ ;;; callbacks only on a few platforms #-(or darwin x86) -(quit :unix-status 104) +(quit :unix-status 104) ;;; simple callback for a function (defun thunk () (write-string "hi")) -(defvar *thunk* +(defvar *thunk* (sb-alien::alien-callback (function c-string) #'thunk)) (assert (equal (with-output-to-string (*standard-output*) - (alien-funcall *thunk*)) - "hi")) + (alien-funcall *thunk*)) + "hi")) ;;; simple callback for a symbol (defun add-two-ints (arg1 arg2) (+ arg1 arg2)) -(defvar *add-two-ints* +(defvar *add-two-ints* (sb-alien::alien-callback (function int int int) 'add-two-ints)) (assert (= (alien-funcall *add-two-ints* 555 444444) 444999)) @@ -49,20 +49,20 @@ (sb-alien::define-alien-callback double*-cmp int ((arg1 (* double)) (arg2 (* double))) (let ((a1 (deref arg1)) - (a2 (deref arg2))) + (a2 (deref arg2))) (cond ((= a1 a2) 0) - ((< a1 a2) -1) - (t 1)))) + ((< a1 a2) -1) + (t 1)))) (let* ((vector (coerce '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0 2.5d0 0.0d0 0.1d0 0.2d0 0.3d0) - '(vector double-float))) + '(vector double-float))) (sorted (sort (copy-seq vector) #'<))) (gc :full t) (sb-sys:with-pinned-objects (vector) (qsort (sb-sys:vector-sap vector) - (length vector) - (alien-size double :bytes) - double*-cmp)) + (length vector) + (alien-size double :bytes) + double*-cmp)) (assert (equalp vector sorted))) ;;; returning floats @@ -104,7 +104,7 @@ (assert p) (assert (not valid))) -(multiple-value-bind (res err) +(multiple-value-bind (res err) (ignore-errors (alien-funcall to-be-invalidated)) (assert (and (not res) (typep err 'error)))) diff --git a/tests/character.pure.lisp b/tests/character.pure.lisp index 74619b4..1a35bbb 100644 --- a/tests/character.pure.lisp +++ b/tests/character.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -18,23 +18,23 @@ ;;; (Obviously, the numeric values in this test implicitly assume ;;; we're using an ASCII-based character set.) (dolist (i '(("Newline" 10) - ;; (ANSI also imposes a constraint on the "semi-standard - ;; character" "Linefeed", but in ASCII as interpreted by - ;; Unix it's shadowed by "Newline" and so doesn't exist - ;; as a separate character.) - ("Space" 32) - ("Tab" 9) - ("Page" 12) - ("Rubout" 127) - ("Return" 13) - ("Backspace" 8))) + ;; (ANSI also imposes a constraint on the "semi-standard + ;; character" "Linefeed", but in ASCII as interpreted by + ;; Unix it's shadowed by "Newline" and so doesn't exist + ;; as a separate character.) + ("Space" 32) + ("Tab" 9) + ("Page" 12) + ("Rubout" 127) + ("Return" 13) + ("Backspace" 8))) (destructuring-bind (name code) i (let ((named-char (name-char name)) - (coded-char (code-char code))) + (coded-char (code-char code))) (assert (eql named-char coded-char)) (assert (characterp named-char)) (let ((coded-char-name (char-name coded-char))) - (assert (string= name coded-char-name)))))) + (assert (string= name coded-char-name)))))) ;;; bug 230: CHAR= didn't check types of &REST arguments (dolist (form '((code-char char-code-limit) diff --git a/tests/clocc-ansi-test-known-bugs.lisp b/tests/clocc-ansi-test-known-bugs.lisp index ad6aa37..004d102 100644 --- a/tests/clocc-ansi-test-known-bugs.lisp +++ b/tests/clocc-ansi-test-known-bugs.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -18,7 +18,7 @@ (map nil (lambda (bugid) (setf (gethash bugid *bugid->knownp*) - t)) + t)) #(;; FIXME: several metaproblems here, over and above the primary ;; problem represented by the honking big bug list.. ;; * This list was generated automatically from test output diff --git a/tests/clos-ignore.interactive.lisp b/tests/clos-ignore.interactive.lisp index 432f65d..92d96d7 100644 --- a/tests/clos-ignore.interactive.lisp +++ b/tests/clos-ignore.interactive.lisp @@ -11,7 +11,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. diff --git a/tests/clos.impure-cload.lisp b/tests/clos.impure-cload.lisp index 5b42736..9c65d58 100644 --- a/tests/clos.impure-cload.lisp +++ b/tests/clos.impure-cload.lisp @@ -7,7 +7,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -103,20 +103,20 @@ ((redefined :allocation :class))) (assert (slot-boundp (make-instance 'shared-to-local-initform-sub) 'redefined)) (assert (eq 'orig-initform - (slot-value (make-instance 'shared-to-local-initform-sub) 'redefined))) + (slot-value (make-instance 'shared-to-local-initform-sub) 'redefined))) (defgeneric no-ignored-warnings (x y)) (handler-case (eval '(defmethod no-ignored-warnings ((x t) (y t)) - (declare (ignore x y)) nil)) + (declare (ignore x y)) nil)) (style-warning (c) (error c))) (handler-case (eval '(defmethod no-ignored-warnings ((x number) (y t)) - (declare (ignore x y)) (setq *print-level* nil))) + (declare (ignore x y)) (setq *print-level* nil))) (style-warning (c) (error c))) (handler-case (eval '(defmethod no-ignored-warnings ((x fixnum) (y t)) - (declare (ignore x)) (setq y 'foo))) + (declare (ignore x)) (setq y 'foo))) (style-warning (c) (error c))) ;;; ctor optimization bugs: @@ -135,7 +135,7 @@ ((foo :initarg :valid-initarg)) (:default-initargs :valid-initarg 2)) (defmethod shared-initialize :before ((thing default-initargs-with-method) - slot-names &key valid-initarg) + slot-names &key valid-initarg) (assert (= valid-initarg 2))) (make-instance 'default-initargs-with-method) ;;; and a test with a non-constant initarg @@ -144,7 +144,7 @@ ((foo :initarg :valid-initarg)) (:default-initargs :valid-initarg (incf *d-i-w-m-2*))) (defmethod shared-initialize :before ((thing default-initargs-with-method2) - slot-names &key valid-initarg) + slot-names &key valid-initarg) (assert (= valid-initarg 1))) (make-instance 'default-initargs-with-method2) (assert (= *d-i-w-m-2* 1)) @@ -155,8 +155,8 @@ (defmethod initialize-instance :after ((x class-with-symbol-initarg) &rest initargs &key &allow-other-keys) (unless (or (null initargs) - (eql (getf initargs 'slot) - (slot-value x 'slot))) + (eql (getf initargs 'slot) + (slot-value x 'slot))) (error "bad bad bad"))) (defun make-thing (arg) (make-instance 'class-with-symbol-initarg 'slot arg)) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index dfcb369..3fd3e05 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -81,26 +81,26 @@ ;;; section 3.4.2 of the ANSI spec. Since Alexey Dejneka's patch for ;;; bug 191-b ca. sbcl-0.7.22, these limitations should be enforced. (labels ((coerce-to-boolean (x) - (if x t nil)) - (%like-or-dislike (expr expected-failure-p) + (if x t nil)) + (%like-or-dislike (expr expected-failure-p) (declare (type boolean expected-failure-p)) (format t "~&trying ~S~%" expr) (multiple-value-bind (fun warnings-p failure-p) - (compile nil - `(lambda () + (compile nil + `(lambda () ,expr)) - (declare (ignore fun)) - ;; In principle the constraint on WARNINGS-P below seems - ;; reasonable, but in practice we get warnings about - ;; undefined functions from the DEFGENERICs, apparently - ;; because the DECLAIMs which ordinarily prevent such - ;; warnings don't take effect because EVAL-WHEN - ;; (:COMPILE-TOPLEVEL) loses its magic when compiled - ;; within a LAMBDA. So maybe we can't test WARNINGS-P - ;; after all? + (declare (ignore fun)) + ;; In principle the constraint on WARNINGS-P below seems + ;; reasonable, but in practice we get warnings about + ;; undefined functions from the DEFGENERICs, apparently + ;; because the DECLAIMs which ordinarily prevent such + ;; warnings don't take effect because EVAL-WHEN + ;; (:COMPILE-TOPLEVEL) loses its magic when compiled + ;; within a LAMBDA. So maybe we can't test WARNINGS-P + ;; after all? ;;(unless expected-failure-p - ;; (assert (not warnings-p))) - (assert (eq (coerce-to-boolean failure-p) expected-failure-p)))) + ;; (assert (not warnings-p))) + (assert (eq (coerce-to-boolean failure-p) expected-failure-p)))) (like (expr) (%like-or-dislike expr nil)) (dislike (expr) @@ -110,14 +110,14 @@ (like '(defgeneric gf-for-ll-test-1 ())) (like '(defgeneric gf-for-ll-test-2 (x))) ;; forbidden default or supplied-p for &OPTIONAL or &KEY arguments - (dislike '(defgeneric gf-for-ll-test-3 (x &optional (y 0)))) - (like '(defgeneric gf-for-ll-test-4 (x &optional y))) - (dislike '(defgeneric gf-for-ll-test-5 (x y &key (z :z z-p)))) + (dislike '(defgeneric gf-for-ll-test-3 (x &optional (y 0)))) + (like '(defgeneric gf-for-ll-test-4 (x &optional y))) + (dislike '(defgeneric gf-for-ll-test-5 (x y &key (z :z z-p)))) (like '(defgeneric gf-for-ll-test-6 (x y &key z))) - (dislike '(defgeneric gf-for-ll-test-7 (x &optional (y 0) &key z))) - (like '(defgeneric gf-for-ll-test-8 (x &optional y &key z))) - (dislike '(defgeneric gf-for-ll-test-9 (x &optional y &key (z :z)))) - (like '(defgeneric gf-for-ll-test-10 (x &optional y &key z))) + (dislike '(defgeneric gf-for-ll-test-7 (x &optional (y 0) &key z))) + (like '(defgeneric gf-for-ll-test-8 (x &optional y &key z))) + (dislike '(defgeneric gf-for-ll-test-9 (x &optional y &key (z :z)))) + (like '(defgeneric gf-for-ll-test-10 (x &optional y &key z))) (dislike '(defgeneric gf-for-ll-test-11 (&optional &key (k :k k-p)))) (like '(defgeneric gf-for-ll-test-12 (&optional &key k))) ;; forbidden &AUX @@ -148,7 +148,7 @@ ;;; DEFGENERIC's blow-away-old-methods behavior is specified to have ;;; special hacks to distinguish between defined-with-DEFGENERIC-:METHOD ;;; methods and defined-with-DEFMETHOD methods, so that reLOADing -;;; DEFGENERIC-containing files does the right thing instead of +;;; DEFGENERIC-containing files does the right thing instead of ;;; randomly slicing your generic functions. (APD made this work ;;; in sbcl-0.7.0.2.) (defgeneric born-to-be-redefined (x) @@ -193,9 +193,9 @@ (c-slot :initarg :c-slot :accessor c-slot))) (let ((foo (make-instance 'class-with-slots - :a-slot 1 - :b-slot 2 - :c-slot 3))) + :a-slot 1 + :b-slot 2 + :c-slot 3))) (let ((bar (change-class foo 'class-with-slots))) (assert (= (a-slot bar) 1)) (assert (= (b-slot bar) 2)) @@ -291,49 +291,49 @@ ;;; Until sbcl-0.7.7.20, some conditions weren't being signalled, and ;;; some others were of the wrong type: (macrolet ((assert-program-error (form) - `(multiple-value-bind (value error) - (ignore-errors ,form) - (unless (and (null value) (typep error 'program-error)) + `(multiple-value-bind (value error) + (ignore-errors ,form) + (unless (and (null value) (typep error 'program-error)) (error "~S failed: ~S, ~S" ',form value error))))) (assert-program-error (defclass foo001 () (a b a))) - (assert-program-error (defclass foo002 () - (a b) - (:default-initargs x 'a x 'b))) + (assert-program-error (defclass foo002 () + (a b) + (:default-initargs x 'a x 'b))) (assert-program-error (defclass foo003 () - ((a :allocation :class :allocation :class)))) + ((a :allocation :class :allocation :class)))) (assert-program-error (defclass foo004 () - ((a :silly t)))) + ((a :silly t)))) ;; and some more, found by Wolfhard Buss and fixed for cmucl by Gerd ;; Moellmann in sbcl-0.7.8.x: (assert-program-error (progn - (defmethod odd-key-args-checking (&key (key 42)) key) - (odd-key-args-checking 3))) + (defmethod odd-key-args-checking (&key (key 42)) key) + (odd-key-args-checking 3))) (assert (= (odd-key-args-checking) 42)) (assert (eq (odd-key-args-checking :key t) t)) ;; yet some more, fixed in sbcl-0.7.9.xx (assert-program-error (defclass foo005 () - (:metaclass sb-pcl::funcallable-standard-class) - (:metaclass 1))) + (:metaclass sb-pcl::funcallable-standard-class) + (:metaclass 1))) (assert-program-error (defclass foo006 () - ((a :reader (setf a))))) + ((a :reader (setf a))))) (assert-program-error (defclass foo007 () - ((a :initarg 1)))) + ((a :initarg 1)))) (assert-program-error (defclass foo008 () - (a :initarg :a) - (:default-initargs :a 1) - (:default-initargs :a 2))) + (a :initarg :a) + (:default-initargs :a 1) + (:default-initargs :a 2))) ;; and also BUG 47d, fixed in sbcl-0.8alpha.0.26 (assert-program-error (defgeneric if (x))) ;; DEFCLASS should detect an error if slot names aren't suitable as ;; variable names: (assert-program-error (defclass foo009 () - ((:a :initarg :a)))) + ((:a :initarg :a)))) (assert-program-error (defclass foo010 () - (("a" :initarg :a)))) + (("a" :initarg :a)))) (assert-program-error (defclass foo011 () - ((#1a() :initarg :a)))) + ((#1a() :initarg :a)))) (assert-program-error (defclass foo012 () - ((t :initarg :t)))) + ((t :initarg :t)))) (assert-program-error (defclass foo013 () ("a"))) ;; specialized lambda lists have certain restrictions on ordering, ;; repeating keywords, and the like: @@ -341,7 +341,7 @@ (assert-program-error (defmethod foo015 ((foo t) &rest x y) nil)) (assert-program-error (defmethod foo016 ((foo t) &allow-other-keys) nil)) (assert-program-error (defmethod foo017 ((foo t) - &optional x &optional y) nil)) + &optional x &optional y) nil)) (assert-program-error (defmethod foo018 ((foo t) &rest x &rest y) nil)) (assert-program-error (defmethod foo019 ((foo t) &rest x &optional y) nil)) (assert-program-error (defmethod foo020 ((foo t) &key x &optional y) nil)) @@ -357,14 +357,14 @@ ;;; only certain declarations are permitted in DEFGENERIC (macrolet ((assert-program-error (form) - `(multiple-value-bind (value error) - (ignore-errors ,form) - (assert (null value)) - (assert (typep error 'program-error))))) + `(multiple-value-bind (value error) + (ignore-errors ,form) + (assert (null value)) + (assert (typep error 'program-error))))) (assert-program-error (defgeneric bogus-declaration (x) - (declare (special y)))) + (declare (special y)))) (assert-program-error (defgeneric bogus-declaration2 (x) - (declare (notinline concatenate))))) + (declare (notinline concatenate))))) ;;; CALL-NEXT-METHOD should call NO-NEXT-METHOD if there is no next ;;; method. (defmethod no-next-method-test ((x integer)) (call-next-method)) @@ -409,46 +409,46 @@ (:method-combination dmc-test-mc)) (defmethod dmc-test-mc dmc-test-mc (&key k) - k) + k) (dmc-test-mc :k 1) ;;; While I'm at it, DEFINE-METHOD-COMBINATION is defined to return ;;; the NAME argument, not some random method object. So: (assert (eq (define-method-combination dmc-test-return-foo) - 'dmc-test-return-foo)) + 'dmc-test-return-foo)) (assert (eq (define-method-combination dmc-test-return-bar :operator and) - 'dmc-test-return-bar)) + 'dmc-test-return-bar)) (assert (eq (define-method-combination dmc-test-return - (&optional (order :most-specific-first)) - ((around (:around)) - (primary (dmc-test-return) :order order :required t)) - (let ((form (if (rest primary) - `(and ,@(mapcar #'(lambda (method) - `(call-method ,method)) - primary)) - `(call-method ,(first primary))))) - (if around - `(call-method ,(first around) - (,@(rest around) - (make-method ,form))) - form))) - 'dmc-test-return)) + (&optional (order :most-specific-first)) + ((around (:around)) + (primary (dmc-test-return) :order order :required t)) + (let ((form (if (rest primary) + `(and ,@(mapcar #'(lambda (method) + `(call-method ,method)) + primary)) + `(call-method ,(first primary))))) + (if around + `(call-method ,(first around) + (,@(rest around) + (make-method ,form))) + form))) + 'dmc-test-return)) ;;; DEFINE-METHOD-COMBINATION should, according to the description in 7.7, -;;; allow you to do everything in the body forms yourself if you specify +;;; allow you to do everything in the body forms yourself if you specify ;;; exactly one method group whose qualifier-pattern is * ;;; ;;; The specific language is: -;;; "The use of method group specifiers provides a convenient syntax to select -;;; methods, to divide them among the possible roles, and to perform the -;;; necessary error checking. It is possible to perform further filtering of -;;; methods in the body forms by using normal list-processing operations and +;;; "The use of method group specifiers provides a convenient syntax to select +;;; methods, to divide them among the possible roles, and to perform the +;;; necessary error checking. It is possible to perform further filtering of +;;; methods in the body forms by using normal list-processing operations and ;;; the functions method-qualifiers and invalid-method-error. It is permissible -;;; to use setq on the variables named in the method group specifiers and to +;;; to use setq on the variables named in the method group specifiers and to ;;; bind additional variables. It is also possible to bypass the method group -;;; specifier mechanism and do everything in the body forms. This is -;;; accomplished by writing a single method group with * as its only -;;; qualifier-pattern; the variable is then bound to a list of all of the +;;; specifier mechanism and do everything in the body forms. This is +;;; accomplished by writing a single method group with * as its only +;;; qualifier-pattern; the variable is then bound to a list of all of the ;;; applicable methods, in most-specific-first order." (define-method-combination wam-test-method-combination-a () ((all-methods *)) @@ -457,23 +457,23 @@ (around nil)) ((null methods) (let ((primary (nreverse primary)) - (around (nreverse around))) - (if primary - (let ((form (if (rest primary) - `(call-method ,(first primary) ,(rest primary)) - `(call-method ,(first primary))))) - (if around - `(call-method ,(first around) (,@(rest around) - (make-method ,form))) - form)) - `(make-method (error "No primary methods"))))) + (around (nreverse around))) + (if primary + (let ((form (if (rest primary) + `(call-method ,(first primary) ,(rest primary)) + `(call-method ,(first primary))))) + (if around + `(call-method ,(first around) (,@(rest around) + (make-method ,form))) + form)) + `(make-method (error "No primary methods"))))) (let* ((method (first methods)) - (qualifier (first (method-qualifiers method)))) + (qualifier (first (method-qualifiers method)))) (cond - ((equal :around qualifier) - (push method around)) - ((null qualifier) - (push method primary)))))) + ((equal :around qualifier) + (push method around)) + ((null qualifier) + (push method primary)))))) (defgeneric wam-test-mc-a (val) (:method-combination wam-test-method-combination-a)) @@ -485,8 +485,8 @@ (+ val (if (next-method-p) (call-next-method) 0))) (assert (= (wam-test-mc-a 13) 26)) -;;; DEFINE-METHOD-COMBINATION -;;; When two methods are in the same method group and have the same +;;; DEFINE-METHOD-COMBINATION +;;; When two methods are in the same method group and have the same ;;; specializers, their sort order within the group may be ambiguous. Therefore, ;;; we should throw an error when we have two methods in the same group with ;;; the same specializers /as long as/ we have more than one method group @@ -494,14 +494,14 @@ ;;; apparent conflict with the above 'It is also possible to bypass' language. ;;; ;;; The language specifying this behavior is: -;;; "Note that two methods with identical specializers, but with different -;;; qualifiers, are not ordered by the algorithm described in Step 2 of the -;;; method selection and combination process described in Section 7.6.6 +;;; "Note that two methods with identical specializers, but with different +;;; qualifiers, are not ordered by the algorithm described in Step 2 of the +;;; method selection and combination process described in Section 7.6.6 ;;; (Method Selection and Combination). Normally the two methods play different -;;; roles in the effective method because they have different qualifiers, and -;;; no matter how they are ordered in the result of Step 2, the effective -;;; method is the same. If the two methods play the same role and their order -;;; matters, an error is signaled. This happens as part of the qualifier +;;; roles in the effective method because they have different qualifiers, and +;;; no matter how they are ordered in the result of Step 2, the effective +;;; method is the same. If the two methods play the same role and their order +;;; matters, an error is signaled. This happens as part of the qualifier ;;; pattern matching in define-method-combination." ;;; ;;; Note that the spec pretty much equates 'method group' and 'role'. @@ -511,12 +511,12 @@ ((around (:around)) (primary * :required t)) (let ((form (if (rest primary) - `(call-method ,(first primary) ,(rest primary)) - `(call-method ,(first primary))))) + `(call-method ,(first primary) ,(rest primary)) + `(call-method ,(first primary))))) (if around - `(call-method ,(first around) (,@(rest around) - (make-method ,form))) - form))) + `(call-method ,(first around) (,@(rest around) + (make-method ,form))) + form))) (defgeneric wam-test-mc-b (val) (:method-combination wam-test-method-combination-b)) @@ -526,7 +526,7 @@ (defmethod wam-test-mc-b :around ((val number)) (+ val (if (next-method-p) (call-next-method) 0))) (assert (= (wam-test-mc-b 13) 26)) -(defmethod wam-test-mc-b :somethingelse ((val number)) +(defmethod wam-test-mc-b :somethingelse ((val number)) (+ val (if (next-method-p) (call-next-method) 0))) (assert (raises-error? (wam-test-mc-b 13))) @@ -555,16 +555,16 @@ (assert (raises-error? (defmethod incompatible-ll-test-1 (x &rest y) y))) ;;; Sneakily using a bit of MOPness to check some consistency (assert (= (length - (sb-pcl:generic-function-methods #'incompatible-ll-test-1)) 1)) + (sb-pcl:generic-function-methods #'incompatible-ll-test-1)) 1)) (defmethod incompatible-ll-test-2 (x &key bar) bar) (assert (raises-error? (defmethod incompatible-ll-test-2 (x) x))) (defmethod incompatible-ll-test-2 (x &rest y) y) (assert (= (length - (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 1)) + (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 1)) (defmethod incompatible-ll-test-2 ((x integer) &key bar) bar) (assert (= (length - (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 2)) + (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 2)) ;;; Per Christophe, this is an illegal method call because of 7.6.5 (assert (raises-error? (incompatible-ll-test-2 t 1 2))) @@ -615,9 +615,9 @@ (:arguments object) `(unwind-protect (progn (lock (object-lock ,object)) - ,@(mapcar #'(lambda (method) - `(call-method ,method)) - methods)) + ,@(mapcar #'(lambda (method) + `(call-method ,method)) + methods)) (unlock (object-lock ,object)))) (defun object-lock (obj) (push "object-lock" *d-m-c-args-test*) @@ -636,11 +636,11 @@ (error "foo")) (assert (equal (d-m-c-args-test t) '("primary" "lock" "object-lock"))) (assert (equal *d-m-c-args-test* - '("unlock" "object-lock" "primary" "lock" "object-lock"))) + '("unlock" "object-lock" "primary" "lock" "object-lock"))) (setf *d-m-c-args-test* nil) (ignore-errors (d-m-c-args-test 1)) (assert (equal *d-m-c-args-test* - '("unlock" "object-lock" "lock" "object-lock"))) + '("unlock" "object-lock" "lock" "object-lock"))) ;;; The walker (on which DEFMETHOD depended) didn't know how to handle ;;; SYMBOL-MACROLET properly. In fact, as of sbcl-0.7.10.20 it still @@ -683,8 +683,8 @@ (incf *bug234*)) (assert (typep (subbug-234) 'subclass234)) (assert (= *bug234* - ;; once for MAKE-INSTANCE, once for REINITIALIZE-INSTANCE - 2)) + ;; once for MAKE-INSTANCE, once for REINITIALIZE-INSTANCE + 2)) ;;; also, some combinations of MAKE-INSTANCE and subclassing missed ;;; new methods (Gerd Moellmann sbcl-devel 2002-12-29): @@ -708,19 +708,19 @@ ;;; SLOT-MISSING should be called when there are missing slots. (defclass class-with-all-slots-missing () ()) (defmethod slot-missing (class (o class-with-all-slots-missing) - slot-name op - &optional new-value) + slot-name op + &optional new-value) op) (assert (eq (slot-value (make-instance 'class-with-all-slots-missing) 'foo) - 'slot-value)) + 'slot-value)) (assert (eq (funcall (lambda (x) (slot-value x 'bar)) - (make-instance 'class-with-all-slots-missing)) - 'slot-value)) + (make-instance 'class-with-all-slots-missing)) + 'slot-value)) (assert (eq (funcall (lambda (x) (setf (slot-value x 'baz) 'baz)) - (make-instance 'class-with-all-slots-missing)) - ;; SLOT-MISSING's value is specified to be ignored; we - ;; return NEW-VALUE. - 'baz)) + (make-instance 'class-with-all-slots-missing)) + ;; SLOT-MISSING's value is specified to be ignored; we + ;; return NEW-VALUE. + 'baz)) ;;; we should be able to specialize on anything that names a class. (defclass name-for-class () ()) @@ -729,7 +729,7 @@ (defmethod something-that-specializes ((x other-name-for-class)) 2) (assert (= (something-that-specializes (make-instance 'name-for-class)) 2)) (assert (= (something-that-specializes (make-instance 'other-name-for-class)) - 2)) + 2)) ;;; more forward referenced classes stuff (defclass frc-1 (frc-2) ()) @@ -755,7 +755,7 @@ ;;; DEFSTRUCT (and not DEFCLASS :METACLASS STRUCTURE-CLASS). (defstruct allocatable-structure a) (assert (typep (allocate-instance (find-class 'allocatable-structure)) - 'allocatable-structure)) + 'allocatable-structure)) ;;; Bug found by Paul Dietz when devising CPL tests: somewhat ;;; amazingly, calls to CPL would work a couple of times, and then @@ -774,11 +774,11 @@ (assert (equal (cpl 0) '(integer number))) (assert (equal (cpl 0) '(integer number))) (assert (equal (cpl (make-broadcast-stream)) - '(broadcast-stream stream structure-object))) + '(broadcast-stream stream structure-object))) (assert (equal (cpl (make-broadcast-stream)) - '(broadcast-stream stream structure-object))) + '(broadcast-stream stream structure-object))) (assert (equal (cpl (make-broadcast-stream)) - '(broadcast-stream stream structure-object))) + '(broadcast-stream stream structure-object))) ;;; Bug in CALL-NEXT-METHOD: assignment to the method's formal ;;; parameters shouldn't affect the arguments to the next method for a @@ -786,7 +786,7 @@ (defgeneric cnm-assignment (x) (:method (x) x) (:method ((x integer)) (setq x 3) - (list x (call-next-method) (call-next-method x)))) + (list x (call-next-method) (call-next-method x)))) (assert (equal (cnm-assignment 1) '(3 1 3))) ;;; Bug reported by Istvan Marko 2003-07-09 @@ -834,17 +834,17 @@ (defmethod width ((c character-class) &key font) font) (defmethod width ((p picture-class) &key pixel-size) pixel-size) -(assert (raises-error? - (width (make-instance 'character-class :char #\Q) - :font 'baskerville :pixel-size 10) - program-error)) (assert (raises-error? - (width (make-instance 'picture-class :glyph #\Q) - :font 'baskerville :pixel-size 10) - program-error)) + (width (make-instance 'character-class :char #\Q) + :font 'baskerville :pixel-size 10) + program-error)) +(assert (raises-error? + (width (make-instance 'picture-class :glyph #\Q) + :font 'baskerville :pixel-size 10) + program-error)) (assert (eq (width (make-instance 'character-picture-class :char #\Q) - :font 'baskerville :pixel-size 10) - 'baskerville)) + :font 'baskerville :pixel-size 10) + 'baskerville)) ;;; class redefinition shouldn't give any warnings, in the usual case (defclass about-to-be-redefined () ((some-slot :accessor some-slot))) @@ -855,8 +855,8 @@ ;;; complex lambda lists should fail (defgeneric accessoroid (object &key &allow-other-keys)) (assert (raises-error? - (defclass accessoroid-class () ((slot :accessor accessoroid))) - program-error)) + (defclass accessoroid-class () ((slot :accessor accessoroid))) + program-error)) ;;; reported by Bruno Haible sbcl-devel 2004-04-15 (defclass shared-slot-and-redefinition () @@ -895,26 +895,26 @@ ;;; shared -> local slot transfers of inherited slots, reported by ;;; Bruno Haible (let (i) - (defclass super-with-magic-slot () + (defclass super-with-magic-slot () ((magic :initarg :size :initform 1 :allocation :class))) (defclass sub-of-super-with-magic-slot (super-with-magic-slot) ()) (setq i (make-instance 'sub-of-super-with-magic-slot)) - (defclass super-with-magic-slot () + (defclass super-with-magic-slot () ((magic :initarg :size :initform 2))) (assert (= 1 (slot-value i 'magic)))) ;;; MAKE-INSTANCES-OBSOLETE return values (defclass one-more-to-obsolete () ()) -(assert (eq 'one-more-to-obsolete - (make-instances-obsolete 'one-more-to-obsolete))) -(assert (eq (find-class 'one-more-to-obsolete) - (make-instances-obsolete (find-class 'one-more-to-obsolete)))) +(assert (eq 'one-more-to-obsolete + (make-instances-obsolete 'one-more-to-obsolete))) +(assert (eq (find-class 'one-more-to-obsolete) + (make-instances-obsolete (find-class 'one-more-to-obsolete)))) ;;; Sensible error instead of a BUG. Reported by Thomas Burdick. (multiple-value-bind (value err) (ignore-errors (defclass slot-def-with-duplicate-accessors () - ((slot :writer get-slot :reader get-slot)))) + ((slot :writer get-slot :reader get-slot)))) (assert (typep err 'error)) (assert (not (typep err 'sb-int:bug)))) @@ -988,36 +988,36 @@ ;;; methods on all of these. (progn (defgeneric method-for-defined-classes (x)) - (dolist (c '(arithmetic-error - generic-function simple-error array hash-table - simple-type-error - bit-vector integer simple-warning - broadcast-stream list standard-class - built-in-class logical-pathname standard-generic-function - cell-error method standard-method - character method-combination standard-object - class null storage-condition - complex number stream - concatenated-stream package stream-error - condition package-error string - cons parse-error string-stream - control-error pathname structure-class - division-by-zero print-not-readable structure-object - echo-stream program-error style-warning - end-of-file random-state symbol - error ratio synonym-stream - file-error rational t - file-stream reader-error two-way-stream - float readtable type-error - floating-point-inexact real unbound-slot - floating-point-invalid-operation restart unbound-variable - floating-point-overflow sequence undefined-function - floating-point-underflow serious-condition vector - function simple-condition warning)) + (dolist (c '(arithmetic-error + generic-function simple-error array hash-table + simple-type-error + bit-vector integer simple-warning + broadcast-stream list standard-class + built-in-class logical-pathname standard-generic-function + cell-error method standard-method + character method-combination standard-object + class null storage-condition + complex number stream + concatenated-stream package stream-error + condition package-error string + cons parse-error string-stream + control-error pathname structure-class + division-by-zero print-not-readable structure-object + echo-stream program-error style-warning + end-of-file random-state symbol + error ratio synonym-stream + file-error rational t + file-stream reader-error two-way-stream + float readtable type-error + floating-point-inexact real unbound-slot + floating-point-invalid-operation restart unbound-variable + floating-point-overflow sequence undefined-function + floating-point-underflow serious-condition vector + function simple-condition warning)) (eval `(defmethod method-for-defined-classes ((x ,c)) (princ x)))) (assert (string= (with-output-to-string (*standard-output*) - (method-for-defined-classes #\3)) - "3"))) + (method-for-defined-classes #\3)) + "3"))) @@ -1054,9 +1054,9 @@ ;; bug 281 (let ((sb-pcl::*max-emf-precomputation-methods* 0)) (eval '(defgeneric bug-281 (x) - (:method-combination +) - (:method ((x symbol)) 1) - (:method + ((x number)) x))) + (:method-combination +) + (:method ((x symbol)) 1) + (:method + ((x number)) x))) (assert (= 1 (bug-281 1))) (assert (= 4.2 (bug-281 4.2))) (multiple-value-bind (val err) (ignore-errors (bug-281 'symbol)) @@ -1074,46 +1074,46 @@ (defun rc-cm/add-method-restarts (form method) (let ((block (gensym)) - (tag (gensym))) + (tag (gensym))) `(block ,block (tagbody - ,tag - (return-from ,block - (restart-case ,form - (method-redo () - :report (lambda (stream) - (format stream "Try calling ~S again." ,method)) - (go ,tag)) - (method-return (l) - :report (lambda (stream) - (format stream "Specify return values for ~S call." - ,method)) - :interactive (lambda () (rc-cm/prompt-for-new-values)) - (return-from ,block (values-list l))))))))) + ,tag + (return-from ,block + (restart-case ,form + (method-redo () + :report (lambda (stream) + (format stream "Try calling ~S again." ,method)) + (go ,tag)) + (method-return (l) + :report (lambda (stream) + (format stream "Specify return values for ~S call." + ,method)) + :interactive (lambda () (rc-cm/prompt-for-new-values)) + (return-from ,block (values-list l))))))))) (defun rc-cm/convert-effective-method (efm) (if (consp efm) (if (eq (car efm) 'call-method) - (let ((method-list (third efm))) - (if (or (typep (first method-list) 'method) (rest method-list)) - ;; Reduce the case of multiple methods to a single one. - ;; Make the call to the next-method explicit. - (rc-cm/convert-effective-method - `(call-method ,(second efm) - ((make-method - (call-method ,(first method-list) ,(rest method-list)))))) - ;; Now the case of at most one method. - (if (typep (second efm) 'method) - ;; Wrap the method call in a RESTART-CASE. - (rc-cm/add-method-restarts - (cons (rc-cm/convert-effective-method (car efm)) - (rc-cm/convert-effective-method (cdr efm))) - (second efm)) - ;; Normal recursive processing. - (cons (rc-cm/convert-effective-method (car efm)) - (rc-cm/convert-effective-method (cdr efm)))))) - (cons (rc-cm/convert-effective-method (car efm)) - (rc-cm/convert-effective-method (cdr efm)))) + (let ((method-list (third efm))) + (if (or (typep (first method-list) 'method) (rest method-list)) + ;; Reduce the case of multiple methods to a single one. + ;; Make the call to the next-method explicit. + (rc-cm/convert-effective-method + `(call-method ,(second efm) + ((make-method + (call-method ,(first method-list) ,(rest method-list)))))) + ;; Now the case of at most one method. + (if (typep (second efm) 'method) + ;; Wrap the method call in a RESTART-CASE. + (rc-cm/add-method-restarts + (cons (rc-cm/convert-effective-method (car efm)) + (rc-cm/convert-effective-method (cdr efm))) + (second efm)) + ;; Normal recursive processing. + (cons (rc-cm/convert-effective-method (car efm)) + (rc-cm/convert-effective-method (cdr efm)))))) + (cons (rc-cm/convert-effective-method (car efm)) + (rc-cm/convert-effective-method (cdr efm)))) efm)) (define-method-combination standard-with-restarts () @@ -1122,20 +1122,20 @@ (primary () :required t) (after (:after))) (flet ((call-methods-sequentially (methods) - (mapcar #'(lambda (method) - `(call-method ,method)) - methods))) + (mapcar #'(lambda (method) + `(call-method ,method)) + methods))) (let ((form (if (or before after (rest primary)) `(multiple-value-prog1 (progn ,@(call-methods-sequentially before) (call-method ,(first primary) ,(rest primary))) - ,@(call-methods-sequentially (reverse after))) + ,@(call-methods-sequentially (reverse after))) `(call-method ,(first primary))))) (when around - (setq form - `(call-method ,(first around) - (,@(rest around) (make-method ,form))))) + (setq form + `(call-method ,(first around) + (,@(rest around) (make-method ,form))))) (rc-cm/convert-effective-method form)))) (defgeneric rc-cm/testgf16 (x) @@ -1155,7 +1155,7 @@ (defmethod rc-cm/testgf16 ((x rc-cm/testclass16d)) (cons 'd (call-next-method))) (assert (equal (rc-cm/testgf16 (make-instance 'rc-cm/testclass16d)) - '(d b c a t t))) + '(d b c a t t))) ;;; test case from Gerd Moellmann (define-method-combination r-c/c-m-1 () diff --git a/tests/clos.pure.lisp b/tests/clos.pure.lisp index b110f27..377c7e8 100644 --- a/tests/clos.pure.lisp +++ b/tests/clos.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -19,22 +19,22 @@ ;;; depends on it. The basic functionality is tested elsewhere, but ;;; this is to investigate the internals for possible inconsistency. (assert (null - (let (collect) - (sb-pcl::map-all-generic-functions - (lambda (gf) - (let ((arg-info (sb-pcl::gf-arg-info gf))) - (when (eq (sb-pcl::arg-info-lambda-list arg-info) - :no-lambda-list) - (push gf collect))))) - (print (nreverse collect))))) + (let (collect) + (sb-pcl::map-all-generic-functions + (lambda (gf) + (let ((arg-info (sb-pcl::gf-arg-info gf))) + (when (eq (sb-pcl::arg-info-lambda-list arg-info) + :no-lambda-list) + (push gf collect))))) + (print (nreverse collect))))) ;;; Regressing test for invalid slot specification error printing -(multiple-value-bind (value err) +(multiple-value-bind (value err) (ignore-errors (macroexpand '(defclass foo () (frob (frob bar))))) (declare (ignore value)) (assert (typep err 'simple-condition)) (multiple-value-bind (value format-err) - (ignore-errors (apply #'format nil + (ignore-errors (apply #'format nil (simple-condition-format-control err) (simple-condition-format-arguments err))) (declare (ignore value)) diff --git a/tests/compiler-1.impure-cload.lisp b/tests/compiler-1.impure-cload.lisp index 1eb8e3d..5b9c106 100644 --- a/tests/compiler-1.impure-cload.lisp +++ b/tests/compiler-1.impure-cload.lisp @@ -7,7 +7,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -39,7 +39,7 @@ (declaim (ftype (function (real) (values integer single-float)) valuesify)) (defun valuesify (x) (values (round x) - (coerce x 'single-float))) + (coerce x 'single-float))) (defun exercise-valuesify (x) (multiple-value-bind (i f) (valuesify x) (declare (type integer i)) @@ -112,9 +112,9 @@ (when (consp (aref x 0)) (aref x 0))) (assert (raises-error? - (array-element-type-handling - (make-array 3 :element-type t :initial-element 0)) - type-error)) + (array-element-type-handling + (make-array 3 :element-type t :initial-element 0)) + type-error)) ;;; bug 220: type check inserted after all arguments in MV-CALL caused ;;; failure of stack analysis diff --git a/tests/compiler.impure-cload.lisp b/tests/compiler.impure-cload.lisp index 41d0525..7d5e99d 100644 --- a/tests/compiler.impure-cload.lisp +++ b/tests/compiler.impure-cload.lisp @@ -364,20 +364,20 @@ ;;; failed on Alpha prior to sbcl-0.8.10.30 (defun lotso-values () (values 0 1 2 3 4 5 6 7 8 9 - 0 1 2 3 4 5 6 7 8 9 - 0 1 2 3 4 5 6 7 8 9 - 0 1 2 3 4 5 6 7 8 9 - 0 1 2 3 4 5 6 7 8 9 - 0 1 2 3 4 5 6 7 8 9 - 0 1 2 3 4 5 6 7 8 9 - 0 1 2 3 4 5 6 7 8 9 - 0 1 2 3 4 5 6 7 8 9 - 0 1 2 3 4 5 6 7 8 9)) + 0 1 2 3 4 5 6 7 8 9 + 0 1 2 3 4 5 6 7 8 9 + 0 1 2 3 4 5 6 7 8 9 + 0 1 2 3 4 5 6 7 8 9 + 0 1 2 3 4 5 6 7 8 9 + 0 1 2 3 4 5 6 7 8 9 + 0 1 2 3 4 5 6 7 8 9 + 0 1 2 3 4 5 6 7 8 9 + 0 1 2 3 4 5 6 7 8 9)) ;;; bug 313: source transforms were "lisp-1" (defun srctran-lisp1-1 (cadr) (if (functionp cadr) (funcall cadr 1) nil)) (assert (eql (funcall (eval #'srctran-lisp1-1) #'identity) 1)) -(without-package-locks +(without-package-locks ;; this be a nasal demon, but test anyways (defvar caar)) (defun srctran-lisp1-2 (caar) (funcall (sb-ext:truly-the function caar) 1)) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 57e9636..79c8bb7 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -10,7 +10,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -46,9 +46,9 @@ (let (num x) (flet ((digs () (setq num index)) - (z () - (let () - (setq x nil)))) + (z () + (let () + (setq x nil)))) (when (and (digs) (digs)) x)))) ;;; Bug 132: The compiler used to fail to compile INTEGER-valued CATCH @@ -68,8 +68,8 @@ (flet ((wufn () (glorp table1 4.9))) (gleep *uustk* #'wufn "#1" (list))) (if (eql (lo foomax 3.2)) - (values) - (error "not ~S" '(eql (lo foomax 3.2)))) + (values) + (error "not ~S" '(eql (lo foomax 3.2)))) (values))) ;;; A simpler test case for bug 150: The compiler died with the ;;; same type error when trying to compile this. @@ -84,9 +84,9 @@ (defun bug147 (string ind) (flet ((digs () (let (old-index) - (if (and (< ind ind) - (typep (char string ind) '(member #\1))) - nil)))))) + (if (and (< ind ind) + (typep (char string ind) '(member #\1))) + nil)))))) ;;; bug reported and fixed by Matthias Hoelzl sbcl-devel 2002-05-13 (defmacro foo-2002-05-13 () ''x) @@ -120,24 +120,24 @@ (defstruct something-known-to-be-a-struct x y) (multiple-value-bind (fun warnings-p failure-p) (compile nil - '(lambda () - (labels ((a1 (a2 a3) - (cond (t (a4 a2 a3)))) - (a4 (a2 a3 a5 a6) - (declare (type (or simple-vector null) a5 a6)) - (something-known-to-be-a-struct-x a5)) - (a8 (a2 a3) - (a9 #'a1 a10 a2 a3)) - (a11 (a2 a3) - (cond ((and (funcall a12 a2) - (funcall a12 a3)) - (funcall a13 a2 a3)) - (t - (when a14 - (let ((a15 (a1 a2 a3))) - )) - a16)))) - (values #'a17 #'a11)))) + '(lambda () + (labels ((a1 (a2 a3) + (cond (t (a4 a2 a3)))) + (a4 (a2 a3 a5 a6) + (declare (type (or simple-vector null) a5 a6)) + (something-known-to-be-a-struct-x a5)) + (a8 (a2 a3) + (a9 #'a1 a10 a2 a3)) + (a11 (a2 a3) + (cond ((and (funcall a12 a2) + (funcall a12 a3)) + (funcall a13 a2 a3)) + (t + (when a14 + (let ((a15 (a1 a2 a3))) + )) + a16)))) + (values #'a17 #'a11)))) ;; Python sees the structure accessor on the known-not-to-be-a-struct ;; A5 value and is very, very disappointed in you. (But it doesn't ;; signal BUG any more.) @@ -149,10 +149,10 @@ ;;; spotted and fixed by Raymond Toy for CMUCL) (defun logand-sparc-bogons (a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) (declare (type (unsigned-byte 32) a0) - (type (signed-byte 32) a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) - ;; to ensure that the call is a candidate for - ;; transformation - (optimize (speed 3) (safety 0) (compilation-speed 0) (debug 0))) + (type (signed-byte 32) a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) + ;; to ensure that the call is a candidate for + ;; transformation + (optimize (speed 3) (safety 0) (compilation-speed 0) (debug 0))) (values ;; the call that fails compilation (logand a0 a10) @@ -165,7 +165,7 @@ ;;; except that there was no non-VOP definition of DATA-VECTOR-REF, so ;;; it would fail. (defun bug192 () - (funcall + (funcall (LAMBDA (TEXT I L ) (LABELS ((G908 (I) (LET ((INDEX @@ -208,65 +208,65 @@ (labels ((alpha-equal-bound-term-lists (listx listy) (or (and (null listx) (null listy)) - (and listx listy - (let ((bindings-x (bindings-of-bound-term (car listx))) - (bindings-y (bindings-of-bound-term (car listy)))) - (if (and (null bindings-x) (null bindings-y)) - (alpha-equal-terms (term-of-bound-term (car listx)) - (term-of-bound-term (car listy))) - (and (= (length bindings-x) (length bindings-y)) - (prog2 - (enter-binding-pairs (bindings-of-bound-term (car listx)) - (bindings-of-bound-term (car listy))) - (alpha-equal-terms (term-of-bound-term (car listx)) - (term-of-bound-term (car listy))) - (exit-binding-pairs (bindings-of-bound-term (car listx)) - (bindings-of-bound-term (car listy))))))) - (alpha-equal-bound-term-lists (cdr listx) (cdr listy))))) + (and listx listy + (let ((bindings-x (bindings-of-bound-term (car listx))) + (bindings-y (bindings-of-bound-term (car listy)))) + (if (and (null bindings-x) (null bindings-y)) + (alpha-equal-terms (term-of-bound-term (car listx)) + (term-of-bound-term (car listy))) + (and (= (length bindings-x) (length bindings-y)) + (prog2 + (enter-binding-pairs (bindings-of-bound-term (car listx)) + (bindings-of-bound-term (car listy))) + (alpha-equal-terms (term-of-bound-term (car listx)) + (term-of-bound-term (car listy))) + (exit-binding-pairs (bindings-of-bound-term (car listx)) + (bindings-of-bound-term (car listy))))))) + (alpha-equal-bound-term-lists (cdr listx) (cdr listy))))) (alpha-equal-terms (termx termy) (if (and (variable-p termx) - (variable-p termy)) - (equal-bindings (id-of-variable-term termx) - (id-of-variable-term termy)) - (and (equal-operators-p (operator-of-term termx) (operator-of-term termy)) - (alpha-equal-bound-term-lists (bound-terms-of-term termx) - (bound-terms-of-term termy)))))) + (variable-p termy)) + (equal-bindings (id-of-variable-term termx) + (id-of-variable-term termy)) + (and (equal-operators-p (operator-of-term termx) (operator-of-term termy)) + (alpha-equal-bound-term-lists (bound-terms-of-term termx) + (bound-terms-of-term termy)))))) (or (eq termx termy) - (and termx termy - (with-variable-invocation (alpha-equal-terms termx termy)))))) + (and termx termy + (with-variable-invocation (alpha-equal-terms termx termy)))))) (defun bug65-2 () ; from Bob Rogers cmucl-imp 1999-07-28 ;; Given an FSSP alignment file named by the argument . . . (labels ((get-fssp-char () - (get-fssp-char)) - (read-fssp-char () - (get-fssp-char))) + (get-fssp-char)) + (read-fssp-char () + (get-fssp-char))) ;; Stub body, enough to tickle the bug. (list (read-fssp-char) - (read-fssp-char)))) + (read-fssp-char)))) (defun bug70 ; from David Young cmucl-help 30 Nov 2000 (item sequence &key (test #'eql)) (labels ((find-item (obj seq test &optional (val nil)) - (let ((item (first seq))) - (cond ((null seq) - (values nil nil)) - ((funcall test obj item) - (values val seq)) - (t - (find-item obj - (rest seq) - test - (nconc val `(,item)))))))) + (let ((item (first seq))) + (cond ((null seq) + (values nil nil)) + ((funcall test obj item) + (values val seq)) + (t + (find-item obj + (rest seq) + test + (nconc val `(,item)))))))) (find-item item sequence test))) (defun bug109 () ; originally from CMU CL bugs collection, reported as ; SBCL bug by MNA 2001-06-25 - (labels + (labels ((eff (&key trouble) - (eff) - ;; nil - ;; Uncomment and it works - )) + (eff) + ;; nil + ;; Uncomment and it works + )) (eff))) ;;; bug 192a, fixed by APD "more strict type checking" patch @@ -316,11 +316,11 @@ (assert (raises-error? (funcall function) program-error))) (multiple-value-bind (function warnings-p failure-p) (compile nil - '(lambda () + '(lambda () ;; not interested in the package lock violation here (declare (sb-ext:disable-package-locks *standard-input*)) - (symbol-macrolet ((*standard-input* nil)) - *standard-input*))) + (symbol-macrolet ((*standard-input* nil)) + *standard-input*))) (assert failure-p) (assert (raises-error? (funcall function) program-error))) (multiple-value-bind (function warnings-p failure-p) @@ -342,7 +342,7 @@ (declare (optimize (speed 3) (safety 1) (debug 1))) (if x t (if y t (dont-constrain-if-too-much x y)))) -(assert (null (dont-constrain-if-too-much-aux nil nil))) +(assert (null (dont-constrain-if-too-much-aux nil nil))) ;;; TYPE-ERROR confusion ca. sbcl-0.7.7.24, reported and fixed by ;;; APD sbcl-devel 2002-09-14 @@ -585,7 +585,7 @@ ;;; bug 172: macro lambda lists were too permissive until 0.7.9.28 ;;; (fix provided by Matthew Danish) on sbcl-devel (assert (null (ignore-errors - (defmacro bug172 (&rest rest foo) `(list ,rest ,foo))))) + (defmacro bug172 (&rest rest foo) `(list ,rest ,foo))))) ;;; embedded THEs (defun check-embedded-thes (policy1 policy2 x y) @@ -632,9 +632,9 @@ (defun to-be-inlined (y) (frob y))) (assert (= (call-inlined 3) - ;; we should have inlined the previous definition, so the - ;; new one won't show up yet. - 4)) + ;; we should have inlined the previous definition, so the + ;; new one won't show up yet. + 4)) (defun call-inlined (z) (to-be-inlined z)) (assert (= (call-inlined 3) 6)) @@ -655,7 +655,7 @@ (defun bug219-a-aux () (bug219-a 2)) (assert (= (bug219-a-aux) - (if *bug219-a-expanded-p* 4 3))) + (if *bug219-a-expanded-p* 4 3))) (defvar *bug219-a-temp* 3) (assert (= (bug219-a *bug219-a-temp*) 4)) @@ -675,7 +675,7 @@ (defun bug219-b (x) x) (assert (= (bug219-b-aux2 1) - (if *bug219-b-expanded-p* 3 1))) + (if *bug219-b-expanded-p* 3 1))) ;;; bug 224: failure in unreachable code deletion (defmacro do-optimizations (&body body) @@ -747,11 +747,11 @@ ;;; WHN's original report (defun debug-return-catch-break1 () (with-open-file (s "/tmp/foo" - :direction :output - :element-type (list - 'signed-byte - (1+ - (integer-length most-positive-fixnum)))) + :direction :output + :element-type (list + 'signed-byte + (1+ + (integer-length most-positive-fixnum)))) (read-byte s) (read-byte s) (read-byte s) @@ -766,8 +766,8 @@ ;;; can understand. Here's a simple test for that on a function ;;; that's likely to return a hairier list than just a lambda: (macrolet ((def (fn) `(progn - (declaim (inline ,fn)) - (defun ,fn (x) (1+ x))))) + (declaim (inline ,fn)) + (defun ,fn (x) (1+ x))))) (def bug228)) (let ((x (function-lambda-expression #'bug228))) (when x @@ -818,9 +818,9 @@ (+ x y)) (defun baz8alpha04 (this kids) (flet ((n-i (&rest rest) - ;; Removing the #+NIL here makes the bug go away. - #+nil (format t "~&in N-I REST=~S~%" rest) - (apply #'frob8alpha04 this rest))) + ;; Removing the #+NIL here makes the bug go away. + #+nil (format t "~&in N-I REST=~S~%" rest) + (apply #'frob8alpha04 this rest))) (n-i kids))) ;;; failed in 0.8alpha.0.4 with "The value 13 is not of type LIST." (assert (= (baz8alpha04 12 13) 25)) @@ -875,7 +875,7 @@ (unless (< a b) (truncate (expt a b)))) (assert (equal (multiple-value-list (expt-derive-type-bug 1 1)) - '(1 0))) + '(1 0))) ;;; Problems with type checking in functions with EXPLICIT-CHECK ;;; attribute (reported by Peter Graves) @@ -900,18 +900,18 @@ (defvar *compiler-note-count* 0) #-(or alpha x86-64) ; FIXME: make a better test! (handler-bind ((sb-ext:compiler-note (lambda (c) - (declare (ignore c)) - (incf *compiler-note-count*)))) + (declare (ignore c)) + (incf *compiler-note-count*)))) (let ((fun - (compile nil - '(lambda (x) - (declare (optimize speed) (fixnum x)) - (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) - (values (* x 5) ; no compiler note from this - (locally - (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note)) - ;; this one gives a compiler note - (* x -5))))))) + (compile nil + '(lambda (x) + (declare (optimize speed) (fixnum x)) + (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) + (values (* x 5) ; no compiler note from this + (locally + (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note)) + ;; this one gives a compiler note + (* x -5))))))) (assert (= *compiler-note-count* 1)) (assert (equal (multiple-value-list (funcall fun 1)) '(5 -5))))) @@ -940,61 +940,61 @@ (dolist (template (fun-info-templates (info :function :info function))) (when (template-more-results-type template) (format t "~&Template ~A has :MORE results, and translates ~A.~%" - (template-name template) - function) + (template-name template) + function) (return nil)) (when (eq (template-result-types template) :conditional) ;; dunno. (return t)) (let ((types (template-result-types template)) - (result-type (fun-type-returns (info :function :type function)))) + (result-type (fun-type-returns (info :function :type function)))) (cond - ((values-type-p result-type) - (do ((ltypes (append (args-type-required result-type) - (args-type-optional result-type)) - (rest ltypes)) - (types types (rest types))) - ((null ltypes) - (unless (null types) - (format t "~&More types than ltypes in ~A, translating ~A.~%" - (template-name template) - function) - (return nil))) - (when (null types) - (unless (null ltypes) - (format t "~&More ltypes than types in ~A, translating ~A.~%" - (template-name template) - function) - (return nil))))) - ((eq result-type (specifier-type nil)) - (unless (null types) - (format t "~&Template ~A returns values for function ~A with RESULT-TYPE NIL.~%" - (template-name template) - function) - (return nil))) - ((/= (length types) 1) - (format t "~&Template ~A isn't returning 1 value for ~A.~%" - (template-name template) - function) - (return nil)) - (t t))))) + ((values-type-p result-type) + (do ((ltypes (append (args-type-required result-type) + (args-type-optional result-type)) + (rest ltypes)) + (types types (rest types))) + ((null ltypes) + (unless (null types) + (format t "~&More types than ltypes in ~A, translating ~A.~%" + (template-name template) + function) + (return nil))) + (when (null types) + (unless (null ltypes) + (format t "~&More ltypes than types in ~A, translating ~A.~%" + (template-name template) + function) + (return nil))))) + ((eq result-type (specifier-type nil)) + (unless (null types) + (format t "~&Template ~A returns values for function ~A with RESULT-TYPE NIL.~%" + (template-name template) + function) + (return nil))) + ((/= (length types) 1) + (format t "~&Template ~A isn't returning 1 value for ~A.~%" + (template-name template) + function) + (return nil)) + (t t))))) (defun identify-suspect-vops (&optional (env (first - (last *info-environment*)))) + (last *info-environment*)))) (do-info (env :class class :type type :name name :value value) (when (and (eq class :function) (eq type :type)) ;; OK, so we have an entry in the INFO database. Now, if ... (let* ((info (info :function :info name)) - (templates (and info (fun-info-templates info)))) - (when templates - ;; ... it has translators - (grovel-results name)))))) + (templates (and info (fun-info-templates info)))) + (when templates + ;; ... it has translators + (grovel-results name)))))) (identify-suspect-vops) ;;;; tests for compiler output (let* ((*error-output* (make-broadcast-stream)) (output (with-output-to-string (*standard-output*) - (compile-file "compiler-output-test.lisp" - :print nil :verbose nil)))) + (compile-file "compiler-output-test.lisp" + :print nil :verbose nil)))) (print output) (assert (zerop (length output)))) @@ -1003,27 +1003,27 @@ (define-condition optimization-error (error) ()) (labels ((compile-lambda (type sense) - (handler-bind ((compiler-note (lambda (_) - (declare (ignore _)) - (error 'optimization-error)))) - (values - (compile - nil - `(lambda () - (declare - ,@(when type '((ftype (function () (integer 0 10)) bug-305))) - (,sense bug-305) - (optimize speed)) - (1+ (bug-305)))) - nil))) - (expect-error (sense) - (multiple-value-bind (f e) (ignore-errors (compile-lambda nil sense)) - (assert (not f)) - (assert (typep e 'optimization-error)))) - (expect-pass (sense) - (multiple-value-bind (f e) (ignore-errors (compile-lambda t sense)) - (assert f) - (assert (not e))))) + (handler-bind ((compiler-note (lambda (_) + (declare (ignore _)) + (error 'optimization-error)))) + (values + (compile + nil + `(lambda () + (declare + ,@(when type '((ftype (function () (integer 0 10)) bug-305))) + (,sense bug-305) + (optimize speed)) + (1+ (bug-305)))) + nil))) + (expect-error (sense) + (multiple-value-bind (f e) (ignore-errors (compile-lambda nil sense)) + (assert (not f)) + (assert (typep e 'optimization-error)))) + (expect-pass (sense) + (multiple-value-bind (f e) (ignore-errors (compile-lambda t sense)) + (assert f) + (assert (not e))))) (expect-error 'inline) (expect-error 'notinline) (expect-pass 'inline) @@ -1033,38 +1033,38 @@ ;;; a local function. (handler-bind ((style-warning #'error)) (let ((f (compile nil '(lambda () - (flet ((foo (&key y) (list y))) - (list (foo :y 1 :y 2))))))) + (flet ((foo (&key y) (list y))) + (list (foo :y 1 :y 2))))))) (assert (equal '((1)) (funcall f))))) ;;; check that EQL is optimized when other argument is (OR SYMBOL FIXNUM). (handler-bind ((compiler-note #'error)) - (let ((f1 (compile nil '(lambda (x1 y1) - (declare (type (or symbol fixnum) x1) - (optimize speed)) - (eql x1 y1)))) - (f2 (compile nil '(lambda (x2 y2) - (declare (type (or symbol fixnum) y2) - (optimize speed)) - (eql x2 y2))))) + (let ((f1 (compile nil '(lambda (x1 y1) + (declare (type (or symbol fixnum) x1) + (optimize speed)) + (eql x1 y1)))) + (f2 (compile nil '(lambda (x2 y2) + (declare (type (or symbol fixnum) y2) + (optimize speed)) + (eql x2 y2))))) (let ((fix (random most-positive-fixnum)) - (sym (gensym)) - (e-count 0)) + (sym (gensym)) + (e-count 0)) (assert (funcall f1 fix fix)) (assert (funcall f2 fix fix)) (assert (funcall f1 sym sym)) - (assert (funcall f2 sym sym)) + (assert (funcall f2 sym sym)) (handler-bind ((type-error (lambda (c) - (incf e-count) - (continue c)))) - (flet ((test (f x y) - (with-simple-restart (continue "continue with next test") - (funcall f x y) - (error "fell through with (~S ~S ~S)" f x y)))) - (test f1 "oops" 42) - (test f1 (1+ most-positive-fixnum) 42) - (test f2 42 "oops") - (test f2 42 (1+ most-positive-fixnum)))) + (incf e-count) + (continue c)))) + (flet ((test (f x y) + (with-simple-restart (continue "continue with next test") + (funcall f x y) + (error "fell through with (~S ~S ~S)" f x y)))) + (test f1 "oops" 42) + (test f1 (1+ most-positive-fixnum) 42) + (test f2 42 "oops") + (test f2 42 (1+ most-positive-fixnum)))) (assert (= e-count 4))))) ;;; success diff --git a/tests/compiler.pure-cload.lisp b/tests/compiler.pure-cload.lisp index 04eb4d7..3136813 100644 --- a/tests/compiler.pure-cload.lisp +++ b/tests/compiler.pure-cload.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -27,7 +27,7 @@ ;;; 0 is not of type (OR FUNCTION SB-KERNEL:FDEFN). ;;; Correct behavior is to warn at compile time because the symbol ;;; isn't declared as a variable, but to set its SYMBOL-VALUE anyway. -;;; +;;; ;;; This bug was in sbcl-0.6.11.13. (print (setq improperly-declared-var '(1 2))) (assert (equal (symbol-value 'improperly-declared-var) '(1 2))) @@ -85,15 +85,15 @@ (defun #:foo (b c) (declare (type (integer -23228343 2) b) - (type (integer -115581022 512244512) c) - (optimize (speed 3) (safety 1) (debug 1))) + (type (integer -115581022 512244512) c) + (optimize (speed 3) (safety 1) (debug 1))) (* (* (logorc2 3 (deposit-field 4667947 (byte 14 26) b)) - (deposit-field b (byte 25 27) -30424886)) + (deposit-field b (byte 25 27) -30424886)) (dpb b (byte 23 29) c))) (defun #:foo (x y) (declare (type (integer -1 1000000000000000000000000) x y) - (optimize speed)) + (optimize speed)) (* x (* y x))) (defun #:foo (b) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 7cb31f2..f6a7848 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -21,67 +21,67 @@ ;;; The bug was fixed by Douglas Crosher's patch, massaged for SBCL by ;;; Martin Atzmueller (2000-09-13 on sbcl-devel). (funcall (compile nil - '(lambda () - (labels ((fun1 () - (fun2)) - (fun2 () - (when nil - (tagbody - tag - (fun2) - (go tag))) - (when nil - (tagbody - tag - (fun1) - (go tag))))) - - (fun1) - nil)))) + '(lambda () + (labels ((fun1 () + (fun2)) + (fun2 () + (when nil + (tagbody + tag + (fun2) + (go tag))) + (when nil + (tagbody + tag + (fun1) + (go tag))))) + + (fun1) + nil)))) ;;; Exercise a compiler bug (by crashing the compiler). ;;; -;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on +;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on ;;; cmucl-imp, and Martin Atzmueller applied it to SBCL. (funcall (compile nil - '(lambda (x) - (or (integerp x) - (block used-by-some-y? - (flet ((frob (stk) - (dolist (y stk) - (unless (rejected? y) - (return-from used-by-some-y? t))))) - (declare (inline frob)) - (frob (rstk x)) - (frob (mrstk x))) - nil)))) - 13) + '(lambda (x) + (or (integerp x) + (block used-by-some-y? + (flet ((frob (stk) + (dolist (y stk) + (unless (rejected? y) + (return-from used-by-some-y? t))))) + (declare (inline frob)) + (frob (rstk x)) + (frob (mrstk x))) + nil)))) + 13) ;;; bug 112, reported by Martin Atzmueller 2001-06-25 (originally ;;; from Bruno Haible in CMU CL bugs collection), fixed by ;;; Alexey Dejneka 2002-01-27 (assert (= 1 ; (used to give 0 under bug 112) - (let ((x 0)) - (declare (special x)) - (let ((x 1)) - (let ((y x)) - (declare (special x)) y))))) + (let ((x 0)) + (declare (special x)) + (let ((x 1)) + (let ((y x)) + (declare (special x)) y))))) (assert (= 1 ; (used to give 1 even under bug 112, still works after fix) - (let ((x 0)) - (declare (special x)) - (let ((x 1)) - (let ((y x) (x 5)) - (declare (special x)) y))))) + (let ((x 0)) + (declare (special x)) + (let ((x 1)) + (let ((y x) (x 5)) + (declare (special x)) y))))) ;;; another LET-related bug fixed by Alexey Dejneka at the same ;;; time as bug 112 (multiple-value-bind (fun warnings-p failure-p) ;; should complain about duplicate variable names in LET binding (compile nil - '(lambda () - (let (x - (x 1)) - (list x)))) + '(lambda () + (let (x + (x 1)) + (list x)))) (declare (ignore warnings-p)) (assert (functionp fun)) (assert failure-p)) @@ -91,26 +91,26 @@ (progn (multiple-value-bind (fun warnings-p failure-p) (compile nil - ;; Compiling this code should cause a STYLE-WARNING - ;; about *X* looking like a special variable but not - ;; being one. - '(lambda (n) - (let ((*x* n)) - (funcall (symbol-function 'x-getter)) - (print *x*)))) + ;; Compiling this code should cause a STYLE-WARNING + ;; about *X* looking like a special variable but not + ;; being one. + '(lambda (n) + (let ((*x* n)) + (funcall (symbol-function 'x-getter)) + (print *x*)))) (assert (functionp fun)) (assert warnings-p) (assert (not failure-p))) (multiple-value-bind (fun warnings-p failure-p) (compile nil - ;; Compiling this code should not cause a warning - ;; (because the DECLARE turns *X* into a special - ;; variable as its name suggests it should be). - '(lambda (n) - (let ((*x* n)) - (declare (special *x*)) - (funcall (symbol-function 'x-getter)) - (print *x*)))) + ;; Compiling this code should not cause a warning + ;; (because the DECLARE turns *X* into a special + ;; variable as its name suggests it should be). + '(lambda (n) + (let ((*x* n)) + (declare (special *x*)) + (funcall (symbol-function 'x-getter)) + (print *x*)))) (assert (functionp fun)) (assert (not warnings-p)) (assert (not failure-p)))) @@ -167,7 +167,7 @@ ;;; 2002-09-12, this failed in sbcl-0.7.7.23. (with failed AVER ;;; "(LEAF-HAS-SOURCE-NAME-P LEAF)") (assert (= (funcall (eval `(lambda (x) (funcall ,(lambda (y) (+ y 3)) x))) 14) - 17)) + 17)) ;;; bug 181: bad type specifier dropped compiler into debugger (assert (list (compile nil '(lambda (x) @@ -252,37 +252,37 @@ ;;; PSETQ should behave when given complex symbol-macro arguments (multiple-value-bind (sequence index) (symbol-macrolet ((x (aref a (incf i))) - (y (aref a (incf i)))) - (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) - (i 0)) - (psetq x (aref a (incf i)) - y (aref a (incf i))) - (values a i))) + (y (aref a (incf i)))) + (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) + (i 0)) + (psetq x (aref a (incf i)) + y (aref a (incf i))) + (values a i))) (assert (equalp sequence #(0 2 2 4 4 5 6 7 8 9))) (assert (= index 4))) (multiple-value-bind (result error) (ignore-errors (let ((x (list 1 2))) - (psetq (car x) 3) - x)) + (psetq (car x) 3) + x)) (assert (null result)) (assert (typep error 'program-error))) ;;; COPY-SEQ should work on known-complex vectors: (assert (equalp #(1) - (let ((v (make-array 0 :fill-pointer 0))) - (vector-push-extend 1 v) - (copy-seq v)))) + (let ((v (make-array 0 :fill-pointer 0))) + (vector-push-extend 1 v) + (copy-seq v)))) ;;; to support INLINE functions inside MACROLET, it is necessary for ;;; FUNCTION-LAMBDA-EXPRESSION to return a proper lambda expression in ;;; certain circumstances, one of which is when compile is called from ;;; top-level. (assert (equal - (function-lambda-expression - (compile nil '(lambda (x) (block nil (print x))))) - '(lambda (x) (block nil (print x))))) + (function-lambda-expression + (compile nil '(lambda (x) (block nil (print x))))) + '(lambda (x) (block nil (print x))))) ;;; bug 62: too cautious type inference in a loop (assert (nth-value @@ -389,8 +389,8 @@ (values nil t t)))))) (assert (typep (eval `(the arithmetic-error - ',(make-condition 'arithmetic-error))) - 'arithmetic-error)) + ',(make-condition 'arithmetic-error))) + 'arithmetic-error)) (assert (not (nth-value 2 (compile nil '(lambda () @@ -460,17 +460,17 @@ (handler-bind ((sb-ext:compiler-note #'error)) (compile nil '(lambda (x) - (declare (type (simple-array (simple-string 3) (5)) x)) - (aref (aref x 0) 0)))) + (declare (type (simple-array (simple-string 3) (5)) x)) + (aref (aref x 0) 0)))) ;;; compiler failure (let ((f (compile nil '(lambda (x) (typep x '(not (member 0d0))))))) (assert (funcall f 1d0))) (compile nil '(lambda (x) - (declare (double-float x)) - (let ((y (* x pi))) - (atan y y)))) + (declare (double-float x)) + (let ((y (* x pi))) + (atan y y)))) ;;; bogus optimization of BIT-NOT (multiple-value-bind (result x) @@ -484,13 +484,13 @@ ;;; the VECTOR type in CONCATENATE/MERGE/MAKE-SEQUENCE means (VECTOR T). (handler-bind ((sb-ext:compiler-note #'error)) (assert (equalp (funcall - (compile - nil - '(lambda () - (let ((x (make-sequence 'vector 10 :initial-element 'a))) - (setf (aref x 4) 'b) - x)))) - #(a a a a b a a a a a)))) + (compile + nil + '(lambda () + (let ((x (make-sequence 'vector 10 :initial-element 'a))) + (setf (aref x 4) 'b) + x)))) + #(a a a a b a a a a a)))) ;;; this is not a check for a bug, but rather a test of compiler ;;; quality @@ -566,8 +566,8 @@ ;;; (SIGNED-BYTE 1) [ returned from the logxor derive-type optimizer ] ;;; wasn't recognized as a good type specifier. (let ((fun (lambda (x y) - (declare (type (integer -1 0) x y) (optimize speed)) - (logxor x y)))) + (declare (type (integer -1 0) x y) (optimize speed)) + (logxor x y)))) (assert (= (funcall fun 0 0) 0)) (assert (= (funcall fun 0 -1) -1)) (assert (= (funcall fun -1 -1) 0))) @@ -637,12 +637,12 @@ ;;; bug in Alpha backend: not enough sanity checking of arguments to ;;; instructions -(assert (= (funcall (compile nil - '(lambda (x) - (declare (fixnum x)) - (ash x -257))) - 1024) - 0)) +(assert (= (funcall (compile nil + '(lambda (x) + (declare (fixnum x)) + (ash x -257))) + 1024) + 0)) ;;; bug found by WHN and pfdietz: compiler failure while referencing ;;; an entry point inside a deleted lambda @@ -682,19 +682,19 @@ ;;; reasonable multiplication never returned, causing chaos. Fixed by ;;; explicitly doing modular arithmetic, and relying on the backends ;;; being smart. -(assert (= (funcall - (compile nil - '(lambda (x) - (declare (type (integer 178956970 178956970) x) - (optimize speed)) - (* x 24))) - 178956970) - 4294967280)) +(assert (= (funcall + (compile nil + '(lambda (x) + (declare (type (integer 178956970 178956970) x) + (optimize speed)) + (* x 24))) + 178956970) + 4294967280)) ;;; bug in modular arithmetic and type specifiers (assert (= (funcall (compile nil (lambda (x) (logand x x 0))) - -1) - 0)) + -1) + 0)) ;;; MISC.99 from Paul Dietz' random tester: FAST-ASH-MOD32-C VOP ;;; produced wrong result for shift >=32 on X86 @@ -881,19 +881,19 @@ (labels ((%f12 (f12-1 f12-2) (labels ((%f2 (f2-1 f2-2) (flet ((%f6 () - (flet ((%f18 + (flet ((%f18 (f18-1 &optional (f18-2 a) (f18-3 -207465075) (f18-4 a)) (return-from %f12 b))) - (%f18 -3489553 - -7 - (%f18 (%f18 150 -64 f12-1) - (%f18 (%f18 -8531) - 11410) - b) - 56362666)))) + (%f18 -3489553 + -7 + (%f18 (%f18 150 -64 f12-1) + (%f18 (%f18 -8531) + 11410) + b) + 56362666)))) (labels ((%f7 (f7-1 f7-2 &optional (f7-3 (%f6))) @@ -1189,18 +1189,18 @@ '(lambda (a b c) (declare (notinline boole values denominator list)) (declare - (optimize (speed 2) - (space 0) - (safety 1) - (debug 0) - (compilation-speed 2))) + (optimize (speed 2) + (space 0) + (safety 1) + (debug 0) + (compilation-speed 2))) (catch 'ct6 - (progv - '(*s8*) - (list 0) - (let ((v9 (ignore-errors (throw 'ct6 0)))) - (denominator - (progv nil nil (values (boole boole-and 0 v9))))))))) + (progv + '(*s8*) + (list 0) + (let ((v9 (ignore-errors (throw 'ct6 0)))) + (denominator + (progv nil nil (values (boole boole-and 0 v9))))))))) 1 2 3))) ;;; non-continuous dead UVL blocks @@ -1241,21 +1241,21 @@ nil '(lambda (b g h) (declare (optimize (speed 3) (space 3) (safety 2) - (debug 2) (compilation-speed 3))) + (debug 2) (compilation-speed 3))) (catch 'ct5 - (unwind-protect - (labels ((%f15 (f15-1 f15-2 f15-3) + (unwind-protect + (labels ((%f15 (f15-1 f15-2 f15-3) (rational (throw 'ct5 0)))) - (%f15 0 - (apply #'%f15 - 0 - h - (progn - (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b) - 0) - nil) - 0)) - (common-lisp:handler-case 0))))) + (%f15 0 + (apply #'%f15 + 0 + h + (progn + (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b) + 0) + nil) + 0)) + (common-lisp:handler-case 0))))) 1 2 3)) '(0))) @@ -1332,10 +1332,10 @@ (handler-case (compile nil '(lambda (x) - (declare (type (integer -100 100) x)) - (declare (optimize speed)) - (declare (notinline identity)) - (1+ (identity x)))) + (declare (type (integer -100 100) x)) + (declare (optimize speed)) + (declare (notinline identity)) + (1+ (identity x)))) (compiler-note () (error "IDENTITY derive-type not applied."))) (assert (null (funcall (compile nil '(lambda (x) (funcall #'cddr x))) nil))) @@ -1375,17 +1375,17 @@ ;;; efficiency notes for ordinary code (macrolet ((frob (arglist &body body) - `(progn - (handler-case - (compile nil '(lambda ,arglist ,@body)) - (sb-ext:compiler-note (e) - (error "bad compiler note for ~S:~% ~A" ',body e))) - (catch :got-note - (handler-case - (compile nil '(lambda ,arglist (declare (optimize speed)) - ,@body)) - (sb-ext:compiler-note (e) (throw :got-note nil))) - (error "missing compiler note for ~S" ',body))))) + `(progn + (handler-case + (compile nil '(lambda ,arglist ,@body)) + (sb-ext:compiler-note (e) + (error "bad compiler note for ~S:~% ~A" ',body e))) + (catch :got-note + (handler-case + (compile nil '(lambda ,arglist (declare (optimize speed)) + ,@body)) + (sb-ext:compiler-note (e) (throw :got-note nil))) + (error "missing compiler note for ~S" ',body))))) (frob (x) (funcall x)) (frob (x y) (find x y)) (frob (x y) (find-if x y)) @@ -1396,16 +1396,16 @@ (frob (x) (aref x 0))) (macrolet ((frob (style-warn-p form) - (if style-warn-p - `(catch :got-style-warning - (handler-case - (eval ',form) - (style-warning (e) (throw :got-style-warning nil))) - (error "missing style-warning for ~S" ',form)) - `(handler-case - (eval ',form) - (style-warning (e) - (error "bad style-warning for ~S: ~A" ',form e)))))) + (if style-warn-p + `(catch :got-style-warning + (handler-case + (eval ',form) + (style-warning (e) (throw :got-style-warning nil))) + (error "missing style-warning for ~S" ',form)) + `(handler-case + (eval ',form) + (style-warning (e) + (error "bad style-warning for ~S: ~A" ',form e)))))) (frob t (lambda (x &optional y &key z) (list x y z))) (frob nil (lambda (x &optional y z) (list x y z))) (frob nil (lambda (x &key y z) (list x y z))) @@ -1419,27 +1419,27 @@ ;;; from LOGXOR was small and negative, though the bottom one worked. (handler-bind ((sb-ext:compiler-note #'error)) (compile nil '(lambda () - (declare (optimize speed (safety 0))) - (lambda (x y) - (declare (type (integer 3 6) x) - (type (integer -6 -3) y)) - (+ (logxor x y) most-positive-fixnum))))) + (declare (optimize speed (safety 0))) + (lambda (x y) + (declare (type (integer 3 6) x) + (type (integer -6 -3) y)) + (+ (logxor x y) most-positive-fixnum))))) (handler-bind ((sb-ext:compiler-note #'error)) (compile nil '(lambda () - (declare (optimize speed (safety 0))) - (lambda (x y) - (declare (type (integer 3 6) y) - (type (integer -6 -3) x)) - (+ (logxor x y) most-positive-fixnum))))) + (declare (optimize speed (safety 0))) + (lambda (x y) + (declare (type (integer 3 6) y) + (type (integer -6 -3) x)) + (+ (logxor x y) most-positive-fixnum))))) ;;; check that modular ash gives the right answer, to protect against ;;; possible misunderstandings about the hardware shift instruction. (assert (zerop (funcall - (compile nil '(lambda (x y) - (declare (optimize speed) - (type (unsigned-byte 32) x y)) - (logand #xffffffff (ash x y)))) - 1 257))) + (compile nil '(lambda (x y) + (declare (optimize speed) + (type (unsigned-byte 32) x y)) + (logand #xffffffff (ash x y)))) + 1 257))) ;;; code instrumenting problems (compile nil @@ -1505,22 +1505,22 @@ (declare (type (integer -4085 0) b)) (declare (ignorable a b)) (declare - (optimize (space 2) - (compilation-speed 0) - #+sbcl (sb-c:insert-step-conditions 0) - (debug 2) - (safety 0) - (speed 3))) + (optimize (space 2) + (compilation-speed 0) + #+sbcl (sb-c:insert-step-conditions 0) + (debug 2) + (safety 0) + (speed 3))) (let ((*s5* 0)) - (dotimes (iv1 2 0) - (let ((*s5* - (elt '(1954479092053) - (min 0 - (max 0 - (if (< iv1 iv1) - (lognand iv1 (ash iv1 (min 53 iv1))) - iv1)))))) - 0))))) + (dotimes (iv1 2 0) + (let ((*s5* + (elt '(1954479092053) + (min 0 + (max 0 + (if (< iv1 iv1) + (lognand iv1 (ash iv1 (min 53 iv1))) + iv1)))))) + 0))))) -7639589303599 -1368))) (compile @@ -1544,15 +1544,15 @@ '(lambda (a b c d) (declare (notinline aref logandc2 gcd make-array)) (declare - (optimize (space 0) (safety 0) (compilation-speed 3) - (speed 3) (debug 1))) + (optimize (space 0) (safety 0) (compilation-speed 3) + (speed 3) (debug 1))) (progn - (tagbody - (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2))))) - (declare (dynamic-extent v2)) - (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2)))) - tag2) - 0))) + (tagbody + (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2))))) + (declare (dynamic-extent v2)) + (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2)))) + tag2) + 0))) 3021871717588 -866608 -2 -17194))) ;;; MISC.436, 438: lost reoptimization @@ -1564,39 +1564,39 @@ (declare (type (integer 0 160159) b)) (declare (ignorable a b)) (declare - (optimize (compilation-speed 1) - (speed 3) - (safety 3) - (space 0) - ; #+sbcl (sb-c:insert-step-conditions 0) - (debug 0))) + (optimize (compilation-speed 1) + (speed 3) + (safety 3) + (space 0) + ; #+sbcl (sb-c:insert-step-conditions 0) + (debug 0))) (if - (oddp - (loop for - lv1 - below - 2 - count - (logbitp 0 - (1- - (ash b - (min 8 - (count 0 - '(-10197561 486 430631291 - 9674068)))))))) - b - 0))) + (oddp + (loop for + lv1 + below + 2 + count + (logbitp 0 + (1- + (ash b + (min 8 + (count 0 + '(-10197561 486 430631291 + 9674068)))))))) + b + 0))) 1265797 110757))) (assert (zerop (funcall (compile nil ' (lambda (a) - (declare (type (integer 0 1696) a)) - ; (declare (ignorable a)) - (declare (optimize (space 2) (debug 0) (safety 1) - (compilation-speed 0) (speed 1))) - (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0))) + (declare (type (integer 0 1696) a)) + ; (declare (ignorable a)) + (declare (optimize (space 2) (debug 0) (safety 1) + (compilation-speed 0) (speed 1))) + (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0))) 805))) ;;; bug #302 @@ -1698,29 +1698,29 @@ (assert (every #'= array1 array2))))))) (let ((fn (compile nil '(lambda (x) - (declare (type bit x)) - (declare (optimize speed)) - (let ((b (make-array 64 :element-type 'bit - :initial-element 0))) - (count x b)))))) + (declare (type bit x)) + (declare (optimize speed)) + (let ((b (make-array 64 :element-type 'bit + :initial-element 0))) + (count x b)))))) (assert (= (funcall fn 0) 64)) (assert (= (funcall fn 1) 0))) (let ((fn (compile nil '(lambda (x y) - (declare (type simple-bit-vector x y)) - (declare (optimize speed)) - (equal x y))))) - (assert (funcall - fn - (make-array 64 :element-type 'bit :initial-element 0) - (make-array 64 :element-type 'bit :initial-element 0))) - (assert (not - (funcall - fn - (make-array 64 :element-type 'bit :initial-element 0) - (let ((b (make-array 64 :element-type 'bit :initial-element 0))) - (setf (sbit b 63) 1) - b))))) + (declare (type simple-bit-vector x y)) + (declare (optimize speed)) + (equal x y))))) + (assert (funcall + fn + (make-array 64 :element-type 'bit :initial-element 0) + (make-array 64 :element-type 'bit :initial-element 0))) + (assert (not + (funcall + fn + (make-array 64 :element-type 'bit :initial-element 0) + (let ((b (make-array 64 :element-type 'bit :initial-element 0))) + (setf (sbit b 63) 1) + b))))) ;;; MISC.535: compiler failure (let ((c0 #c(4196.088977268509d0 -15943.3603515625d0))) @@ -1728,22 +1728,22 @@ (compile nil `(lambda (p1 p2) - (declare (optimize speed (safety 1)) - (type (eql ,c0) p1) - (type number p2)) - (eql (the (complex double-float) p1) p2))) + (declare (optimize speed (safety 1)) + (type (eql ,c0) p1) + (type number p2)) + (eql (the (complex double-float) p1) p2))) c0 #c(12 612/979))))) ;;; reported by Lutz Euler: we shouldn't signal a compiler note for ;;; simple-bit-vector functions. (handler-bind ((sb-ext:compiler-note #'error)) (compile nil '(lambda (x) - (declare (type simple-bit-vector x)) - (count 1 x)))) + (declare (type simple-bit-vector x)) + (count 1 x)))) (handler-bind ((sb-ext:compiler-note #'error)) (compile nil '(lambda (x y) - (declare (type simple-bit-vector x y)) - (equal x y)))) + (declare (type simple-bit-vector x y)) + (equal x y)))) ;;; MISC.550: CAST merging in IR1 finalization caused unexpected ;;; code transformations. @@ -1772,13 +1772,13 @@ ;;; Free special bindings only apply to the body of the binding form, not ;;; the initialization forms. (assert (eq :good - (funcall (compile 'nil - (lambda () - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - ((lambda (&optional (y x)) - (declare (special x)) y))))))))) + (funcall (compile 'nil + (lambda () + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + ((lambda (&optional (y x)) + (declare (special x)) y))))))))) ;;; Bug from pfdietz's random tester: the compiler knew that IMAGPART of ;;; a rational was zero, but didn't do the substitution, leading to a diff --git a/tests/compound-cons.impure.lisp b/tests/compound-cons.impure.lisp index 3a75ecd..04ed0e9 100644 --- a/tests/compound-cons.impure.lisp +++ b/tests/compound-cons.impure.lisp @@ -9,14 +9,14 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. (cl:in-package :cl-user) -;;; This block of eight assertions is taken directly from +;;; This block of eight assertions is taken directly from ;;; 'Issue CONS-TYPE-SPECIFIER Writeup' in the ANSI spec. (assert (typep '(a b c) '(cons t))) (assert (typep '(a b c) '(cons symbol))) diff --git a/tests/condition.impure.lisp b/tests/condition.impure.lisp index b454b4b..a8103a9 100644 --- a/tests/condition.impure.lisp +++ b/tests/condition.impure.lisp @@ -44,7 +44,7 @@ (defmethod frob-counted-condition ((x counted-condition)) x) (assert (= 0 *condition-count*)) (assert (typep (sb-mop:class-prototype (find-class 'counted-condition)) - '(and condition counted-condition))) + '(and condition counted-condition))) ;;; success (sb-ext:quit :unix-status 104) diff --git a/tests/condition.pure.lisp b/tests/condition.pure.lisp index cddc4be..2ed2786 100644 --- a/tests/condition.pure.lisp +++ b/tests/condition.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -18,8 +18,8 @@ ;;; referred to unbound slots. This was reported and fixed by Antonio ;;; Martinez (sbcl-devel 2002-09-10). (format t - "~&printable now: ~A~%" - (make-condition 'file-error :pathname "foo")) + "~&printable now: ~A~%" + (make-condition 'file-error :pathname "foo")) (assert (eq (block nil @@ -104,7 +104,7 @@ ;;; clauses in HANDLER-CASE are allowed to have declarations (and ;;; indeed, only declarations) -(assert +(assert (null (handler-case (error "foo") (error () (declare (optimize speed)))))) (handler-case @@ -119,7 +119,7 @@ (funcall (lambda (x) (check-type x fixnum) x) t) (type-error (c) (assert (and (subtypep (type-error-expected-type c) 'fixnum) - (subtypep 'fixnum (type-error-expected-type c)))) + (subtypep 'fixnum (type-error-expected-type c)))) (assert (eq (type-error-datum c) t))) (:no-error (&rest rest) (error "no error: ~S" rest))) @@ -127,13 +127,13 @@ ;;; designators for a condition. Reported by Bruno Haible on cmucl-imp ;;; 2004-10-12. (flet ((test (&rest args) - (multiple-value-bind (res err) + (multiple-value-bind (res err) (ignore-errors (apply #'error args)) (assert (not res)) (assert (typep err 'type-error)) - (assert (not (nth-value 1 (ignore-errors + (assert (not (nth-value 1 (ignore-errors (type-error-datum err))))) - (assert (not (nth-value 1 (ignore-errors + (assert (not (nth-value 1 (ignore-errors (type-error-expected-type err)))))))) (test '#:no-such-condition) (test nil) diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index db05cc3..3a1397a 100644 --- a/tests/debug.impure.lisp +++ b/tests/debug.impure.lisp @@ -1,5 +1,5 @@ ;;;; This file is for testing debugging functionality, using -;;;; test machinery which might have side effects (e.g. +;;;; test machinery which might have side effects (e.g. ;;;; executing DEFUN). ;;;; This software is part of the SBCL system. See the README file for @@ -8,7 +8,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -29,7 +29,7 @@ (#.sb-vm:simple-fun-header-widetag (sb-kernel:%simple-fun-arglist fun)) (#.sb-vm:closure-header-widetag (get-arglist - (sb-kernel:%closure-fun fun))) + (sb-kernel:%closure-fun fun))) ;; In code/describe.lisp, ll. 227 (%describe-fun), we use a scheme ;; like above, and it seems to work. -- MNA 2001-06-12 ;; @@ -87,30 +87,30 @@ (sb-debug:backtrace-as-list) :key #'car :test #'equal)))) - + (setf result condition) - + (unless backtrace (print :missing-backtrace) (setf result nil)) - + ;; check that we have all the frames we wanted - (mapcar + (mapcar (lambda (spec frame) (unless (or (not spec) (and (equal (car spec) (car frame)) - (args-equal (cdr spec) + (args-equal (cdr spec) (cdr frame)))) (print (list :mismatch spec frame)) (setf result nil))) frame-specs backtrace) - + ;; Make sure the backtrace isn't stunted in ;; any way. (Depends on running in the main ;; thread.) (let ((end (last backtrace 2))) - (unless (equal (caar end) + (unless (equal (caar end) (if *show-entry-point-details* '(sb-c::tl-xep sb-impl::toplevel-init) 'sb-impl::toplevel-init)) @@ -144,11 +144,11 @@ (lambda () (test #'optimized)) (list *undefined-function-frame* (list '(flet test) #'optimized)))) - + ;; bug 353: This test fails at least most of the time for x86/linux ;; ca. 0.8.20.16. -- WHN #-(and x86 linux) - (assert (verify-backtrace + (assert (verify-backtrace (lambda () (test #'not-optimized)) (list *undefined-function-frame* (list '(flet not-optimized)) @@ -177,7 +177,7 @@ (declare (optimize (speed 1) (debug 2))) ; no tail call elimination (funcall fun))) (assert (verify-backtrace (lambda () (test #'optimized)) - (list '(/ 42 &rest) + (list '(/ 42 &rest) (list '(flet test) #'optimized)))) (assert (verify-backtrace (lambda () (test #'not-optimized)) (list '(/ 42 &rest) @@ -198,14 +198,14 @@ (defmacro defbt (n ll &body body) `(progn ;; normal debug info - (defun ,(intern (format nil "BT.~A.1" n)) ,ll + (defun ,(intern (format nil "BT.~A.1" n)) ,ll ,@body) ;; no arguments saved - (defun ,(intern (format nil "BT.~A.2" n)) ,ll + (defun ,(intern (format nil "BT.~A.2" n)) ,ll (declare (optimize (debug 1) (speed 3))) ,@body) ;; no lambda-list saved - (defun ,(intern (format nil "BT.~A.3" n)) ,ll + (defun ,(intern (format nil "BT.~A.3" n)) ,ll (declare (optimize (debug 0))) ,@body))) @@ -330,18 +330,18 @@ 'ok) (let ((out (with-output-to-string (*trace-output*) - (trace trace-this) - (assert (eq 'ok (trace-this))) - (untrace)))) + (trace trace-this) + (assert (eq 'ok (trace-this))) + (untrace)))) (assert (search "TRACE-THIS" out)) (assert (search "returned OK" out))) #-(and ppc darwin) ;;; bug 379 (let ((out (with-output-to-string (*trace-output*) - (trace trace-this :encapsulate nil) - (assert (eq 'ok (trace-this))) - (untrace)))) + (trace trace-this :encapsulate nil) + (assert (eq 'ok (trace-this))) + (untrace)))) (assert (search "TRACE-THIS" out)) (assert (search "returned OK" out))) diff --git a/tests/define-compiler-macro.impure.lisp b/tests/define-compiler-macro.impure.lisp index 50c4fe2..27527d0 100644 --- a/tests/define-compiler-macro.impure.lisp +++ b/tests/define-compiler-macro.impure.lisp @@ -8,15 +8,15 @@ (if (atom arg) `(expt ,arg 2) (case (car arg) - (square (if (= (length arg) 2) - `(expt ,(nth 1 arg) 4) - form)) - (expt (if (= (length arg) 3) - (if (numberp (nth 2 arg)) - `(expt ,(nth 1 arg) ,(* 2 (nth 2 arg))) + (square (if (= (length arg) 2) + `(expt ,(nth 1 arg) 4) + form)) + (expt (if (= (length arg) 3) + (if (numberp (nth 2 arg)) + `(expt ,(nth 1 arg) ,(* 2 (nth 2 arg))) `(expt ,(nth 1 arg) (* 2 ,(nth 2 arg)))) - form)) - (otherwise `(expt ,arg 2))))) + form)) + (otherwise `(expt ,arg 2))))) (assert (eql 81 (square (square 3)))) @@ -25,18 +25,18 @@ (assert (not expanded-p))) (assert (equal '(expt x 2) - (funcall (compiler-macro-function 'square) - '(square x) - nil))) + (funcall (compiler-macro-function 'square) + '(square x) + nil))) (assert (equal '(expt x 4) - (funcall (compiler-macro-function 'square) - '(square (square x)) - nil))) + (funcall (compiler-macro-function 'square) + '(square (square x)) + nil))) (assert (equal '(expt x 2) - (funcall (compiler-macro-function 'square) - '(funcall #'square x) - nil))) + (funcall (compiler-macro-function 'square) + '(funcall #'square x) + nil))) (quit :unix-status 104) diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index 45ba8a1..abd655e 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -4,7 +4,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -21,7 +21,7 @@ (make-person :name "James") ; not an error, 007 not used (assert (raises-error? (make-person) type-error)) (assert (raises-error? (setf (person-name (make-person :name "Q")) 1) - type-error)) + type-error)) ;;; An &AUX variable in a boa-constructor without a default value ;;; means "do not initialize slot" and does not cause type error @@ -65,7 +65,7 @@ ;;; basic inheritance (defstruct (astronaut (:include person) - (:conc-name astro-)) + (:conc-name astro-)) helmet-size (favorite-beverage 'tang)) (let ((x (make-astronaut :name "Buzz" :helmet-size 17.5))) @@ -84,16 +84,16 @@ operand-1 operand-2) (defstruct (annotated-binop (:type list) - (:initial-offset 3) - (:include binop)) + (:initial-offset 3) + (:include binop)) commutative associative identity) (assert (equal (make-annotated-binop :operator '* - :operand-1 'x - :operand-2 5 - :commutative t - :associative t - :identity 1) - '(nil nil binop * x 5 nil nil nil t t 1))) + :operand-1 'x + :operand-2 5 + :commutative t + :associative t + :identity 1) + '(nil nil binop * x 5 nil nil nil t t 1))) ;;; effect of :NAMED on :TYPE (defstruct (named-binop (:type list) :named) @@ -114,7 +114,7 @@ area watertowers (firetrucks 1 :type fixnum) - population + population (elevation 5128 :read-only t)) (let ((town1 (make-town :area 0 :watertowers 0))) (assert (town-p town1)) @@ -126,24 +126,24 @@ (assert (eql (town-population town1) 99)) (let ((town2 (copy-town town1))) (dolist (slot-accessor-name '(town-area - town-watertowers - town-firetrucks - town-population - town-elevation)) + town-watertowers + town-firetrucks + town-population + town-elevation)) (assert (eql (funcall slot-accessor-name town1) - (funcall slot-accessor-name town2)))) + (funcall slot-accessor-name town2)))) (assert (not (fboundp '(setf town-elevation)))))) ; 'cause it's :READ-ONLY ;;; example 2 (defstruct (clown (:conc-name bozo-)) - (nose-color 'red) + (nose-color 'red) frizzy-hair-p polkadots) (let ((funny-clown (make-clown))) (assert (eql (bozo-nose-color funny-clown) 'red))) (defstruct (klown (:constructor make-up-klown) - (:copier clone-klown) - (:predicate is-a-bozo-p)) + (:copier clone-klown) + (:predicate is-a-bozo-p)) nose-color frizzy-hair-p polkadots) @@ -167,7 +167,7 @@ (defun string+ (&rest rest) (apply #'concatenate 'string - (mapcar #'string rest))) + (mapcar #'string rest))) (defun symbol+ (&rest rest) (values (intern (apply #'string+ rest)))) @@ -180,28 +180,28 @@ (funcall (accessor-name conc-name slot-name) instance)) (defun write-slot-notinline (new-value conc-name slot-name instance) (funcall (fdefinition `(setf ,(accessor-name conc-name slot-name))) - new-value instance)) + new-value instance)) ;;; Use inline expansions of slot accessors, if possible, to read and ;;; write a structure slot. (defun read-slot-inline (conc-name slot-name instance) (funcall (compile nil - `(lambda (instance) - (,(accessor-name conc-name slot-name) instance))) - instance)) + `(lambda (instance) + (,(accessor-name conc-name slot-name) instance))) + instance)) (defun write-slot-inline (new-value conc-name slot-name instance) (funcall (compile nil - `(lambda (new-value instance) - (setf (,(accessor-name conc-name slot-name) instance) - new-value))) - new-value - instance)) + `(lambda (new-value instance) + (setf (,(accessor-name conc-name slot-name) instance) + new-value))) + new-value + instance)) ;;; Read a structure slot, checking that the inline and out-of-line ;;; accessors give the same result. (defun read-slot (conc-name slot-name instance) (let ((inline-value (read-slot-inline conc-name slot-name instance)) - (notinline-value (read-slot-notinline conc-name slot-name instance))) + (notinline-value (read-slot-notinline conc-name slot-name instance))) (assert (eql inline-value notinline-value)) inline-value)) @@ -215,19 +215,19 @@ ;;; bound during the tests so that we can get to it even if the ;;; debugger is having a bad day (defvar *instance*) - + (defmacro test-variant (defstructname &key colontype boa-constructor-p) `(progn (format t "~&/beginning PROGN for COLONTYPE=~S~%" ',colontype) (defstruct (,defstructname - ,@(when colontype `((:type ,colontype))) + ,@(when colontype `((:type ,colontype))) ,@(when boa-constructor-p `((:constructor ,(symbol+ "CREATE-" defstructname) (id - &optional - (optional-test 2 optional-test-p) + &optional + (optional-test 2 optional-test-p) &key (home nil home-p) (no-home-comment "Home package CL not provided.") @@ -235,7 +235,7 @@ (refcount (if optional-test-p optional-test nil)) hash weight))))) - + ;; some ordinary tagged slots id (home nil :type package :read-only t) @@ -249,28 +249,28 @@ (format t "~&/done with DEFSTRUCT~%") (let* ((cn (string+ ',defstructname "-")) ; conc-name - (ctor (symbol-function ',(symbol+ (if boa-constructor-p + (ctor (symbol-function ',(symbol+ (if boa-constructor-p "CREATE-" "MAKE-") defstructname))) - (*instance* (funcall ctor - ,@(unless boa-constructor-p + (*instance* (funcall ctor + ,@(unless boa-constructor-p `(:id)) "some id" - ,@(when boa-constructor-p - '(1)) - :home (find-package :cl) - :hash (+ 14 most-positive-fixnum) - ,@(unless boa-constructor-p - `(:refcount 1))))) - - ;; Check that ctor set up slot values correctly. + ,@(when boa-constructor-p + '(1)) + :home (find-package :cl) + :hash (+ 14 most-positive-fixnum) + ,@(unless boa-constructor-p + `(:refcount 1))))) + + ;; Check that ctor set up slot values correctly. (format t "~&/checking constructed structure~%") (assert (string= "some id" (read-slot cn "ID" *instance*))) (assert (eql (find-package :cl) (read-slot cn "HOME" *instance*))) (assert (string= "" (read-slot cn "COMMENT" *instance*))) (assert (= 1.0 (read-slot cn "WEIGHT" *instance*))) (assert (eql (+ 14 most-positive-fixnum) - (read-slot cn "HASH" *instance*))) + (read-slot cn "HASH" *instance*))) (assert (= 1 (read-slot cn "REFCOUNT" *instance*))) ;; There should be no writers for read-only slots. @@ -280,55 +280,55 @@ ;; (Read-only slot values are checked in the loop below.) (dolist (inlinep '(t nil)) - (format t "~&/doing INLINEP=~S~%" inlinep) - ;; Fiddle with writable slot values. - (let ((new-id (format nil "~S" (random 100))) - (new-comment (format nil "~X" (random 5555))) - (new-weight (random 10.0))) - (write-slot new-id cn "ID" *instance* inlinep) - (write-slot new-comment cn "COMMENT" *instance* inlinep) - (write-slot new-weight cn "WEIGHT" *instance* inlinep) - (assert (eql new-id (read-slot cn "ID" *instance*))) - (assert (eql new-comment (read-slot cn "COMMENT" *instance*))) - ;;(unless (eql new-weight (read-slot cn "WEIGHT" *instance*)) - ;; (error "WEIGHT mismatch: ~S vs. ~S" - ;; new-weight (read-slot cn "WEIGHT" *instance*))) - (assert (eql new-weight (read-slot cn "WEIGHT" *instance*))))) + (format t "~&/doing INLINEP=~S~%" inlinep) + ;; Fiddle with writable slot values. + (let ((new-id (format nil "~S" (random 100))) + (new-comment (format nil "~X" (random 5555))) + (new-weight (random 10.0))) + (write-slot new-id cn "ID" *instance* inlinep) + (write-slot new-comment cn "COMMENT" *instance* inlinep) + (write-slot new-weight cn "WEIGHT" *instance* inlinep) + (assert (eql new-id (read-slot cn "ID" *instance*))) + (assert (eql new-comment (read-slot cn "COMMENT" *instance*))) + ;;(unless (eql new-weight (read-slot cn "WEIGHT" *instance*)) + ;; (error "WEIGHT mismatch: ~S vs. ~S" + ;; new-weight (read-slot cn "WEIGHT" *instance*))) + (assert (eql new-weight (read-slot cn "WEIGHT" *instance*))))) (format t "~&/done with INLINEP loop~%") ;; :TYPE FOO objects don't go in the Lisp type system, so we ;; can't test TYPEP stuff for them. ;; ;; FIXME: However, when they're named, they do define - ;; predicate functions, and we could test those. - ,@(unless colontype - `(;; Fiddle with predicate function. - (let ((pred-name (symbol+ ',defstructname "-P"))) - (format t "~&/doing tests on PRED-NAME=~S~%" pred-name) - (assert (funcall pred-name *instance*)) - (assert (not (funcall pred-name 14))) - (assert (not (funcall pred-name "test"))) - (assert (not (funcall pred-name (make-hash-table)))) - (let ((compiled-pred - (compile nil `(lambda (x) (,pred-name x))))) - (format t "~&/doing COMPILED-PRED tests~%") - (assert (funcall compiled-pred *instance*)) - (assert (not (funcall compiled-pred 14))) - (assert (not (funcall compiled-pred #())))) - ;; Fiddle with TYPEP. - (format t "~&/doing TYPEP tests, COLONTYPE=~S~%" ',colontype) - (assert (typep *instance* ',defstructname)) - (assert (not (typep 0 ',defstructname))) - (assert (funcall (symbol+ "TYPEP") *instance* ',defstructname)) - (assert (not (funcall (symbol+ "TYPEP") nil ',defstructname))) - (let* ((typename ',defstructname) - (compiled-typep - (compile nil `(lambda (x) (typep x ',typename))))) - (assert (funcall compiled-typep *instance*)) - (assert (not (funcall compiled-typep nil)))))))) - + ;; predicate functions, and we could test those. + ,@(unless colontype + `(;; Fiddle with predicate function. + (let ((pred-name (symbol+ ',defstructname "-P"))) + (format t "~&/doing tests on PRED-NAME=~S~%" pred-name) + (assert (funcall pred-name *instance*)) + (assert (not (funcall pred-name 14))) + (assert (not (funcall pred-name "test"))) + (assert (not (funcall pred-name (make-hash-table)))) + (let ((compiled-pred + (compile nil `(lambda (x) (,pred-name x))))) + (format t "~&/doing COMPILED-PRED tests~%") + (assert (funcall compiled-pred *instance*)) + (assert (not (funcall compiled-pred 14))) + (assert (not (funcall compiled-pred #())))) + ;; Fiddle with TYPEP. + (format t "~&/doing TYPEP tests, COLONTYPE=~S~%" ',colontype) + (assert (typep *instance* ',defstructname)) + (assert (not (typep 0 ',defstructname))) + (assert (funcall (symbol+ "TYPEP") *instance* ',defstructname)) + (assert (not (funcall (symbol+ "TYPEP") nil ',defstructname))) + (let* ((typename ',defstructname) + (compiled-typep + (compile nil `(lambda (x) (typep x ',typename))))) + (assert (funcall compiled-typep *instance*)) + (assert (not (funcall compiled-typep nil)))))))) + (format t "~&/done with PROGN for COLONTYPE=~S~%" ',colontype))) - + (test-variant vanilla-struct) (test-variant vector-struct :colontype vector) (test-variant list-struct :colontype list) @@ -407,24 +407,24 @@ for m in (reverse manyraws) for i from 0 do - ;; Compare the tagged reference values with raw reffer results. - (destructuring-bind (j a b c d e) - (manyraw-unraw-slot-just-for-variety m) - (assert (eql i j)) - (assert (= (manyraw-a m) a)) - (assert (= (manyraw-b m) b)) - (assert (= (manyraw-c m) c)) - (assert (= (manyraw-d m) d)) - (assert (= (manyraw-e m) e))) - ;; Test the funny out-of-line OAOOM-style closures, too. - (mapcar (lambda (fn value) - (assert (= (funcall fn m) value))) - (list #'manyraw-a - #'manyraw-b - #'manyraw-c - #'manyraw-d - #'manyraw-e) - (cdr (manyraw-unraw-slot-just-for-variety m))))) + ;; Compare the tagged reference values with raw reffer results. + (destructuring-bind (j a b c d e) + (manyraw-unraw-slot-just-for-variety m) + (assert (eql i j)) + (assert (= (manyraw-a m) a)) + (assert (= (manyraw-b m) b)) + (assert (= (manyraw-c m) c)) + (assert (= (manyraw-d m) d)) + (assert (= (manyraw-e m) e))) + ;; Test the funny out-of-line OAOOM-style closures, too. + (mapcar (lambda (fn value) + (assert (= (funcall fn m) value))) + (list #'manyraw-a + #'manyraw-b + #'manyraw-c + #'manyraw-d + #'manyraw-e) + (cdr (manyraw-unraw-slot-just-for-variety m))))) (defstruct (manyraw-subclass (:include manyraw)) (stolperstein 0 :type (unsigned-byte 32))) @@ -433,25 +433,25 @@ (dotimes (y +n-manyraw+) (dotimes (x +m-manyraw+) (let ((a (random (expt 2 32))) - (b (random most-positive-single-float)) - (c (random most-positive-double-float)) - (d (complex - (random most-positive-single-float) - (random most-positive-single-float))) - (e (complex - (random most-positive-double-float) - (random most-positive-double-float)))) + (b (random most-positive-single-float)) + (c (random most-positive-double-float)) + (d (complex + (random most-positive-single-float) + (random most-positive-single-float))) + (e (complex + (random most-positive-double-float) + (random most-positive-double-float)))) (push (funcall (if (zerop (mod x 3)) - #'make-manyraw-subclass - #'make-manyraw) - :unraw-slot-just-for-variety - (list (+ x (* y +m-manyraw+)) a b c d e) - :a a - :b b - :c c - :d d - :e e) - *manyraw*))) + #'make-manyraw-subclass + #'make-manyraw) + :unraw-slot-just-for-variety + (list (+ x (* y +m-manyraw+)) a b c d e) + :a a + :b b + :c c + :d d + :e e) + *manyraw*))) (room) (sb-ext:gc)) (check-manyraws *manyraw*) @@ -466,8 +466,8 @@ self env :sb-just-dump-it-normally) (with-open-file (s "tmp-defstruct.manyraw.lisp" - :direction :output - :if-exists :supersede) + :direction :output + :if-exists :supersede) (write-string "(defun dumped-manyraws () '#.*manyraw*)" s)) (compile-file "tmp-defstruct.manyraw.lisp") (delete-file "tmp-defstruct.manyraw.lisp") @@ -548,15 +548,15 @@ ;;; too fragile: (defstruct (conc-name-syntax :conc-name) a-conc-name-slot) (assert (eq (a-conc-name-slot (make-conc-name-syntax :a-conc-name-slot 'y)) - 'y)) + 'y)) ;;; and further :CONC-NAME NIL was being wrongly treated: (defpackage "DEFSTRUCT-TEST-SCRATCH") (defstruct (conc-name-nil :conc-name) defstruct-test-scratch::conc-name-nil-slot) (assert (= (defstruct-test-scratch::conc-name-nil-slot - (make-conc-name-nil :conc-name-nil-slot 1)) 1)) + (make-conc-name-nil :conc-name-nil-slot 1)) 1)) (assert (raises-error? (conc-name-nil-slot (make-conc-name-nil)) - undefined-function)) + undefined-function)) ;;; The named/typed predicates were a little fragile, in that they ;;; could throw errors on innocuous input: @@ -621,11 +621,11 @@ (assert (bug-332b-p '(1 2 3 4 5 x 1 2 bug-332b))) ;;; Similar test for vectors, just for good measure. -(defstruct (bug-332a-aux (:type vector) - (:initial-offset 5) :named)) -(defstruct (bug-332b-aux (:type vector) - (:initial-offset 2) :named - (:include bug-332a-aux))) +(defstruct (bug-332a-aux (:type vector) + (:initial-offset 5) :named)) +(defstruct (bug-332b-aux (:type vector) + (:initial-offset 2) :named + (:include bug-332a-aux))) (assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 premature-end)))) (assert (not (bug-332b-aux-p 873257))) (assert (not (bug-332b-aux-p #(1 2 3 4 5 x 1 2 bug-332a-aux)))) diff --git a/tests/deftype.impure.lisp b/tests/deftype.impure.lisp index b1eef79..e236981 100644 --- a/tests/deftype.impure.lisp +++ b/tests/deftype.impure.lisp @@ -4,7 +4,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. diff --git a/tests/dump.impure-cload.lisp b/tests/dump.impure-cload.lisp index d5854ce..e7cdf57 100644 --- a/tests/dump.impure-cload.lisp +++ b/tests/dump.impure-cload.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -41,7 +41,7 @@ ;; an extremely meaningless MAKE-LOAD-FORM method whose only point ;; is to exercise the mechanism a little bit (values `(make-foo :x (list ',(foo-x foo))) - `(setf (foo-y ,foo) ',foo)))) + `(setf (foo-y ,foo) ',foo)))) (defparameter *foo* #.(make-foo :x "X" :y "Y")) @@ -55,7 +55,7 @@ ;;; symbol involves dumping a reference to the name of its package). (eval-when (:compile-toplevel :load-toplevel :execute) (setf (logical-pathname-translations "MY-LOGICAL-HOST") - (list '("**;*.*.*" "/tmp/*.*")))) + (list '("**;*.*.*" "/tmp/*.*")))) (defparameter *path* #p"MY-LOGICAL-HOST:FOO;BAR.LISP") @@ -63,8 +63,8 @@ ;;; their complex attributes. (defparameter *string* #.(make-array 3 :initial-element #\a - :fill-pointer 2 - :element-type 'character)) + :fill-pointer 2 + :element-type 'character)) ;;; SBCL 0.7.8 incorrectly read high bits of (COMPLEX DOUBLE-FLOAT) ;;; components as unsigned bytes. diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index dc67efa..b8380dc 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -116,8 +116,8 @@ t) (defun-with-dx dxclosure (x) - (flet ((f (y) - (+ y x))) + (flet ((f (y) + (+ y x))) (declare (dynamic-extent #'f)) (true #'f))) diff --git a/tests/eucjp-test.lisp-expr b/tests/eucjp-test.lisp-expr index 3f6875e..3e40d6e 100644 --- a/tests/eucjp-test.lisp-expr +++ b/tests/eucjp-test.lisp-expr @@ -1,13104 +1,13104 @@ -#x20 #x0020 -#x21 #x0021 -#x22 #x0022 -#x23 #x0023 -#x24 #x0024 -#x25 #x0025 -#x26 #x0026 -#x27 #x0027 -#x28 #x0028 -#x29 #x0029 -#x2A #x002A -#x2B #x002B -#x2C #x002C -#x2D #x002D -#x2E #x002E -#x2F #x002F -#x30 #x0030 -#x31 #x0031 -#x32 #x0032 -#x33 #x0033 -#x34 #x0034 -#x35 #x0035 -#x36 #x0036 -#x37 #x0037 -#x38 #x0038 -#x39 #x0039 -#x3A #x003A -#x3B #x003B -#x3C #x003C -#x3D #x003D -#x3E #x003E -#x3F #x003F -#x40 #x0040 -#x41 #x0041 -#x42 #x0042 -#x43 #x0043 -#x44 #x0044 -#x45 #x0045 -#x46 #x0046 -#x47 #x0047 -#x48 #x0048 -#x49 #x0049 -#x4A #x004A -#x4B #x004B -#x4C #x004C -#x4D #x004D -#x4E #x004E -#x4F #x004F -#x50 #x0050 -#x51 #x0051 -#x52 #x0052 -#x53 #x0053 -#x54 #x0054 -#x55 #x0055 -#x56 #x0056 -#x57 #x0057 -#x58 #x0058 -#x59 #x0059 -#x5A #x005A -#x5B #x005B -#x5C #x005C -#x5D #x005D -#x5E #x005E -#x5F #x005F -#x60 #x0060 -#x61 #x0061 -#x62 #x0062 -#x63 #x0063 -#x64 #x0064 -#x65 #x0065 -#x66 #x0066 -#x67 #x0067 -#x68 #x0068 -#x69 #x0069 -#x6A #x006A -#x6B #x006B -#x6C #x006C -#x6D #x006D -#x6E #x006E -#x6F #x006F -#x70 #x0070 -#x71 #x0071 -#x72 #x0072 -#x73 #x0073 -#x74 #x0074 -#x75 #x0075 -#x76 #x0076 -#x77 #x0077 -#x78 #x0078 -#x79 #x0079 -#x7A #x007A -#x7B #x007B -#x7C #x007C -#x7D #x007D -#x7E #x007E -#x8EA1 #xFF61 -#x8EA2 #xFF62 -#x8EA3 #xFF63 -#x8EA4 #xFF64 -#x8EA5 #xFF65 -#x8EA6 #xFF66 -#x8EA7 #xFF67 -#x8EA8 #xFF68 -#x8EA9 #xFF69 -#x8EAA #xFF6A -#x8EAB #xFF6B -#x8EAC #xFF6C -#x8EAD #xFF6D -#x8EAE #xFF6E -#x8EAF #xFF6F -#x8EB0 #xFF70 -#x8EB1 #xFF71 -#x8EB2 #xFF72 -#x8EB3 #xFF73 -#x8EB4 #xFF74 -#x8EB5 #xFF75 -#x8EB6 #xFF76 -#x8EB7 #xFF77 -#x8EB8 #xFF78 -#x8EB9 #xFF79 -#x8EBA #xFF7A -#x8EBB #xFF7B -#x8EBC #xFF7C -#x8EBD #xFF7D -#x8EBE #xFF7E -#x8EBF #xFF7F -#x8EC0 #xFF80 -#x8EC1 #xFF81 -#x8EC2 #xFF82 -#x8EC3 #xFF83 -#x8EC4 #xFF84 -#x8EC5 #xFF85 -#x8EC6 #xFF86 -#x8EC7 #xFF87 -#x8EC8 #xFF88 -#x8EC9 #xFF89 -#x8ECA #xFF8A -#x8ECB #xFF8B -#x8ECC #xFF8C -#x8ECD #xFF8D -#x8ECE #xFF8E -#x8ECF #xFF8F -#x8ED0 #xFF90 -#x8ED1 #xFF91 -#x8ED2 #xFF92 -#x8ED3 #xFF93 -#x8ED4 #xFF94 -#x8ED5 #xFF95 -#x8ED6 #xFF96 -#x8ED7 #xFF97 -#x8ED8 #xFF98 -#x8ED9 #xFF99 -#x8EDA #xFF9A -#x8EDB #xFF9B -#x8EDC #xFF9C -#x8EDD #xFF9D -#x8EDE #xFF9E -#x8EDF #xFF9F -#xA1A1 #x3000 -#xA1A2 #x3001 -#xA1A3 #x3002 -#xA1A4 #xFF0C -#xA1A5 #xFF0E -#xA1A6 #x30FB -#xA1A7 #xFF1A -#xA1A8 #xFF1B -#xA1A9 #xFF1F -#xA1AA #xFF01 -#xA1AB #x309B -#xA1AC #x309C -#xA1AD #x00B4 -#xA1AE #xFF40 -#xA1AF #x00A8 -#xA1B0 #xFF3E -#xA1B1 #x203E -#xA1B2 #xFF3F -#xA1B3 #x30FD -#xA1B4 #x30FE -#xA1B5 #x309D -#xA1B6 #x309E -#xA1B7 #x3003 -#xA1B8 #x4EDD -#xA1B9 #x3005 -#xA1BA #x3006 -#xA1BB #x3007 -#xA1BC #x30FC -#xA1BD #x2014 -#xA1BE #x2010 -#xA1BF #xFF0F -#xA1C0 #xFF3C -#xA1C1 #x301C -#xA1C2 #x2016 -#xA1C3 #xFF5C -#xA1C4 #x2026 -#xA1C5 #x2025 -#xA1C6 #x2018 -#xA1C7 #x2019 -#xA1C8 #x201C -#xA1C9 #x201D -#xA1CA #xFF08 -#xA1CB #xFF09 -#xA1CC #x3014 -#xA1CD #x3015 -#xA1CE #xFF3B -#xA1CF #xFF3D -#xA1D0 #xFF5B -#xA1D1 #xFF5D -#xA1D2 #x3008 -#xA1D3 #x3009 -#xA1D4 #x300A -#xA1D5 #x300B -#xA1D6 #x300C -#xA1D7 #x300D -#xA1D8 #x300E -#xA1D9 #x300F -#xA1DA #x3010 -#xA1DB #x3011 -#xA1DC #xFF0B -#xA1DD #x2212 -#xA1DE #x00B1 -#xA1DF #x00D7 -#xA1E0 #x00F7 -#xA1E1 #xFF1D -#xA1E2 #x2260 -#xA1E3 #xFF1C -#xA1E4 #xFF1E -#xA1E5 #x2266 -#xA1E6 #x2267 -#xA1E7 #x221E -#xA1E8 #x2234 -#xA1E9 #x2642 -#xA1EA #x2640 -#xA1EB #x00B0 -#xA1EC #x2032 -#xA1ED #x2033 -#xA1EE #x2103 -#xA1EF #x00A5 -#xA1F0 #xFF04 -#xA1F1 #x00A2 -#xA1F2 #x00A3 -#xA1F3 #xFF05 -#xA1F4 #xFF03 -#xA1F5 #xFF06 -#xA1F6 #xFF0A -#xA1F7 #xFF20 -#xA1F8 #x00A7 -#xA1F9 #x2606 -#xA1FA #x2605 -#xA1FB #x25CB -#xA1FC #x25CF -#xA1FD #x25CE -#xA1FE #x25C7 -#xA2A1 #x25C6 -#xA2A2 #x25A1 -#xA2A3 #x25A0 -#xA2A4 #x25B3 -#xA2A5 #x25B2 -#xA2A6 #x25BD -#xA2A7 #x25BC -#xA2A8 #x203B -#xA2A9 #x3012 -#xA2AA #x2192 -#xA2AB #x2190 -#xA2AC #x2191 -#xA2AD #x2193 -#xA2AE #x3013 -#xA2BA #x2208 -#xA2BB #x220B -#xA2BC #x2286 -#xA2BD #x2287 -#xA2BE #x2282 -#xA2BF #x2283 -#xA2C0 #x222A -#xA2C1 #x2229 -#xA2CA #x2227 -#xA2CB #x2228 -#xA2CC #x00AC -#xA2CD #x21D2 -#xA2CE #x21D4 -#xA2CF #x2200 -#xA2D0 #x2203 -#xA2DC #x2220 -#xA2DD #x22A5 -#xA2DE #x2312 -#xA2DF #x2202 -#xA2E0 #x2207 -#xA2E1 #x2261 -#xA2E2 #x2252 -#xA2E3 #x226A -#xA2E4 #x226B -#xA2E5 #x221A -#xA2E6 #x223D -#xA2E7 #x221D -#xA2E8 #x2235 -#xA2E9 #x222B -#xA2EA #x222C -#xA2F2 #x212B -#xA2F3 #x2030 -#xA2F4 #x266F -#xA2F5 #x266D -#xA2F6 #x266A -#xA2F7 #x2020 -#xA2F8 #x2021 -#xA2F9 #x00B6 -#xA2FE #x25EF -#xA3B0 #xFF10 -#xA3B1 #xFF11 -#xA3B2 #xFF12 -#xA3B3 #xFF13 -#xA3B4 #xFF14 -#xA3B5 #xFF15 -#xA3B6 #xFF16 -#xA3B7 #xFF17 -#xA3B8 #xFF18 -#xA3B9 #xFF19 -#xA3C1 #xFF21 -#xA3C2 #xFF22 -#xA3C3 #xFF23 -#xA3C4 #xFF24 -#xA3C5 #xFF25 -#xA3C6 #xFF26 -#xA3C7 #xFF27 -#xA3C8 #xFF28 -#xA3C9 #xFF29 -#xA3CA #xFF2A -#xA3CB #xFF2B -#xA3CC #xFF2C -#xA3CD #xFF2D -#xA3CE #xFF2E -#xA3CF #xFF2F -#xA3D0 #xFF30 -#xA3D1 #xFF31 -#xA3D2 #xFF32 -#xA3D3 #xFF33 -#xA3D4 #xFF34 -#xA3D5 #xFF35 -#xA3D6 #xFF36 -#xA3D7 #xFF37 -#xA3D8 #xFF38 -#xA3D9 #xFF39 -#xA3DA #xFF3A -#xA3E1 #xFF41 -#xA3E2 #xFF42 -#xA3E3 #xFF43 -#xA3E4 #xFF44 -#xA3E5 #xFF45 -#xA3E6 #xFF46 -#xA3E7 #xFF47 -#xA3E8 #xFF48 -#xA3E9 #xFF49 -#xA3EA #xFF4A -#xA3EB #xFF4B -#xA3EC #xFF4C -#xA3ED #xFF4D -#xA3EE #xFF4E -#xA3EF #xFF4F -#xA3F0 #xFF50 -#xA3F1 #xFF51 -#xA3F2 #xFF52 -#xA3F3 #xFF53 -#xA3F4 #xFF54 -#xA3F5 #xFF55 -#xA3F6 #xFF56 -#xA3F7 #xFF57 -#xA3F8 #xFF58 -#xA3F9 #xFF59 -#xA3FA #xFF5A -#xA4A1 #x3041 -#xA4A2 #x3042 -#xA4A3 #x3043 -#xA4A4 #x3044 -#xA4A5 #x3045 -#xA4A6 #x3046 -#xA4A7 #x3047 -#xA4A8 #x3048 -#xA4A9 #x3049 -#xA4AA #x304A -#xA4AB #x304B -#xA4AC #x304C -#xA4AD #x304D -#xA4AE #x304E -#xA4AF #x304F -#xA4B0 #x3050 -#xA4B1 #x3051 -#xA4B2 #x3052 -#xA4B3 #x3053 -#xA4B4 #x3054 -#xA4B5 #x3055 -#xA4B6 #x3056 -#xA4B7 #x3057 -#xA4B8 #x3058 -#xA4B9 #x3059 -#xA4BA #x305A -#xA4BB #x305B -#xA4BC #x305C -#xA4BD #x305D -#xA4BE #x305E -#xA4BF #x305F -#xA4C0 #x3060 -#xA4C1 #x3061 -#xA4C2 #x3062 -#xA4C3 #x3063 -#xA4C4 #x3064 -#xA4C5 #x3065 -#xA4C6 #x3066 -#xA4C7 #x3067 -#xA4C8 #x3068 -#xA4C9 #x3069 -#xA4CA #x306A -#xA4CB #x306B -#xA4CC #x306C -#xA4CD #x306D -#xA4CE #x306E -#xA4CF #x306F -#xA4D0 #x3070 -#xA4D1 #x3071 -#xA4D2 #x3072 -#xA4D3 #x3073 -#xA4D4 #x3074 -#xA4D5 #x3075 -#xA4D6 #x3076 -#xA4D7 #x3077 -#xA4D8 #x3078 -#xA4D9 #x3079 -#xA4DA #x307A -#xA4DB #x307B -#xA4DC #x307C -#xA4DD #x307D -#xA4DE #x307E -#xA4DF #x307F -#xA4E0 #x3080 -#xA4E1 #x3081 -#xA4E2 #x3082 -#xA4E3 #x3083 -#xA4E4 #x3084 -#xA4E5 #x3085 -#xA4E6 #x3086 -#xA4E7 #x3087 -#xA4E8 #x3088 -#xA4E9 #x3089 -#xA4EA #x308A -#xA4EB #x308B -#xA4EC #x308C -#xA4ED #x308D -#xA4EE #x308E -#xA4EF #x308F -#xA4F0 #x3090 -#xA4F1 #x3091 -#xA4F2 #x3092 -#xA4F3 #x3093 -#xA5A1 #x30A1 -#xA5A2 #x30A2 -#xA5A3 #x30A3 -#xA5A4 #x30A4 -#xA5A5 #x30A5 -#xA5A6 #x30A6 -#xA5A7 #x30A7 -#xA5A8 #x30A8 -#xA5A9 #x30A9 -#xA5AA #x30AA -#xA5AB #x30AB -#xA5AC #x30AC -#xA5AD #x30AD -#xA5AE #x30AE -#xA5AF #x30AF -#xA5B0 #x30B0 -#xA5B1 #x30B1 -#xA5B2 #x30B2 -#xA5B3 #x30B3 -#xA5B4 #x30B4 -#xA5B5 #x30B5 -#xA5B6 #x30B6 -#xA5B7 #x30B7 -#xA5B8 #x30B8 -#xA5B9 #x30B9 -#xA5BA #x30BA -#xA5BB #x30BB -#xA5BC #x30BC -#xA5BD #x30BD -#xA5BE #x30BE -#xA5BF #x30BF -#xA5C0 #x30C0 -#xA5C1 #x30C1 -#xA5C2 #x30C2 -#xA5C3 #x30C3 -#xA5C4 #x30C4 -#xA5C5 #x30C5 -#xA5C6 #x30C6 -#xA5C7 #x30C7 -#xA5C8 #x30C8 -#xA5C9 #x30C9 -#xA5CA #x30CA -#xA5CB #x30CB -#xA5CC #x30CC -#xA5CD #x30CD -#xA5CE #x30CE -#xA5CF #x30CF -#xA5D0 #x30D0 -#xA5D1 #x30D1 -#xA5D2 #x30D2 -#xA5D3 #x30D3 -#xA5D4 #x30D4 -#xA5D5 #x30D5 -#xA5D6 #x30D6 -#xA5D7 #x30D7 -#xA5D8 #x30D8 -#xA5D9 #x30D9 -#xA5DA #x30DA -#xA5DB #x30DB -#xA5DC #x30DC -#xA5DD #x30DD -#xA5DE #x30DE -#xA5DF #x30DF -#xA5E0 #x30E0 -#xA5E1 #x30E1 -#xA5E2 #x30E2 -#xA5E3 #x30E3 -#xA5E4 #x30E4 -#xA5E5 #x30E5 -#xA5E6 #x30E6 -#xA5E7 #x30E7 -#xA5E8 #x30E8 -#xA5E9 #x30E9 -#xA5EA #x30EA -#xA5EB #x30EB -#xA5EC #x30EC -#xA5ED #x30ED -#xA5EE #x30EE -#xA5EF #x30EF -#xA5F0 #x30F0 -#xA5F1 #x30F1 -#xA5F2 #x30F2 -#xA5F3 #x30F3 -#xA5F4 #x30F4 -#xA5F5 #x30F5 -#xA5F6 #x30F6 -#xA6A1 #x0391 -#xA6A2 #x0392 -#xA6A3 #x0393 -#xA6A4 #x0394 -#xA6A5 #x0395 -#xA6A6 #x0396 -#xA6A7 #x0397 -#xA6A8 #x0398 -#xA6A9 #x0399 -#xA6AA #x039A -#xA6AB #x039B -#xA6AC #x039C -#xA6AD #x039D -#xA6AE #x039E -#xA6AF #x039F -#xA6B0 #x03A0 -#xA6B1 #x03A1 -#xA6B2 #x03A3 -#xA6B3 #x03A4 -#xA6B4 #x03A5 -#xA6B5 #x03A6 -#xA6B6 #x03A7 -#xA6B7 #x03A8 -#xA6B8 #x03A9 -#xA6C1 #x03B1 -#xA6C2 #x03B2 -#xA6C3 #x03B3 -#xA6C4 #x03B4 -#xA6C5 #x03B5 -#xA6C6 #x03B6 -#xA6C7 #x03B7 -#xA6C8 #x03B8 -#xA6C9 #x03B9 -#xA6CA #x03BA -#xA6CB #x03BB -#xA6CC #x03BC -#xA6CD #x03BD -#xA6CE #x03BE -#xA6CF #x03BF -#xA6D0 #x03C0 -#xA6D1 #x03C1 -#xA6D2 #x03C3 -#xA6D3 #x03C4 -#xA6D4 #x03C5 -#xA6D5 #x03C6 -#xA6D6 #x03C7 -#xA6D7 #x03C8 -#xA6D8 #x03C9 -#xA7A1 #x0410 -#xA7A2 #x0411 -#xA7A3 #x0412 -#xA7A4 #x0413 -#xA7A5 #x0414 -#xA7A6 #x0415 -#xA7A7 #x0401 -#xA7A8 #x0416 -#xA7A9 #x0417 -#xA7AA #x0418 -#xA7AB #x0419 -#xA7AC #x041A -#xA7AD #x041B -#xA7AE #x041C -#xA7AF #x041D -#xA7B0 #x041E -#xA7B1 #x041F -#xA7B2 #x0420 -#xA7B3 #x0421 -#xA7B4 #x0422 -#xA7B5 #x0423 -#xA7B6 #x0424 -#xA7B7 #x0425 -#xA7B8 #x0426 -#xA7B9 #x0427 -#xA7BA #x0428 -#xA7BB #x0429 -#xA7BC #x042A -#xA7BD #x042B -#xA7BE #x042C -#xA7BF #x042D -#xA7C0 #x042E -#xA7C1 #x042F -#xA7D1 #x0430 -#xA7D2 #x0431 -#xA7D3 #x0432 -#xA7D4 #x0433 -#xA7D5 #x0434 -#xA7D6 #x0435 -#xA7D7 #x0451 -#xA7D8 #x0436 -#xA7D9 #x0437 -#xA7DA #x0438 -#xA7DB #x0439 -#xA7DC #x043A -#xA7DD #x043B -#xA7DE #x043C -#xA7DF #x043D -#xA7E0 #x043E -#xA7E1 #x043F -#xA7E2 #x0440 -#xA7E3 #x0441 -#xA7E4 #x0442 -#xA7E5 #x0443 -#xA7E6 #x0444 -#xA7E7 #x0445 -#xA7E8 #x0446 -#xA7E9 #x0447 -#xA7EA #x0448 -#xA7EB #x0449 -#xA7EC #x044A -#xA7ED #x044B -#xA7EE #x044C -#xA7EF #x044D -#xA7F0 #x044E -#xA7F1 #x044F -#xA8A1 #x2500 -#xA8A2 #x2502 -#xA8A3 #x250C -#xA8A4 #x2510 -#xA8A5 #x2518 -#xA8A6 #x2514 -#xA8A7 #x251C -#xA8A8 #x252C -#xA8A9 #x2524 -#xA8AA #x2534 -#xA8AB #x253C -#xA8AC #x2501 -#xA8AD #x2503 -#xA8AE #x250F -#xA8AF #x2513 -#xA8B0 #x251B -#xA8B1 #x2517 -#xA8B2 #x2523 -#xA8B3 #x2533 -#xA8B4 #x252B -#xA8B5 #x253B -#xA8B6 #x254B -#xA8B7 #x2520 -#xA8B8 #x252F -#xA8B9 #x2528 -#xA8BA #x2537 -#xA8BB #x253F -#xA8BC #x251D -#xA8BD #x2530 -#xA8BE #x2525 -#xA8BF #x2538 -#xA8C0 #x2542 -#xB0A1 #x4E9C -#xB0A2 #x5516 -#xB0A3 #x5A03 -#xB0A4 #x963F -#xB0A5 #x54C0 -#xB0A6 #x611B -#xB0A7 #x6328 -#xB0A8 #x59F6 -#xB0A9 #x9022 -#xB0AA #x8475 -#xB0AB #x831C -#xB0AC #x7A50 -#xB0AD #x60AA -#xB0AE #x63E1 -#xB0AF #x6E25 -#xB0B0 #x65ED -#xB0B1 #x8466 -#xB0B2 #x82A6 -#xB0B3 #x9BF5 -#xB0B4 #x6893 -#xB0B5 #x5727 -#xB0B6 #x65A1 -#xB0B7 #x6271 -#xB0B8 #x5B9B -#xB0B9 #x59D0 -#xB0BA #x867B -#xB0BB #x98F4 -#xB0BC #x7D62 -#xB0BD #x7DBE -#xB0BE #x9B8E -#xB0BF #x6216 -#xB0C0 #x7C9F -#xB0C1 #x88B7 -#xB0C2 #x5B89 -#xB0C3 #x5EB5 -#xB0C4 #x6309 -#xB0C5 #x6697 -#xB0C6 #x6848 -#xB0C7 #x95C7 -#xB0C8 #x978D -#xB0C9 #x674F -#xB0CA #x4EE5 -#xB0CB #x4F0A -#xB0CC #x4F4D -#xB0CD #x4F9D -#xB0CE #x5049 -#xB0CF #x56F2 -#xB0D0 #x5937 -#xB0D1 #x59D4 -#xB0D2 #x5A01 -#xB0D3 #x5C09 -#xB0D4 #x60DF -#xB0D5 #x610F -#xB0D6 #x6170 -#xB0D7 #x6613 -#xB0D8 #x6905 -#xB0D9 #x70BA -#xB0DA #x754F -#xB0DB #x7570 -#xB0DC #x79FB -#xB0DD #x7DAD -#xB0DE #x7DEF -#xB0DF #x80C3 -#xB0E0 #x840E -#xB0E1 #x8863 -#xB0E2 #x8B02 -#xB0E3 #x9055 -#xB0E4 #x907A -#xB0E5 #x533B -#xB0E6 #x4E95 -#xB0E7 #x4EA5 -#xB0E8 #x57DF -#xB0E9 #x80B2 -#xB0EA #x90C1 -#xB0EB #x78EF -#xB0EC #x4E00 -#xB0ED #x58F1 -#xB0EE #x6EA2 -#xB0EF #x9038 -#xB0F0 #x7A32 -#xB0F1 #x8328 -#xB0F2 #x828B -#xB0F3 #x9C2F -#xB0F4 #x5141 -#xB0F5 #x5370 -#xB0F6 #x54BD -#xB0F7 #x54E1 -#xB0F8 #x56E0 -#xB0F9 #x59FB -#xB0FA #x5F15 -#xB0FB #x98F2 -#xB0FC #x6DEB -#xB0FD #x80E4 -#xB0FE #x852D -#xB1A1 #x9662 -#xB1A2 #x9670 -#xB1A3 #x96A0 -#xB1A4 #x97FB -#xB1A5 #x540B -#xB1A6 #x53F3 -#xB1A7 #x5B87 -#xB1A8 #x70CF -#xB1A9 #x7FBD -#xB1AA #x8FC2 -#xB1AB #x96E8 -#xB1AC #x536F -#xB1AD #x9D5C -#xB1AE #x7ABA -#xB1AF #x4E11 -#xB1B0 #x7893 -#xB1B1 #x81FC -#xB1B2 #x6E26 -#xB1B3 #x5618 -#xB1B4 #x5504 -#xB1B5 #x6B1D -#xB1B6 #x851A -#xB1B7 #x9C3B -#xB1B8 #x59E5 -#xB1B9 #x53A9 -#xB1BA #x6D66 -#xB1BB #x74DC -#xB1BC #x958F -#xB1BD #x5642 -#xB1BE #x4E91 -#xB1BF #x904B -#xB1C0 #x96F2 -#xB1C1 #x834F -#xB1C2 #x990C -#xB1C3 #x53E1 -#xB1C4 #x55B6 -#xB1C5 #x5B30 -#xB1C6 #x5F71 -#xB1C7 #x6620 -#xB1C8 #x66F3 -#xB1C9 #x6804 -#xB1CA #x6C38 -#xB1CB #x6CF3 -#xB1CC #x6D29 -#xB1CD #x745B -#xB1CE #x76C8 -#xB1CF #x7A4E -#xB1D0 #x9834 -#xB1D1 #x82F1 -#xB1D2 #x885B -#xB1D3 #x8A60 -#xB1D4 #x92ED -#xB1D5 #x6DB2 -#xB1D6 #x75AB -#xB1D7 #x76CA -#xB1D8 #x99C5 -#xB1D9 #x60A6 -#xB1DA #x8B01 -#xB1DB #x8D8A -#xB1DC #x95B2 -#xB1DD #x698E -#xB1DE #x53AD -#xB1DF #x5186 -#xB1E0 #x5712 -#xB1E1 #x5830 -#xB1E2 #x5944 -#xB1E3 #x5BB4 -#xB1E4 #x5EF6 -#xB1E5 #x6028 -#xB1E6 #x63A9 -#xB1E7 #x63F4 -#xB1E8 #x6CBF -#xB1E9 #x6F14 -#xB1EA #x708E -#xB1EB #x7114 -#xB1EC #x7159 -#xB1ED #x71D5 -#xB1EE #x733F -#xB1EF #x7E01 -#xB1F0 #x8276 -#xB1F1 #x82D1 -#xB1F2 #x8597 -#xB1F3 #x9060 -#xB1F4 #x925B -#xB1F5 #x9D1B -#xB1F6 #x5869 -#xB1F7 #x65BC -#xB1F8 #x6C5A -#xB1F9 #x7525 -#xB1FA #x51F9 -#xB1FB #x592E -#xB1FC #x5965 -#xB1FD #x5F80 -#xB1FE #x5FDC -#xB2A1 #x62BC -#xB2A2 #x65FA -#xB2A3 #x6A2A -#xB2A4 #x6B27 -#xB2A5 #x6BB4 -#xB2A6 #x738B -#xB2A7 #x7FC1 -#xB2A8 #x8956 -#xB2A9 #x9D2C -#xB2AA #x9D0E -#xB2AB #x9EC4 -#xB2AC #x5CA1 -#xB2AD #x6C96 -#xB2AE #x837B -#xB2AF #x5104 -#xB2B0 #x5C4B -#xB2B1 #x61B6 -#xB2B2 #x81C6 -#xB2B3 #x6876 -#xB2B4 #x7261 -#xB2B5 #x4E59 -#xB2B6 #x4FFA -#xB2B7 #x5378 -#xB2B8 #x6069 -#xB2B9 #x6E29 -#xB2BA #x7A4F -#xB2BB #x97F3 -#xB2BC #x4E0B -#xB2BD #x5316 -#xB2BE #x4EEE -#xB2BF #x4F55 -#xB2C0 #x4F3D -#xB2C1 #x4FA1 -#xB2C2 #x4F73 -#xB2C3 #x52A0 -#xB2C4 #x53EF -#xB2C5 #x5609 -#xB2C6 #x590F -#xB2C7 #x5AC1 -#xB2C8 #x5BB6 -#xB2C9 #x5BE1 -#xB2CA #x79D1 -#xB2CB #x6687 -#xB2CC #x679C -#xB2CD #x67B6 -#xB2CE #x6B4C -#xB2CF #x6CB3 -#xB2D0 #x706B -#xB2D1 #x73C2 -#xB2D2 #x798D -#xB2D3 #x79BE -#xB2D4 #x7A3C -#xB2D5 #x7B87 -#xB2D6 #x82B1 -#xB2D7 #x82DB -#xB2D8 #x8304 -#xB2D9 #x8377 -#xB2DA #x83EF -#xB2DB #x83D3 -#xB2DC #x8766 -#xB2DD #x8AB2 -#xB2DE #x5629 -#xB2DF #x8CA8 -#xB2E0 #x8FE6 -#xB2E1 #x904E -#xB2E2 #x971E -#xB2E3 #x868A -#xB2E4 #x4FC4 -#xB2E5 #x5CE8 -#xB2E6 #x6211 -#xB2E7 #x7259 -#xB2E8 #x753B -#xB2E9 #x81E5 -#xB2EA #x82BD -#xB2EB #x86FE -#xB2EC #x8CC0 -#xB2ED #x96C5 -#xB2EE #x9913 -#xB2EF #x99D5 -#xB2F0 #x4ECB -#xB2F1 #x4F1A -#xB2F2 #x89E3 -#xB2F3 #x56DE -#xB2F4 #x584A -#xB2F5 #x58CA -#xB2F6 #x5EFB -#xB2F7 #x5FEB -#xB2F8 #x602A -#xB2F9 #x6094 -#xB2FA #x6062 -#xB2FB #x61D0 -#xB2FC #x6212 -#xB2FD #x62D0 -#xB2FE #x6539 -#xB3A1 #x9B41 -#xB3A2 #x6666 -#xB3A3 #x68B0 -#xB3A4 #x6D77 -#xB3A5 #x7070 -#xB3A6 #x754C -#xB3A7 #x7686 -#xB3A8 #x7D75 -#xB3A9 #x82A5 -#xB3AA #x87F9 -#xB3AB #x958B -#xB3AC #x968E -#xB3AD #x8C9D -#xB3AE #x51F1 -#xB3AF #x52BE -#xB3B0 #x5916 -#xB3B1 #x54B3 -#xB3B2 #x5BB3 -#xB3B3 #x5D16 -#xB3B4 #x6168 -#xB3B5 #x6982 -#xB3B6 #x6DAF -#xB3B7 #x788D -#xB3B8 #x84CB -#xB3B9 #x8857 -#xB3BA #x8A72 -#xB3BB #x93A7 -#xB3BC #x9AB8 -#xB3BD #x6D6C -#xB3BE #x99A8 -#xB3BF #x86D9 -#xB3C0 #x57A3 -#xB3C1 #x67FF -#xB3C2 #x86CE -#xB3C3 #x920E -#xB3C4 #x5283 -#xB3C5 #x5687 -#xB3C6 #x5404 -#xB3C7 #x5ED3 -#xB3C8 #x62E1 -#xB3C9 #x64B9 -#xB3CA #x683C -#xB3CB #x6838 -#xB3CC #x6BBB -#xB3CD #x7372 -#xB3CE #x78BA -#xB3CF #x7A6B -#xB3D0 #x899A -#xB3D1 #x89D2 -#xB3D2 #x8D6B -#xB3D3 #x8F03 -#xB3D4 #x90ED -#xB3D5 #x95A3 -#xB3D6 #x9694 -#xB3D7 #x9769 -#xB3D8 #x5B66 -#xB3D9 #x5CB3 -#xB3DA #x697D -#xB3DB #x984D -#xB3DC #x984E -#xB3DD #x639B -#xB3DE #x7B20 -#xB3DF #x6A2B -#xB3E0 #x6A7F -#xB3E1 #x68B6 -#xB3E2 #x9C0D -#xB3E3 #x6F5F -#xB3E4 #x5272 -#xB3E5 #x559D -#xB3E6 #x6070 -#xB3E7 #x62EC -#xB3E8 #x6D3B -#xB3E9 #x6E07 -#xB3EA #x6ED1 -#xB3EB #x845B -#xB3EC #x8910 -#xB3ED #x8F44 -#xB3EE #x4E14 -#xB3EF #x9C39 -#xB3F0 #x53F6 -#xB3F1 #x691B -#xB3F2 #x6A3A -#xB3F3 #x9784 -#xB3F4 #x682A -#xB3F5 #x515C -#xB3F6 #x7AC3 -#xB3F7 #x84B2 -#xB3F8 #x91DC -#xB3F9 #x938C -#xB3FA #x565B -#xB3FB #x9D28 -#xB3FC #x6822 -#xB3FD #x8305 -#xB3FE #x8431 -#xB4A1 #x7CA5 -#xB4A2 #x5208 -#xB4A3 #x82C5 -#xB4A4 #x74E6 -#xB4A5 #x4E7E -#xB4A6 #x4F83 -#xB4A7 #x51A0 -#xB4A8 #x5BD2 -#xB4A9 #x520A -#xB4AA #x52D8 -#xB4AB #x52E7 -#xB4AC #x5DFB -#xB4AD #x559A -#xB4AE #x582A -#xB4AF #x59E6 -#xB4B0 #x5B8C -#xB4B1 #x5B98 -#xB4B2 #x5BDB -#xB4B3 #x5E72 -#xB4B4 #x5E79 -#xB4B5 #x60A3 -#xB4B6 #x611F -#xB4B7 #x6163 -#xB4B8 #x61BE -#xB4B9 #x63DB -#xB4BA #x6562 -#xB4BB #x67D1 -#xB4BC #x6853 -#xB4BD #x68FA -#xB4BE #x6B3E -#xB4BF #x6B53 -#xB4C0 #x6C57 -#xB4C1 #x6F22 -#xB4C2 #x6F97 -#xB4C3 #x6F45 -#xB4C4 #x74B0 -#xB4C5 #x7518 -#xB4C6 #x76E3 -#xB4C7 #x770B -#xB4C8 #x7AFF -#xB4C9 #x7BA1 -#xB4CA #x7C21 -#xB4CB #x7DE9 -#xB4CC #x7F36 -#xB4CD #x7FF0 -#xB4CE #x809D -#xB4CF #x8266 -#xB4D0 #x839E -#xB4D1 #x89B3 -#xB4D2 #x8ACC -#xB4D3 #x8CAB -#xB4D4 #x9084 -#xB4D5 #x9451 -#xB4D6 #x9593 -#xB4D7 #x9591 -#xB4D8 #x95A2 -#xB4D9 #x9665 -#xB4DA #x97D3 -#xB4DB #x9928 -#xB4DC #x8218 -#xB4DD #x4E38 -#xB4DE #x542B -#xB4DF #x5CB8 -#xB4E0 #x5DCC -#xB4E1 #x73A9 -#xB4E2 #x764C -#xB4E3 #x773C -#xB4E4 #x5CA9 -#xB4E5 #x7FEB -#xB4E6 #x8D0B -#xB4E7 #x96C1 -#xB4E8 #x9811 -#xB4E9 #x9854 -#xB4EA #x9858 -#xB4EB #x4F01 -#xB4EC #x4F0E -#xB4ED #x5371 -#xB4EE #x559C -#xB4EF #x5668 -#xB4F0 #x57FA -#xB4F1 #x5947 -#xB4F2 #x5B09 -#xB4F3 #x5BC4 -#xB4F4 #x5C90 -#xB4F5 #x5E0C -#xB4F6 #x5E7E -#xB4F7 #x5FCC -#xB4F8 #x63EE -#xB4F9 #x673A -#xB4FA #x65D7 -#xB4FB #x65E2 -#xB4FC #x671F -#xB4FD #x68CB -#xB4FE #x68C4 -#xB5A1 #x6A5F -#xB5A2 #x5E30 -#xB5A3 #x6BC5 -#xB5A4 #x6C17 -#xB5A5 #x6C7D -#xB5A6 #x757F -#xB5A7 #x7948 -#xB5A8 #x5B63 -#xB5A9 #x7A00 -#xB5AA #x7D00 -#xB5AB #x5FBD -#xB5AC #x898F -#xB5AD #x8A18 -#xB5AE #x8CB4 -#xB5AF #x8D77 -#xB5B0 #x8ECC -#xB5B1 #x8F1D -#xB5B2 #x98E2 -#xB5B3 #x9A0E -#xB5B4 #x9B3C -#xB5B5 #x4E80 -#xB5B6 #x507D -#xB5B7 #x5100 -#xB5B8 #x5993 -#xB5B9 #x5B9C -#xB5BA #x622F -#xB5BB #x6280 -#xB5BC #x64EC -#xB5BD #x6B3A -#xB5BE #x72A0 -#xB5BF #x7591 -#xB5C0 #x7947 -#xB5C1 #x7FA9 -#xB5C2 #x87FB -#xB5C3 #x8ABC -#xB5C4 #x8B70 -#xB5C5 #x63AC -#xB5C6 #x83CA -#xB5C7 #x97A0 -#xB5C8 #x5409 -#xB5C9 #x5403 -#xB5CA #x55AB -#xB5CB #x6854 -#xB5CC #x6A58 -#xB5CD #x8A70 -#xB5CE #x7827 -#xB5CF #x6775 -#xB5D0 #x9ECD -#xB5D1 #x5374 -#xB5D2 #x5BA2 -#xB5D3 #x811A -#xB5D4 #x8650 -#xB5D5 #x9006 -#xB5D6 #x4E18 -#xB5D7 #x4E45 -#xB5D8 #x4EC7 -#xB5D9 #x4F11 -#xB5DA #x53CA -#xB5DB #x5438 -#xB5DC #x5BAE -#xB5DD #x5F13 -#xB5DE #x6025 -#xB5DF #x6551 -#xB5E0 #x673D -#xB5E1 #x6C42 -#xB5E2 #x6C72 -#xB5E3 #x6CE3 -#xB5E4 #x7078 -#xB5E5 #x7403 -#xB5E6 #x7A76 -#xB5E7 #x7AAE -#xB5E8 #x7B08 -#xB5E9 #x7D1A -#xB5EA #x7CFE -#xB5EB #x7D66 -#xB5EC #x65E7 -#xB5ED #x725B -#xB5EE #x53BB -#xB5EF #x5C45 -#xB5F0 #x5DE8 -#xB5F1 #x62D2 -#xB5F2 #x62E0 -#xB5F3 #x6319 -#xB5F4 #x6E20 -#xB5F5 #x865A -#xB5F6 #x8A31 -#xB5F7 #x8DDD -#xB5F8 #x92F8 -#xB5F9 #x6F01 -#xB5FA #x79A6 -#xB5FB #x9B5A -#xB5FC #x4EA8 -#xB5FD #x4EAB -#xB5FE #x4EAC -#xB6A1 #x4F9B -#xB6A2 #x4FA0 -#xB6A3 #x50D1 -#xB6A4 #x5147 -#xB6A5 #x7AF6 -#xB6A6 #x5171 -#xB6A7 #x51F6 -#xB6A8 #x5354 -#xB6A9 #x5321 -#xB6AA #x537F -#xB6AB #x53EB -#xB6AC #x55AC -#xB6AD #x5883 -#xB6AE #x5CE1 -#xB6AF #x5F37 -#xB6B0 #x5F4A -#xB6B1 #x602F -#xB6B2 #x6050 -#xB6B3 #x606D -#xB6B4 #x631F -#xB6B5 #x6559 -#xB6B6 #x6A4B -#xB6B7 #x6CC1 -#xB6B8 #x72C2 -#xB6B9 #x72ED -#xB6BA #x77EF -#xB6BB #x80F8 -#xB6BC #x8105 -#xB6BD #x8208 -#xB6BE #x854E -#xB6BF #x90F7 -#xB6C0 #x93E1 -#xB6C1 #x97FF -#xB6C2 #x9957 -#xB6C3 #x9A5A -#xB6C4 #x4EF0 -#xB6C5 #x51DD -#xB6C6 #x5C2D -#xB6C7 #x6681 -#xB6C8 #x696D -#xB6C9 #x5C40 -#xB6CA #x66F2 -#xB6CB #x6975 -#xB6CC #x7389 -#xB6CD #x6850 -#xB6CE #x7C81 -#xB6CF #x50C5 -#xB6D0 #x52E4 -#xB6D1 #x5747 -#xB6D2 #x5DFE -#xB6D3 #x9326 -#xB6D4 #x65A4 -#xB6D5 #x6B23 -#xB6D6 #x6B3D -#xB6D7 #x7434 -#xB6D8 #x7981 -#xB6D9 #x79BD -#xB6DA #x7B4B -#xB6DB #x7DCA -#xB6DC #x82B9 -#xB6DD #x83CC -#xB6DE #x887F -#xB6DF #x895F -#xB6E0 #x8B39 -#xB6E1 #x8FD1 -#xB6E2 #x91D1 -#xB6E3 #x541F -#xB6E4 #x9280 -#xB6E5 #x4E5D -#xB6E6 #x5036 -#xB6E7 #x53E5 -#xB6E8 #x533A -#xB6E9 #x72D7 -#xB6EA #x7396 -#xB6EB #x77E9 -#xB6EC #x82E6 -#xB6ED #x8EAF -#xB6EE #x99C6 -#xB6EF #x99C8 -#xB6F0 #x99D2 -#xB6F1 #x5177 -#xB6F2 #x611A -#xB6F3 #x865E -#xB6F4 #x55B0 -#xB6F5 #x7A7A -#xB6F6 #x5076 -#xB6F7 #x5BD3 -#xB6F8 #x9047 -#xB6F9 #x9685 -#xB6FA #x4E32 -#xB6FB #x6ADB -#xB6FC #x91E7 -#xB6FD #x5C51 -#xB6FE #x5C48 -#xB7A1 #x6398 -#xB7A2 #x7A9F -#xB7A3 #x6C93 -#xB7A4 #x9774 -#xB7A5 #x8F61 -#xB7A6 #x7AAA -#xB7A7 #x718A -#xB7A8 #x9688 -#xB7A9 #x7C82 -#xB7AA #x6817 -#xB7AB #x7E70 -#xB7AC #x6851 -#xB7AD #x936C -#xB7AE #x52F2 -#xB7AF #x541B -#xB7B0 #x85AB -#xB7B1 #x8A13 -#xB7B2 #x7FA4 -#xB7B3 #x8ECD -#xB7B4 #x90E1 -#xB7B5 #x5366 -#xB7B6 #x8888 -#xB7B7 #x7941 -#xB7B8 #x4FC2 -#xB7B9 #x50BE -#xB7BA #x5211 -#xB7BB #x5144 -#xB7BC #x5553 -#xB7BD #x572D -#xB7BE #x73EA -#xB7BF #x578B -#xB7C0 #x5951 -#xB7C1 #x5F62 -#xB7C2 #x5F84 -#xB7C3 #x6075 -#xB7C4 #x6176 -#xB7C5 #x6167 -#xB7C6 #x61A9 -#xB7C7 #x63B2 -#xB7C8 #x643A -#xB7C9 #x656C -#xB7CA #x666F -#xB7CB #x6842 -#xB7CC #x6E13 -#xB7CD #x7566 -#xB7CE #x7A3D -#xB7CF #x7CFB -#xB7D0 #x7D4C -#xB7D1 #x7D99 -#xB7D2 #x7E4B -#xB7D3 #x7F6B -#xB7D4 #x830E -#xB7D5 #x834A -#xB7D6 #x86CD -#xB7D7 #x8A08 -#xB7D8 #x8A63 -#xB7D9 #x8B66 -#xB7DA #x8EFD -#xB7DB #x981A -#xB7DC #x9D8F -#xB7DD #x82B8 -#xB7DE #x8FCE -#xB7DF #x9BE8 -#xB7E0 #x5287 -#xB7E1 #x621F -#xB7E2 #x6483 -#xB7E3 #x6FC0 -#xB7E4 #x9699 -#xB7E5 #x6841 -#xB7E6 #x5091 -#xB7E7 #x6B20 -#xB7E8 #x6C7A -#xB7E9 #x6F54 -#xB7EA #x7A74 -#xB7EB #x7D50 -#xB7EC #x8840 -#xB7ED #x8A23 -#xB7EE #x6708 -#xB7EF #x4EF6 -#xB7F0 #x5039 -#xB7F1 #x5026 -#xB7F2 #x5065 -#xB7F3 #x517C -#xB7F4 #x5238 -#xB7F5 #x5263 -#xB7F6 #x55A7 -#xB7F7 #x570F -#xB7F8 #x5805 -#xB7F9 #x5ACC -#xB7FA #x5EFA -#xB7FB #x61B2 -#xB7FC #x61F8 -#xB7FD #x62F3 -#xB7FE #x6372 -#xB8A1 #x691C -#xB8A2 #x6A29 -#xB8A3 #x727D -#xB8A4 #x72AC -#xB8A5 #x732E -#xB8A6 #x7814 -#xB8A7 #x786F -#xB8A8 #x7D79 -#xB8A9 #x770C -#xB8AA #x80A9 -#xB8AB #x898B -#xB8AC #x8B19 -#xB8AD #x8CE2 -#xB8AE #x8ED2 -#xB8AF #x9063 -#xB8B0 #x9375 -#xB8B1 #x967A -#xB8B2 #x9855 -#xB8B3 #x9A13 -#xB8B4 #x9E78 -#xB8B5 #x5143 -#xB8B6 #x539F -#xB8B7 #x53B3 -#xB8B8 #x5E7B -#xB8B9 #x5F26 -#xB8BA #x6E1B -#xB8BB #x6E90 -#xB8BC #x7384 -#xB8BD #x73FE -#xB8BE #x7D43 -#xB8BF #x8237 -#xB8C0 #x8A00 -#xB8C1 #x8AFA -#xB8C2 #x9650 -#xB8C3 #x4E4E -#xB8C4 #x500B -#xB8C5 #x53E4 -#xB8C6 #x547C -#xB8C7 #x56FA -#xB8C8 #x59D1 -#xB8C9 #x5B64 -#xB8CA #x5DF1 -#xB8CB #x5EAB -#xB8CC #x5F27 -#xB8CD #x6238 -#xB8CE #x6545 -#xB8CF #x67AF -#xB8D0 #x6E56 -#xB8D1 #x72D0 -#xB8D2 #x7CCA -#xB8D3 #x88B4 -#xB8D4 #x80A1 -#xB8D5 #x80E1 -#xB8D6 #x83F0 -#xB8D7 #x864E -#xB8D8 #x8A87 -#xB8D9 #x8DE8 -#xB8DA #x9237 -#xB8DB #x96C7 -#xB8DC #x9867 -#xB8DD #x9F13 -#xB8DE #x4E94 -#xB8DF #x4E92 -#xB8E0 #x4F0D -#xB8E1 #x5348 -#xB8E2 #x5449 -#xB8E3 #x543E -#xB8E4 #x5A2F -#xB8E5 #x5F8C -#xB8E6 #x5FA1 -#xB8E7 #x609F -#xB8E8 #x68A7 -#xB8E9 #x6A8E -#xB8EA #x745A -#xB8EB #x7881 -#xB8EC #x8A9E -#xB8ED #x8AA4 -#xB8EE #x8B77 -#xB8EF #x9190 -#xB8F0 #x4E5E -#xB8F1 #x9BC9 -#xB8F2 #x4EA4 -#xB8F3 #x4F7C -#xB8F4 #x4FAF -#xB8F5 #x5019 -#xB8F6 #x5016 -#xB8F7 #x5149 -#xB8F8 #x516C -#xB8F9 #x529F -#xB8FA #x52B9 -#xB8FB #x52FE -#xB8FC #x539A -#xB8FD #x53E3 -#xB8FE #x5411 -#xB9A1 #x540E -#xB9A2 #x5589 -#xB9A3 #x5751 -#xB9A4 #x57A2 -#xB9A5 #x597D -#xB9A6 #x5B54 -#xB9A7 #x5B5D -#xB9A8 #x5B8F -#xB9A9 #x5DE5 -#xB9AA #x5DE7 -#xB9AB #x5DF7 -#xB9AC #x5E78 -#xB9AD #x5E83 -#xB9AE #x5E9A -#xB9AF #x5EB7 -#xB9B0 #x5F18 -#xB9B1 #x6052 -#xB9B2 #x614C -#xB9B3 #x6297 -#xB9B4 #x62D8 -#xB9B5 #x63A7 -#xB9B6 #x653B -#xB9B7 #x6602 -#xB9B8 #x6643 -#xB9B9 #x66F4 -#xB9BA #x676D -#xB9BB #x6821 -#xB9BC #x6897 -#xB9BD #x69CB -#xB9BE #x6C5F -#xB9BF #x6D2A -#xB9C0 #x6D69 -#xB9C1 #x6E2F -#xB9C2 #x6E9D -#xB9C3 #x7532 -#xB9C4 #x7687 -#xB9C5 #x786C -#xB9C6 #x7A3F -#xB9C7 #x7CE0 -#xB9C8 #x7D05 -#xB9C9 #x7D18 -#xB9CA #x7D5E -#xB9CB #x7DB1 -#xB9CC #x8015 -#xB9CD #x8003 -#xB9CE #x80AF -#xB9CF #x80B1 -#xB9D0 #x8154 -#xB9D1 #x818F -#xB9D2 #x822A -#xB9D3 #x8352 -#xB9D4 #x884C -#xB9D5 #x8861 -#xB9D6 #x8B1B -#xB9D7 #x8CA2 -#xB9D8 #x8CFC -#xB9D9 #x90CA -#xB9DA #x9175 -#xB9DB #x9271 -#xB9DC #x783F -#xB9DD #x92FC -#xB9DE #x95A4 -#xB9DF #x964D -#xB9E0 #x9805 -#xB9E1 #x9999 -#xB9E2 #x9AD8 -#xB9E3 #x9D3B -#xB9E4 #x525B -#xB9E5 #x52AB -#xB9E6 #x53F7 -#xB9E7 #x5408 -#xB9E8 #x58D5 -#xB9E9 #x62F7 -#xB9EA #x6FE0 -#xB9EB #x8C6A -#xB9EC #x8F5F -#xB9ED #x9EB9 -#xB9EE #x514B -#xB9EF #x523B -#xB9F0 #x544A -#xB9F1 #x56FD -#xB9F2 #x7A40 -#xB9F3 #x9177 -#xB9F4 #x9D60 -#xB9F5 #x9ED2 -#xB9F6 #x7344 -#xB9F7 #x6F09 -#xB9F8 #x8170 -#xB9F9 #x7511 -#xB9FA #x5FFD -#xB9FB #x60DA -#xB9FC #x9AA8 -#xB9FD #x72DB -#xB9FE #x8FBC -#xBAA1 #x6B64 -#xBAA2 #x9803 -#xBAA3 #x4ECA -#xBAA4 #x56F0 -#xBAA5 #x5764 -#xBAA6 #x58BE -#xBAA7 #x5A5A -#xBAA8 #x6068 -#xBAA9 #x61C7 -#xBAAA #x660F -#xBAAB #x6606 -#xBAAC #x6839 -#xBAAD #x68B1 -#xBAAE #x6DF7 -#xBAAF #x75D5 -#xBAB0 #x7D3A -#xBAB1 #x826E -#xBAB2 #x9B42 -#xBAB3 #x4E9B -#xBAB4 #x4F50 -#xBAB5 #x53C9 -#xBAB6 #x5506 -#xBAB7 #x5D6F -#xBAB8 #x5DE6 -#xBAB9 #x5DEE -#xBABA #x67FB -#xBABB #x6C99 -#xBABC #x7473 -#xBABD #x7802 -#xBABE #x8A50 -#xBABF #x9396 -#xBAC0 #x88DF -#xBAC1 #x5750 -#xBAC2 #x5EA7 -#xBAC3 #x632B -#xBAC4 #x50B5 -#xBAC5 #x50AC -#xBAC6 #x518D -#xBAC7 #x6700 -#xBAC8 #x54C9 -#xBAC9 #x585E -#xBACA #x59BB -#xBACB #x5BB0 -#xBACC #x5F69 -#xBACD #x624D -#xBACE #x63A1 -#xBACF #x683D -#xBAD0 #x6B73 -#xBAD1 #x6E08 -#xBAD2 #x707D -#xBAD3 #x91C7 -#xBAD4 #x7280 -#xBAD5 #x7815 -#xBAD6 #x7826 -#xBAD7 #x796D -#xBAD8 #x658E -#xBAD9 #x7D30 -#xBADA #x83DC -#xBADB #x88C1 -#xBADC #x8F09 -#xBADD #x969B -#xBADE #x5264 -#xBADF #x5728 -#xBAE0 #x6750 -#xBAE1 #x7F6A -#xBAE2 #x8CA1 -#xBAE3 #x51B4 -#xBAE4 #x5742 -#xBAE5 #x962A -#xBAE6 #x583A -#xBAE7 #x698A -#xBAE8 #x80B4 -#xBAE9 #x54B2 -#xBAEA #x5D0E -#xBAEB #x57FC -#xBAEC #x7895 -#xBAED #x9DFA -#xBAEE #x4F5C -#xBAEF #x524A -#xBAF0 #x548B -#xBAF1 #x643E -#xBAF2 #x6628 -#xBAF3 #x6714 -#xBAF4 #x67F5 -#xBAF5 #x7A84 -#xBAF6 #x7B56 -#xBAF7 #x7D22 -#xBAF8 #x932F -#xBAF9 #x685C -#xBAFA #x9BAD -#xBAFB #x7B39 -#xBAFC #x5319 -#xBAFD #x518A -#xBAFE #x5237 -#xBBA1 #x5BDF -#xBBA2 #x62F6 -#xBBA3 #x64AE -#xBBA4 #x64E6 -#xBBA5 #x672D -#xBBA6 #x6BBA -#xBBA7 #x85A9 -#xBBA8 #x96D1 -#xBBA9 #x7690 -#xBBAA #x9BD6 -#xBBAB #x634C -#xBBAC #x9306 -#xBBAD #x9BAB -#xBBAE #x76BF -#xBBAF #x6652 -#xBBB0 #x4E09 -#xBBB1 #x5098 -#xBBB2 #x53C2 -#xBBB3 #x5C71 -#xBBB4 #x60E8 -#xBBB5 #x6492 -#xBBB6 #x6563 -#xBBB7 #x685F -#xBBB8 #x71E6 -#xBBB9 #x73CA -#xBBBA #x7523 -#xBBBB #x7B97 -#xBBBC #x7E82 -#xBBBD #x8695 -#xBBBE #x8B83 -#xBBBF #x8CDB -#xBBC0 #x9178 -#xBBC1 #x9910 -#xBBC2 #x65AC -#xBBC3 #x66AB -#xBBC4 #x6B8B -#xBBC5 #x4ED5 -#xBBC6 #x4ED4 -#xBBC7 #x4F3A -#xBBC8 #x4F7F -#xBBC9 #x523A -#xBBCA #x53F8 -#xBBCB #x53F2 -#xBBCC #x55E3 -#xBBCD #x56DB -#xBBCE #x58EB -#xBBCF #x59CB -#xBBD0 #x59C9 -#xBBD1 #x59FF -#xBBD2 #x5B50 -#xBBD3 #x5C4D -#xBBD4 #x5E02 -#xBBD5 #x5E2B -#xBBD6 #x5FD7 -#xBBD7 #x601D -#xBBD8 #x6307 -#xBBD9 #x652F -#xBBDA #x5B5C -#xBBDB #x65AF -#xBBDC #x65BD -#xBBDD #x65E8 -#xBBDE #x679D -#xBBDF #x6B62 -#xBBE0 #x6B7B -#xBBE1 #x6C0F -#xBBE2 #x7345 -#xBBE3 #x7949 -#xBBE4 #x79C1 -#xBBE5 #x7CF8 -#xBBE6 #x7D19 -#xBBE7 #x7D2B -#xBBE8 #x80A2 -#xBBE9 #x8102 -#xBBEA #x81F3 -#xBBEB #x8996 -#xBBEC #x8A5E -#xBBED #x8A69 -#xBBEE #x8A66 -#xBBEF #x8A8C -#xBBF0 #x8AEE -#xBBF1 #x8CC7 -#xBBF2 #x8CDC -#xBBF3 #x96CC -#xBBF4 #x98FC -#xBBF5 #x6B6F -#xBBF6 #x4E8B -#xBBF7 #x4F3C -#xBBF8 #x4F8D -#xBBF9 #x5150 -#xBBFA #x5B57 -#xBBFB #x5BFA -#xBBFC #x6148 -#xBBFD #x6301 -#xBBFE #x6642 -#xBCA1 #x6B21 -#xBCA2 #x6ECB -#xBCA3 #x6CBB -#xBCA4 #x723E -#xBCA5 #x74BD -#xBCA6 #x75D4 -#xBCA7 #x78C1 -#xBCA8 #x793A -#xBCA9 #x800C -#xBCAA #x8033 -#xBCAB #x81EA -#xBCAC #x8494 -#xBCAD #x8F9E -#xBCAE #x6C50 -#xBCAF #x9E7F -#xBCB0 #x5F0F -#xBCB1 #x8B58 -#xBCB2 #x9D2B -#xBCB3 #x7AFA -#xBCB4 #x8EF8 -#xBCB5 #x5B8D -#xBCB6 #x96EB -#xBCB7 #x4E03 -#xBCB8 #x53F1 -#xBCB9 #x57F7 -#xBCBA #x5931 -#xBCBB #x5AC9 -#xBCBC #x5BA4 -#xBCBD #x6089 -#xBCBE #x6E7F -#xBCBF #x6F06 -#xBCC0 #x75BE -#xBCC1 #x8CEA -#xBCC2 #x5B9F -#xBCC3 #x8500 -#xBCC4 #x7BE0 -#xBCC5 #x5072 -#xBCC6 #x67F4 -#xBCC7 #x829D -#xBCC8 #x5C61 -#xBCC9 #x854A -#xBCCA #x7E1E -#xBCCB #x820E -#xBCCC #x5199 -#xBCCD #x5C04 -#xBCCE #x6368 -#xBCCF #x8D66 -#xBCD0 #x659C -#xBCD1 #x716E -#xBCD2 #x793E -#xBCD3 #x7D17 -#xBCD4 #x8005 -#xBCD5 #x8B1D -#xBCD6 #x8ECA -#xBCD7 #x906E -#xBCD8 #x86C7 -#xBCD9 #x90AA -#xBCDA #x501F -#xBCDB #x52FA -#xBCDC #x5C3A -#xBCDD #x6753 -#xBCDE #x707C -#xBCDF #x7235 -#xBCE0 #x914C -#xBCE1 #x91C8 -#xBCE2 #x932B -#xBCE3 #x82E5 -#xBCE4 #x5BC2 -#xBCE5 #x5F31 -#xBCE6 #x60F9 -#xBCE7 #x4E3B -#xBCE8 #x53D6 -#xBCE9 #x5B88 -#xBCEA #x624B -#xBCEB #x6731 -#xBCEC #x6B8A -#xBCED #x72E9 -#xBCEE #x73E0 -#xBCEF #x7A2E -#xBCF0 #x816B -#xBCF1 #x8DA3 -#xBCF2 #x9152 -#xBCF3 #x9996 -#xBCF4 #x5112 -#xBCF5 #x53D7 -#xBCF6 #x546A -#xBCF7 #x5BFF -#xBCF8 #x6388 -#xBCF9 #x6A39 -#xBCFA #x7DAC -#xBCFB #x9700 -#xBCFC #x56DA -#xBCFD #x53CE -#xBCFE #x5468 -#xBDA1 #x5B97 -#xBDA2 #x5C31 -#xBDA3 #x5DDE -#xBDA4 #x4FEE -#xBDA5 #x6101 -#xBDA6 #x62FE -#xBDA7 #x6D32 -#xBDA8 #x79C0 -#xBDA9 #x79CB -#xBDAA #x7D42 -#xBDAB #x7E4D -#xBDAC #x7FD2 -#xBDAD #x81ED -#xBDAE #x821F -#xBDAF #x8490 -#xBDB0 #x8846 -#xBDB1 #x8972 -#xBDB2 #x8B90 -#xBDB3 #x8E74 -#xBDB4 #x8F2F -#xBDB5 #x9031 -#xBDB6 #x914B -#xBDB7 #x916C -#xBDB8 #x96C6 -#xBDB9 #x919C -#xBDBA #x4EC0 -#xBDBB #x4F4F -#xBDBC #x5145 -#xBDBD #x5341 -#xBDBE #x5F93 -#xBDBF #x620E -#xBDC0 #x67D4 -#xBDC1 #x6C41 -#xBDC2 #x6E0B -#xBDC3 #x7363 -#xBDC4 #x7E26 -#xBDC5 #x91CD -#xBDC6 #x9283 -#xBDC7 #x53D4 -#xBDC8 #x5919 -#xBDC9 #x5BBF -#xBDCA #x6DD1 -#xBDCB #x795D -#xBDCC #x7E2E -#xBDCD #x7C9B -#xBDCE #x587E -#xBDCF #x719F -#xBDD0 #x51FA -#xBDD1 #x8853 -#xBDD2 #x8FF0 -#xBDD3 #x4FCA -#xBDD4 #x5CFB -#xBDD5 #x6625 -#xBDD6 #x77AC -#xBDD7 #x7AE3 -#xBDD8 #x821C -#xBDD9 #x99FF -#xBDDA #x51C6 -#xBDDB #x5FAA -#xBDDC #x65EC -#xBDDD #x696F -#xBDDE #x6B89 -#xBDDF #x6DF3 -#xBDE0 #x6E96 -#xBDE1 #x6F64 -#xBDE2 #x76FE -#xBDE3 #x7D14 -#xBDE4 #x5DE1 -#xBDE5 #x9075 -#xBDE6 #x9187 -#xBDE7 #x9806 -#xBDE8 #x51E6 -#xBDE9 #x521D -#xBDEA #x6240 -#xBDEB #x6691 -#xBDEC #x66D9 -#xBDED #x6E1A -#xBDEE #x5EB6 -#xBDEF #x7DD2 -#xBDF0 #x7F72 -#xBDF1 #x66F8 -#xBDF2 #x85AF -#xBDF3 #x85F7 -#xBDF4 #x8AF8 -#xBDF5 #x52A9 -#xBDF6 #x53D9 -#xBDF7 #x5973 -#xBDF8 #x5E8F -#xBDF9 #x5F90 -#xBDFA #x6055 -#xBDFB #x92E4 -#xBDFC #x9664 -#xBDFD #x50B7 -#xBDFE #x511F -#xBEA1 #x52DD -#xBEA2 #x5320 -#xBEA3 #x5347 -#xBEA4 #x53EC -#xBEA5 #x54E8 -#xBEA6 #x5546 -#xBEA7 #x5531 -#xBEA8 #x5617 -#xBEA9 #x5968 -#xBEAA #x59BE -#xBEAB #x5A3C -#xBEAC #x5BB5 -#xBEAD #x5C06 -#xBEAE #x5C0F -#xBEAF #x5C11 -#xBEB0 #x5C1A -#xBEB1 #x5E84 -#xBEB2 #x5E8A -#xBEB3 #x5EE0 -#xBEB4 #x5F70 -#xBEB5 #x627F -#xBEB6 #x6284 -#xBEB7 #x62DB -#xBEB8 #x638C -#xBEB9 #x6377 -#xBEBA #x6607 -#xBEBB #x660C -#xBEBC #x662D -#xBEBD #x6676 -#xBEBE #x677E -#xBEBF #x68A2 -#xBEC0 #x6A1F -#xBEC1 #x6A35 -#xBEC2 #x6CBC -#xBEC3 #x6D88 -#xBEC4 #x6E09 -#xBEC5 #x6E58 -#xBEC6 #x713C -#xBEC7 #x7126 -#xBEC8 #x7167 -#xBEC9 #x75C7 -#xBECA #x7701 -#xBECB #x785D -#xBECC #x7901 -#xBECD #x7965 -#xBECE #x79F0 -#xBECF #x7AE0 -#xBED0 #x7B11 -#xBED1 #x7CA7 -#xBED2 #x7D39 -#xBED3 #x8096 -#xBED4 #x83D6 -#xBED5 #x848B -#xBED6 #x8549 -#xBED7 #x885D -#xBED8 #x88F3 -#xBED9 #x8A1F -#xBEDA #x8A3C -#xBEDB #x8A54 -#xBEDC #x8A73 -#xBEDD #x8C61 -#xBEDE #x8CDE -#xBEDF #x91A4 -#xBEE0 #x9266 -#xBEE1 #x937E -#xBEE2 #x9418 -#xBEE3 #x969C -#xBEE4 #x9798 -#xBEE5 #x4E0A -#xBEE6 #x4E08 -#xBEE7 #x4E1E -#xBEE8 #x4E57 -#xBEE9 #x5197 -#xBEEA #x5270 -#xBEEB #x57CE -#xBEEC #x5834 -#xBEED #x58CC -#xBEEE #x5B22 -#xBEEF #x5E38 -#xBEF0 #x60C5 -#xBEF1 #x64FE -#xBEF2 #x6761 -#xBEF3 #x6756 -#xBEF4 #x6D44 -#xBEF5 #x72B6 -#xBEF6 #x7573 -#xBEF7 #x7A63 -#xBEF8 #x84B8 -#xBEF9 #x8B72 -#xBEFA #x91B8 -#xBEFB #x9320 -#xBEFC #x5631 -#xBEFD #x57F4 -#xBEFE #x98FE -#xBFA1 #x62ED -#xBFA2 #x690D -#xBFA3 #x6B96 -#xBFA4 #x71ED -#xBFA5 #x7E54 -#xBFA6 #x8077 -#xBFA7 #x8272 -#xBFA8 #x89E6 -#xBFA9 #x98DF -#xBFAA #x8755 -#xBFAB #x8FB1 -#xBFAC #x5C3B -#xBFAD #x4F38 -#xBFAE #x4FE1 -#xBFAF #x4FB5 -#xBFB0 #x5507 -#xBFB1 #x5A20 -#xBFB2 #x5BDD -#xBFB3 #x5BE9 -#xBFB4 #x5FC3 -#xBFB5 #x614E -#xBFB6 #x632F -#xBFB7 #x65B0 -#xBFB8 #x664B -#xBFB9 #x68EE -#xBFBA #x699B -#xBFBB #x6D78 -#xBFBC #x6DF1 -#xBFBD #x7533 -#xBFBE #x75B9 -#xBFBF #x771F -#xBFC0 #x795E -#xBFC1 #x79E6 -#xBFC2 #x7D33 -#xBFC3 #x81E3 -#xBFC4 #x82AF -#xBFC5 #x85AA -#xBFC6 #x89AA -#xBFC7 #x8A3A -#xBFC8 #x8EAB -#xBFC9 #x8F9B -#xBFCA #x9032 -#xBFCB #x91DD -#xBFCC #x9707 -#xBFCD #x4EBA -#xBFCE #x4EC1 -#xBFCF #x5203 -#xBFD0 #x5875 -#xBFD1 #x58EC -#xBFD2 #x5C0B -#xBFD3 #x751A -#xBFD4 #x5C3D -#xBFD5 #x814E -#xBFD6 #x8A0A -#xBFD7 #x8FC5 -#xBFD8 #x9663 -#xBFD9 #x976D -#xBFDA #x7B25 -#xBFDB #x8ACF -#xBFDC #x9808 -#xBFDD #x9162 -#xBFDE #x56F3 -#xBFDF #x53A8 -#xBFE0 #x9017 -#xBFE1 #x5439 -#xBFE2 #x5782 -#xBFE3 #x5E25 -#xBFE4 #x63A8 -#xBFE5 #x6C34 -#xBFE6 #x708A -#xBFE7 #x7761 -#xBFE8 #x7C8B -#xBFE9 #x7FE0 -#xBFEA #x8870 -#xBFEB #x9042 -#xBFEC #x9154 -#xBFED #x9310 -#xBFEE #x9318 -#xBFEF #x968F -#xBFF0 #x745E -#xBFF1 #x9AC4 -#xBFF2 #x5D07 -#xBFF3 #x5D69 -#xBFF4 #x6570 -#xBFF5 #x67A2 -#xBFF6 #x8DA8 -#xBFF7 #x96DB -#xBFF8 #x636E -#xBFF9 #x6749 -#xBFFA #x6919 -#xBFFB #x83C5 -#xBFFC #x9817 -#xBFFD #x96C0 -#xBFFE #x88FE -#xC0A1 #x6F84 -#xC0A2 #x647A -#xC0A3 #x5BF8 -#xC0A4 #x4E16 -#xC0A5 #x702C -#xC0A6 #x755D -#xC0A7 #x662F -#xC0A8 #x51C4 -#xC0A9 #x5236 -#xC0AA #x52E2 -#xC0AB #x59D3 -#xC0AC #x5F81 -#xC0AD #x6027 -#xC0AE #x6210 -#xC0AF #x653F -#xC0B0 #x6574 -#xC0B1 #x661F -#xC0B2 #x6674 -#xC0B3 #x68F2 -#xC0B4 #x6816 -#xC0B5 #x6B63 -#xC0B6 #x6E05 -#xC0B7 #x7272 -#xC0B8 #x751F -#xC0B9 #x76DB -#xC0BA #x7CBE -#xC0BB #x8056 -#xC0BC #x58F0 -#xC0BD #x88FD -#xC0BE #x897F -#xC0BF #x8AA0 -#xC0C0 #x8A93 -#xC0C1 #x8ACB -#xC0C2 #x901D -#xC0C3 #x9192 -#xC0C4 #x9752 -#xC0C5 #x9759 -#xC0C6 #x6589 -#xC0C7 #x7A0E -#xC0C8 #x8106 -#xC0C9 #x96BB -#xC0CA #x5E2D -#xC0CB #x60DC -#xC0CC #x621A -#xC0CD #x65A5 -#xC0CE #x6614 -#xC0CF #x6790 -#xC0D0 #x77F3 -#xC0D1 #x7A4D -#xC0D2 #x7C4D -#xC0D3 #x7E3E -#xC0D4 #x810A -#xC0D5 #x8CAC -#xC0D6 #x8D64 -#xC0D7 #x8DE1 -#xC0D8 #x8E5F -#xC0D9 #x78A9 -#xC0DA #x5207 -#xC0DB #x62D9 -#xC0DC #x63A5 -#xC0DD #x6442 -#xC0DE #x6298 -#xC0DF #x8A2D -#xC0E0 #x7A83 -#xC0E1 #x7BC0 -#xC0E2 #x8AAC -#xC0E3 #x96EA -#xC0E4 #x7D76 -#xC0E5 #x820C -#xC0E6 #x8749 -#xC0E7 #x4ED9 -#xC0E8 #x5148 -#xC0E9 #x5343 -#xC0EA #x5360 -#xC0EB #x5BA3 -#xC0EC #x5C02 -#xC0ED #x5C16 -#xC0EE #x5DDD -#xC0EF #x6226 -#xC0F0 #x6247 -#xC0F1 #x64B0 -#xC0F2 #x6813 -#xC0F3 #x6834 -#xC0F4 #x6CC9 -#xC0F5 #x6D45 -#xC0F6 #x6D17 -#xC0F7 #x67D3 -#xC0F8 #x6F5C -#xC0F9 #x714E -#xC0FA #x717D -#xC0FB #x65CB -#xC0FC #x7A7F -#xC0FD #x7BAD -#xC0FE #x7DDA -#xC1A1 #x7E4A -#xC1A2 #x7FA8 -#xC1A3 #x817A -#xC1A4 #x821B -#xC1A5 #x8239 -#xC1A6 #x85A6 -#xC1A7 #x8A6E -#xC1A8 #x8CCE -#xC1A9 #x8DF5 -#xC1AA #x9078 -#xC1AB #x9077 -#xC1AC #x92AD -#xC1AD #x9291 -#xC1AE #x9583 -#xC1AF #x9BAE -#xC1B0 #x524D -#xC1B1 #x5584 -#xC1B2 #x6F38 -#xC1B3 #x7136 -#xC1B4 #x5168 -#xC1B5 #x7985 -#xC1B6 #x7E55 -#xC1B7 #x81B3 -#xC1B8 #x7CCE -#xC1B9 #x564C -#xC1BA #x5851 -#xC1BB #x5CA8 -#xC1BC #x63AA -#xC1BD #x66FE -#xC1BE #x66FD -#xC1BF #x695A -#xC1C0 #x72D9 -#xC1C1 #x758F -#xC1C2 #x758E -#xC1C3 #x790E -#xC1C4 #x7956 -#xC1C5 #x79DF -#xC1C6 #x7C97 -#xC1C7 #x7D20 -#xC1C8 #x7D44 -#xC1C9 #x8607 -#xC1CA #x8A34 -#xC1CB #x963B -#xC1CC #x9061 -#xC1CD #x9F20 -#xC1CE #x50E7 -#xC1CF #x5275 -#xC1D0 #x53CC -#xC1D1 #x53E2 -#xC1D2 #x5009 -#xC1D3 #x55AA -#xC1D4 #x58EE -#xC1D5 #x594F -#xC1D6 #x723D -#xC1D7 #x5B8B -#xC1D8 #x5C64 -#xC1D9 #x531D -#xC1DA #x60E3 -#xC1DB #x60F3 -#xC1DC #x635C -#xC1DD #x6383 -#xC1DE #x633F -#xC1DF #x63BB -#xC1E0 #x64CD -#xC1E1 #x65E9 -#xC1E2 #x66F9 -#xC1E3 #x5DE3 -#xC1E4 #x69CD -#xC1E5 #x69FD -#xC1E6 #x6F15 -#xC1E7 #x71E5 -#xC1E8 #x4E89 -#xC1E9 #x75E9 -#xC1EA #x76F8 -#xC1EB #x7A93 -#xC1EC #x7CDF -#xC1ED #x7DCF -#xC1EE #x7D9C -#xC1EF #x8061 -#xC1F0 #x8349 -#xC1F1 #x8358 -#xC1F2 #x846C -#xC1F3 #x84BC -#xC1F4 #x85FB -#xC1F5 #x88C5 -#xC1F6 #x8D70 -#xC1F7 #x9001 -#xC1F8 #x906D -#xC1F9 #x9397 -#xC1FA #x971C -#xC1FB #x9A12 -#xC1FC #x50CF -#xC1FD #x5897 -#xC1FE #x618E -#xC2A1 #x81D3 -#xC2A2 #x8535 -#xC2A3 #x8D08 -#xC2A4 #x9020 -#xC2A5 #x4FC3 -#xC2A6 #x5074 -#xC2A7 #x5247 -#xC2A8 #x5373 -#xC2A9 #x606F -#xC2AA #x6349 -#xC2AB #x675F -#xC2AC #x6E2C -#xC2AD #x8DB3 -#xC2AE #x901F -#xC2AF #x4FD7 -#xC2B0 #x5C5E -#xC2B1 #x8CCA -#xC2B2 #x65CF -#xC2B3 #x7D9A -#xC2B4 #x5352 -#xC2B5 #x8896 -#xC2B6 #x5176 -#xC2B7 #x63C3 -#xC2B8 #x5B58 -#xC2B9 #x5B6B -#xC2BA #x5C0A -#xC2BB #x640D -#xC2BC #x6751 -#xC2BD #x905C -#xC2BE #x4ED6 -#xC2BF #x591A -#xC2C0 #x592A -#xC2C1 #x6C70 -#xC2C2 #x8A51 -#xC2C3 #x553E -#xC2C4 #x5815 -#xC2C5 #x59A5 -#xC2C6 #x60F0 -#xC2C7 #x6253 -#xC2C8 #x67C1 -#xC2C9 #x8235 -#xC2CA #x6955 -#xC2CB #x9640 -#xC2CC #x99C4 -#xC2CD #x9A28 -#xC2CE #x4F53 -#xC2CF #x5806 -#xC2D0 #x5BFE -#xC2D1 #x8010 -#xC2D2 #x5CB1 -#xC2D3 #x5E2F -#xC2D4 #x5F85 -#xC2D5 #x6020 -#xC2D6 #x614B -#xC2D7 #x6234 -#xC2D8 #x66FF -#xC2D9 #x6CF0 -#xC2DA #x6EDE -#xC2DB #x80CE -#xC2DC #x817F -#xC2DD #x82D4 -#xC2DE #x888B -#xC2DF #x8CB8 -#xC2E0 #x9000 -#xC2E1 #x902E -#xC2E2 #x968A -#xC2E3 #x9EDB -#xC2E4 #x9BDB -#xC2E5 #x4EE3 -#xC2E6 #x53F0 -#xC2E7 #x5927 -#xC2E8 #x7B2C -#xC2E9 #x918D -#xC2EA #x984C -#xC2EB #x9DF9 -#xC2EC #x6EDD -#xC2ED #x7027 -#xC2EE #x5353 -#xC2EF #x5544 -#xC2F0 #x5B85 -#xC2F1 #x6258 -#xC2F2 #x629E -#xC2F3 #x62D3 -#xC2F4 #x6CA2 -#xC2F5 #x6FEF -#xC2F6 #x7422 -#xC2F7 #x8A17 -#xC2F8 #x9438 -#xC2F9 #x6FC1 -#xC2FA #x8AFE -#xC2FB #x8338 -#xC2FC #x51E7 -#xC2FD #x86F8 -#xC2FE #x53EA -#xC3A1 #x53E9 -#xC3A2 #x4F46 -#xC3A3 #x9054 -#xC3A4 #x8FB0 -#xC3A5 #x596A -#xC3A6 #x8131 -#xC3A7 #x5DFD -#xC3A8 #x7AEA -#xC3A9 #x8FBF -#xC3AA #x68DA -#xC3AB #x8C37 -#xC3AC #x72F8 -#xC3AD #x9C48 -#xC3AE #x6A3D -#xC3AF #x8AB0 -#xC3B0 #x4E39 -#xC3B1 #x5358 -#xC3B2 #x5606 -#xC3B3 #x5766 -#xC3B4 #x62C5 -#xC3B5 #x63A2 -#xC3B6 #x65E6 -#xC3B7 #x6B4E -#xC3B8 #x6DE1 -#xC3B9 #x6E5B -#xC3BA #x70AD -#xC3BB #x77ED -#xC3BC #x7AEF -#xC3BD #x7BAA -#xC3BE #x7DBB -#xC3BF #x803D -#xC3C0 #x80C6 -#xC3C1 #x86CB -#xC3C2 #x8A95 -#xC3C3 #x935B -#xC3C4 #x56E3 -#xC3C5 #x58C7 -#xC3C6 #x5F3E -#xC3C7 #x65AD -#xC3C8 #x6696 -#xC3C9 #x6A80 -#xC3CA #x6BB5 -#xC3CB #x7537 -#xC3CC #x8AC7 -#xC3CD #x5024 -#xC3CE #x77E5 -#xC3CF #x5730 -#xC3D0 #x5F1B -#xC3D1 #x6065 -#xC3D2 #x667A -#xC3D3 #x6C60 -#xC3D4 #x75F4 -#xC3D5 #x7A1A -#xC3D6 #x7F6E -#xC3D7 #x81F4 -#xC3D8 #x8718 -#xC3D9 #x9045 -#xC3DA #x99B3 -#xC3DB #x7BC9 -#xC3DC #x755C -#xC3DD #x7AF9 -#xC3DE #x7B51 -#xC3DF #x84C4 -#xC3E0 #x9010 -#xC3E1 #x79E9 -#xC3E2 #x7A92 -#xC3E3 #x8336 -#xC3E4 #x5AE1 -#xC3E5 #x7740 -#xC3E6 #x4E2D -#xC3E7 #x4EF2 -#xC3E8 #x5B99 -#xC3E9 #x5FE0 -#xC3EA #x62BD -#xC3EB #x663C -#xC3EC #x67F1 -#xC3ED #x6CE8 -#xC3EE #x866B -#xC3EF #x8877 -#xC3F0 #x8A3B -#xC3F1 #x914E -#xC3F2 #x92F3 -#xC3F3 #x99D0 -#xC3F4 #x6A17 -#xC3F5 #x7026 -#xC3F6 #x732A -#xC3F7 #x82E7 -#xC3F8 #x8457 -#xC3F9 #x8CAF -#xC3FA #x4E01 -#xC3FB #x5146 -#xC3FC #x51CB -#xC3FD #x558B -#xC3FE #x5BF5 -#xC4A1 #x5E16 -#xC4A2 #x5E33 -#xC4A3 #x5E81 -#xC4A4 #x5F14 -#xC4A5 #x5F35 -#xC4A6 #x5F6B -#xC4A7 #x5FB4 -#xC4A8 #x61F2 -#xC4A9 #x6311 -#xC4AA #x66A2 -#xC4AB #x671D -#xC4AC #x6F6E -#xC4AD #x7252 -#xC4AE #x753A -#xC4AF #x773A -#xC4B0 #x8074 -#xC4B1 #x8139 -#xC4B2 #x8178 -#xC4B3 #x8776 -#xC4B4 #x8ABF -#xC4B5 #x8ADC -#xC4B6 #x8D85 -#xC4B7 #x8DF3 -#xC4B8 #x929A -#xC4B9 #x9577 -#xC4BA #x9802 -#xC4BB #x9CE5 -#xC4BC #x52C5 -#xC4BD #x6357 -#xC4BE #x76F4 -#xC4BF #x6715 -#xC4C0 #x6C88 -#xC4C1 #x73CD -#xC4C2 #x8CC3 -#xC4C3 #x93AE -#xC4C4 #x9673 -#xC4C5 #x6D25 -#xC4C6 #x589C -#xC4C7 #x690E -#xC4C8 #x69CC -#xC4C9 #x8FFD -#xC4CA #x939A -#xC4CB #x75DB -#xC4CC #x901A -#xC4CD #x585A -#xC4CE #x6802 -#xC4CF #x63B4 -#xC4D0 #x69FB -#xC4D1 #x4F43 -#xC4D2 #x6F2C -#xC4D3 #x67D8 -#xC4D4 #x8FBB -#xC4D5 #x8526 -#xC4D6 #x7DB4 -#xC4D7 #x9354 -#xC4D8 #x693F -#xC4D9 #x6F70 -#xC4DA #x576A -#xC4DB #x58F7 -#xC4DC #x5B2C -#xC4DD #x7D2C -#xC4DE #x722A -#xC4DF #x540A -#xC4E0 #x91E3 -#xC4E1 #x9DB4 -#xC4E2 #x4EAD -#xC4E3 #x4F4E -#xC4E4 #x505C -#xC4E5 #x5075 -#xC4E6 #x5243 -#xC4E7 #x8C9E -#xC4E8 #x5448 -#xC4E9 #x5824 -#xC4EA #x5B9A -#xC4EB #x5E1D -#xC4EC #x5E95 -#xC4ED #x5EAD -#xC4EE #x5EF7 -#xC4EF #x5F1F -#xC4F0 #x608C -#xC4F1 #x62B5 -#xC4F2 #x633A -#xC4F3 #x63D0 -#xC4F4 #x68AF -#xC4F5 #x6C40 -#xC4F6 #x7887 -#xC4F7 #x798E -#xC4F8 #x7A0B -#xC4F9 #x7DE0 -#xC4FA #x8247 -#xC4FB #x8A02 -#xC4FC #x8AE6 -#xC4FD #x8E44 -#xC4FE #x9013 -#xC5A1 #x90B8 -#xC5A2 #x912D -#xC5A3 #x91D8 -#xC5A4 #x9F0E -#xC5A5 #x6CE5 -#xC5A6 #x6458 -#xC5A7 #x64E2 -#xC5A8 #x6575 -#xC5A9 #x6EF4 -#xC5AA #x7684 -#xC5AB #x7B1B -#xC5AC #x9069 -#xC5AD #x93D1 -#xC5AE #x6EBA -#xC5AF #x54F2 -#xC5B0 #x5FB9 -#xC5B1 #x64A4 -#xC5B2 #x8F4D -#xC5B3 #x8FED -#xC5B4 #x9244 -#xC5B5 #x5178 -#xC5B6 #x586B -#xC5B7 #x5929 -#xC5B8 #x5C55 -#xC5B9 #x5E97 -#xC5BA #x6DFB -#xC5BB #x7E8F -#xC5BC #x751C -#xC5BD #x8CBC -#xC5BE #x8EE2 -#xC5BF #x985B -#xC5C0 #x70B9 -#xC5C1 #x4F1D -#xC5C2 #x6BBF -#xC5C3 #x6FB1 -#xC5C4 #x7530 -#xC5C5 #x96FB -#xC5C6 #x514E -#xC5C7 #x5410 -#xC5C8 #x5835 -#xC5C9 #x5857 -#xC5CA #x59AC -#xC5CB #x5C60 -#xC5CC #x5F92 -#xC5CD #x6597 -#xC5CE #x675C -#xC5CF #x6E21 -#xC5D0 #x767B -#xC5D1 #x83DF -#xC5D2 #x8CED -#xC5D3 #x9014 -#xC5D4 #x90FD -#xC5D5 #x934D -#xC5D6 #x7825 -#xC5D7 #x783A -#xC5D8 #x52AA -#xC5D9 #x5EA6 -#xC5DA #x571F -#xC5DB #x5974 -#xC5DC #x6012 -#xC5DD #x5012 -#xC5DE #x515A -#xC5DF #x51AC -#xC5E0 #x51CD -#xC5E1 #x5200 -#xC5E2 #x5510 -#xC5E3 #x5854 -#xC5E4 #x5858 -#xC5E5 #x5957 -#xC5E6 #x5B95 -#xC5E7 #x5CF6 -#xC5E8 #x5D8B -#xC5E9 #x60BC -#xC5EA #x6295 -#xC5EB #x642D -#xC5EC #x6771 -#xC5ED #x6843 -#xC5EE #x68BC -#xC5EF #x68DF -#xC5F0 #x76D7 -#xC5F1 #x6DD8 -#xC5F2 #x6E6F -#xC5F3 #x6D9B -#xC5F4 #x706F -#xC5F5 #x71C8 -#xC5F6 #x5F53 -#xC5F7 #x75D8 -#xC5F8 #x7977 -#xC5F9 #x7B49 -#xC5FA #x7B54 -#xC5FB #x7B52 -#xC5FC #x7CD6 -#xC5FD #x7D71 -#xC5FE #x5230 -#xC6A1 #x8463 -#xC6A2 #x8569 -#xC6A3 #x85E4 -#xC6A4 #x8A0E -#xC6A5 #x8B04 -#xC6A6 #x8C46 -#xC6A7 #x8E0F -#xC6A8 #x9003 -#xC6A9 #x900F -#xC6AA #x9419 -#xC6AB #x9676 -#xC6AC #x982D -#xC6AD #x9A30 -#xC6AE #x95D8 -#xC6AF #x50CD -#xC6B0 #x52D5 -#xC6B1 #x540C -#xC6B2 #x5802 -#xC6B3 #x5C0E -#xC6B4 #x61A7 -#xC6B5 #x649E -#xC6B6 #x6D1E -#xC6B7 #x77B3 -#xC6B8 #x7AE5 -#xC6B9 #x80F4 -#xC6BA #x8404 -#xC6BB #x9053 -#xC6BC #x9285 -#xC6BD #x5CE0 -#xC6BE #x9D07 -#xC6BF #x533F -#xC6C0 #x5F97 -#xC6C1 #x5FB3 -#xC6C2 #x6D9C -#xC6C3 #x7279 -#xC6C4 #x7763 -#xC6C5 #x79BF -#xC6C6 #x7BE4 -#xC6C7 #x6BD2 -#xC6C8 #x72EC -#xC6C9 #x8AAD -#xC6CA #x6803 -#xC6CB #x6A61 -#xC6CC #x51F8 -#xC6CD #x7A81 -#xC6CE #x6934 -#xC6CF #x5C4A -#xC6D0 #x9CF6 -#xC6D1 #x82EB -#xC6D2 #x5BC5 -#xC6D3 #x9149 -#xC6D4 #x701E -#xC6D5 #x5678 -#xC6D6 #x5C6F -#xC6D7 #x60C7 -#xC6D8 #x6566 -#xC6D9 #x6C8C -#xC6DA #x8C5A -#xC6DB #x9041 -#xC6DC #x9813 -#xC6DD #x5451 -#xC6DE #x66C7 -#xC6DF #x920D -#xC6E0 #x5948 -#xC6E1 #x90A3 -#xC6E2 #x5185 -#xC6E3 #x4E4D -#xC6E4 #x51EA -#xC6E5 #x8599 -#xC6E6 #x8B0E -#xC6E7 #x7058 -#xC6E8 #x637A -#xC6E9 #x934B -#xC6EA #x6962 -#xC6EB #x99B4 -#xC6EC #x7E04 -#xC6ED #x7577 -#xC6EE #x5357 -#xC6EF #x6960 -#xC6F0 #x8EDF -#xC6F1 #x96E3 -#xC6F2 #x6C5D -#xC6F3 #x4E8C -#xC6F4 #x5C3C -#xC6F5 #x5F10 -#xC6F6 #x8FE9 -#xC6F7 #x5302 -#xC6F8 #x8CD1 -#xC6F9 #x8089 -#xC6FA #x8679 -#xC6FB #x5EFF -#xC6FC #x65E5 -#xC6FD #x4E73 -#xC6FE #x5165 -#xC7A1 #x5982 -#xC7A2 #x5C3F -#xC7A3 #x97EE -#xC7A4 #x4EFB -#xC7A5 #x598A -#xC7A6 #x5FCD -#xC7A7 #x8A8D -#xC7A8 #x6FE1 -#xC7A9 #x79B0 -#xC7AA #x7962 -#xC7AB #x5BE7 -#xC7AC #x8471 -#xC7AD #x732B -#xC7AE #x71B1 -#xC7AF #x5E74 -#xC7B0 #x5FF5 -#xC7B1 #x637B -#xC7B2 #x649A -#xC7B3 #x71C3 -#xC7B4 #x7C98 -#xC7B5 #x4E43 -#xC7B6 #x5EFC -#xC7B7 #x4E4B -#xC7B8 #x57DC -#xC7B9 #x56A2 -#xC7BA #x60A9 -#xC7BB #x6FC3 -#xC7BC #x7D0D -#xC7BD #x80FD -#xC7BE #x8133 -#xC7BF #x81BF -#xC7C0 #x8FB2 -#xC7C1 #x8997 -#xC7C2 #x86A4 -#xC7C3 #x5DF4 -#xC7C4 #x628A -#xC7C5 #x64AD -#xC7C6 #x8987 -#xC7C7 #x6777 -#xC7C8 #x6CE2 -#xC7C9 #x6D3E -#xC7CA #x7436 -#xC7CB #x7834 -#xC7CC #x5A46 -#xC7CD #x7F75 -#xC7CE #x82AD -#xC7CF #x99AC -#xC7D0 #x4FF3 -#xC7D1 #x5EC3 -#xC7D2 #x62DD -#xC7D3 #x6392 -#xC7D4 #x6557 -#xC7D5 #x676F -#xC7D6 #x76C3 -#xC7D7 #x724C -#xC7D8 #x80CC -#xC7D9 #x80BA -#xC7DA #x8F29 -#xC7DB #x914D -#xC7DC #x500D -#xC7DD #x57F9 -#xC7DE #x5A92 -#xC7DF #x6885 -#xC7E0 #x6973 -#xC7E1 #x7164 -#xC7E2 #x72FD -#xC7E3 #x8CB7 -#xC7E4 #x58F2 -#xC7E5 #x8CE0 -#xC7E6 #x966A -#xC7E7 #x9019 -#xC7E8 #x877F -#xC7E9 #x79E4 -#xC7EA #x77E7 -#xC7EB #x8429 -#xC7EC #x4F2F -#xC7ED #x5265 -#xC7EE #x535A -#xC7EF #x62CD -#xC7F0 #x67CF -#xC7F1 #x6CCA -#xC7F2 #x767D -#xC7F3 #x7B94 -#xC7F4 #x7C95 -#xC7F5 #x8236 -#xC7F6 #x8584 -#xC7F7 #x8FEB -#xC7F8 #x66DD -#xC7F9 #x6F20 -#xC7FA #x7206 -#xC7FB #x7E1B -#xC7FC #x83AB -#xC7FD #x99C1 -#xC7FE #x9EA6 -#xC8A1 #x51FD -#xC8A2 #x7BB1 -#xC8A3 #x7872 -#xC8A4 #x7BB8 -#xC8A5 #x8087 -#xC8A6 #x7B48 -#xC8A7 #x6AE8 -#xC8A8 #x5E61 -#xC8A9 #x808C -#xC8AA #x7551 -#xC8AB #x7560 -#xC8AC #x516B -#xC8AD #x9262 -#xC8AE #x6E8C -#xC8AF #x767A -#xC8B0 #x9197 -#xC8B1 #x9AEA -#xC8B2 #x4F10 -#xC8B3 #x7F70 -#xC8B4 #x629C -#xC8B5 #x7B4F -#xC8B6 #x95A5 -#xC8B7 #x9CE9 -#xC8B8 #x567A -#xC8B9 #x5859 -#xC8BA #x86E4 -#xC8BB #x96BC -#xC8BC #x4F34 -#xC8BD #x5224 -#xC8BE #x534A -#xC8BF #x53CD -#xC8C0 #x53DB -#xC8C1 #x5E06 -#xC8C2 #x642C -#xC8C3 #x6591 -#xC8C4 #x677F -#xC8C5 #x6C3E -#xC8C6 #x6C4E -#xC8C7 #x7248 -#xC8C8 #x72AF -#xC8C9 #x73ED -#xC8CA #x7554 -#xC8CB #x7E41 -#xC8CC #x822C -#xC8CD #x85E9 -#xC8CE #x8CA9 -#xC8CF #x7BC4 -#xC8D0 #x91C6 -#xC8D1 #x7169 -#xC8D2 #x9812 -#xC8D3 #x98EF -#xC8D4 #x633D -#xC8D5 #x6669 -#xC8D6 #x756A -#xC8D7 #x76E4 -#xC8D8 #x78D0 -#xC8D9 #x8543 -#xC8DA #x86EE -#xC8DB #x532A -#xC8DC #x5351 -#xC8DD #x5426 -#xC8DE #x5983 -#xC8DF #x5E87 -#xC8E0 #x5F7C -#xC8E1 #x60B2 -#xC8E2 #x6249 -#xC8E3 #x6279 -#xC8E4 #x62AB -#xC8E5 #x6590 -#xC8E6 #x6BD4 -#xC8E7 #x6CCC -#xC8E8 #x75B2 -#xC8E9 #x76AE -#xC8EA #x7891 -#xC8EB #x79D8 -#xC8EC #x7DCB -#xC8ED #x7F77 -#xC8EE #x80A5 -#xC8EF #x88AB -#xC8F0 #x8AB9 -#xC8F1 #x8CBB -#xC8F2 #x907F -#xC8F3 #x975E -#xC8F4 #x98DB -#xC8F5 #x6A0B -#xC8F6 #x7C38 -#xC8F7 #x5099 -#xC8F8 #x5C3E -#xC8F9 #x5FAE -#xC8FA #x6787 -#xC8FB #x6BD8 -#xC8FC #x7435 -#xC8FD #x7709 -#xC8FE #x7F8E -#xC9A1 #x9F3B -#xC9A2 #x67CA -#xC9A3 #x7A17 -#xC9A4 #x5339 -#xC9A5 #x758B -#xC9A6 #x9AED -#xC9A7 #x5F66 -#xC9A8 #x819D -#xC9A9 #x83F1 -#xC9AA #x8098 -#xC9AB #x5F3C -#xC9AC #x5FC5 -#xC9AD #x7562 -#xC9AE #x7B46 -#xC9AF #x903C -#xC9B0 #x6867 -#xC9B1 #x59EB -#xC9B2 #x5A9B -#xC9B3 #x7D10 -#xC9B4 #x767E -#xC9B5 #x8B2C -#xC9B6 #x4FF5 -#xC9B7 #x5F6A -#xC9B8 #x6A19 -#xC9B9 #x6C37 -#xC9BA #x6F02 -#xC9BB #x74E2 -#xC9BC #x7968 -#xC9BD #x8868 -#xC9BE #x8A55 -#xC9BF #x8C79 -#xC9C0 #x5EDF -#xC9C1 #x63CF -#xC9C2 #x75C5 -#xC9C3 #x79D2 -#xC9C4 #x82D7 -#xC9C5 #x9328 -#xC9C6 #x92F2 -#xC9C7 #x849C -#xC9C8 #x86ED -#xC9C9 #x9C2D -#xC9CA #x54C1 -#xC9CB #x5F6C -#xC9CC #x658C -#xC9CD #x6D5C -#xC9CE #x7015 -#xC9CF #x8CA7 -#xC9D0 #x8CD3 -#xC9D1 #x983B -#xC9D2 #x654F -#xC9D3 #x74F6 -#xC9D4 #x4E0D -#xC9D5 #x4ED8 -#xC9D6 #x57E0 -#xC9D7 #x592B -#xC9D8 #x5A66 -#xC9D9 #x5BCC -#xC9DA #x51A8 -#xC9DB #x5E03 -#xC9DC #x5E9C -#xC9DD #x6016 -#xC9DE #x6276 -#xC9DF #x6577 -#xC9E0 #x65A7 -#xC9E1 #x666E -#xC9E2 #x6D6E -#xC9E3 #x7236 -#xC9E4 #x7B26 -#xC9E5 #x8150 -#xC9E6 #x819A -#xC9E7 #x8299 -#xC9E8 #x8B5C -#xC9E9 #x8CA0 -#xC9EA #x8CE6 -#xC9EB #x8D74 -#xC9EC #x961C -#xC9ED #x9644 -#xC9EE #x4FAE -#xC9EF #x64AB -#xC9F0 #x6B66 -#xC9F1 #x821E -#xC9F2 #x8461 -#xC9F3 #x856A -#xC9F4 #x90E8 -#xC9F5 #x5C01 -#xC9F6 #x6953 -#xC9F7 #x98A8 -#xC9F8 #x847A -#xC9F9 #x8557 -#xC9FA #x4F0F -#xC9FB #x526F -#xC9FC #x5FA9 -#xC9FD #x5E45 -#xC9FE #x670D -#xCAA1 #x798F -#xCAA2 #x8179 -#xCAA3 #x8907 -#xCAA4 #x8986 -#xCAA5 #x6DF5 -#xCAA6 #x5F17 -#xCAA7 #x6255 -#xCAA8 #x6CB8 -#xCAA9 #x4ECF -#xCAAA #x7269 -#xCAAB #x9B92 -#xCAAC #x5206 -#xCAAD #x543B -#xCAAE #x5674 -#xCAAF #x58B3 -#xCAB0 #x61A4 -#xCAB1 #x626E -#xCAB2 #x711A -#xCAB3 #x596E -#xCAB4 #x7C89 -#xCAB5 #x7CDE -#xCAB6 #x7D1B -#xCAB7 #x96F0 -#xCAB8 #x6587 -#xCAB9 #x805E -#xCABA #x4E19 -#xCABB #x4F75 -#xCABC #x5175 -#xCABD #x5840 -#xCABE #x5E63 -#xCABF #x5E73 -#xCAC0 #x5F0A -#xCAC1 #x67C4 -#xCAC2 #x4E26 -#xCAC3 #x853D -#xCAC4 #x9589 -#xCAC5 #x965B -#xCAC6 #x7C73 -#xCAC7 #x9801 -#xCAC8 #x50FB -#xCAC9 #x58C1 -#xCACA #x7656 -#xCACB #x78A7 -#xCACC #x5225 -#xCACD #x77A5 -#xCACE #x8511 -#xCACF #x7B86 -#xCAD0 #x504F -#xCAD1 #x5909 -#xCAD2 #x7247 -#xCAD3 #x7BC7 -#xCAD4 #x7DE8 -#xCAD5 #x8FBA -#xCAD6 #x8FD4 -#xCAD7 #x904D -#xCAD8 #x4FBF -#xCAD9 #x52C9 -#xCADA #x5A29 -#xCADB #x5F01 -#xCADC #x97AD -#xCADD #x4FDD -#xCADE #x8217 -#xCADF #x92EA -#xCAE0 #x5703 -#xCAE1 #x6355 -#xCAE2 #x6B69 -#xCAE3 #x752B -#xCAE4 #x88DC -#xCAE5 #x8F14 -#xCAE6 #x7A42 -#xCAE7 #x52DF -#xCAE8 #x5893 -#xCAE9 #x6155 -#xCAEA #x620A -#xCAEB #x66AE -#xCAEC #x6BCD -#xCAED #x7C3F -#xCAEE #x83E9 -#xCAEF #x5023 -#xCAF0 #x4FF8 -#xCAF1 #x5305 -#xCAF2 #x5446 -#xCAF3 #x5831 -#xCAF4 #x5949 -#xCAF5 #x5B9D -#xCAF6 #x5CF0 -#xCAF7 #x5CEF -#xCAF8 #x5D29 -#xCAF9 #x5E96 -#xCAFA #x62B1 -#xCAFB #x6367 -#xCAFC #x653E -#xCAFD #x65B9 -#xCAFE #x670B -#xCBA1 #x6CD5 -#xCBA2 #x6CE1 -#xCBA3 #x70F9 -#xCBA4 #x7832 -#xCBA5 #x7E2B -#xCBA6 #x80DE -#xCBA7 #x82B3 -#xCBA8 #x840C -#xCBA9 #x84EC -#xCBAA #x8702 -#xCBAB #x8912 -#xCBAC #x8A2A -#xCBAD #x8C4A -#xCBAE #x90A6 -#xCBAF #x92D2 -#xCBB0 #x98FD -#xCBB1 #x9CF3 -#xCBB2 #x9D6C -#xCBB3 #x4E4F -#xCBB4 #x4EA1 -#xCBB5 #x508D -#xCBB6 #x5256 -#xCBB7 #x574A -#xCBB8 #x59A8 -#xCBB9 #x5E3D -#xCBBA #x5FD8 -#xCBBB #x5FD9 -#xCBBC #x623F -#xCBBD #x66B4 -#xCBBE #x671B -#xCBBF #x67D0 -#xCBC0 #x68D2 -#xCBC1 #x5192 -#xCBC2 #x7D21 -#xCBC3 #x80AA -#xCBC4 #x81A8 -#xCBC5 #x8B00 -#xCBC6 #x8C8C -#xCBC7 #x8CBF -#xCBC8 #x927E -#xCBC9 #x9632 -#xCBCA #x5420 -#xCBCB #x982C -#xCBCC #x5317 -#xCBCD #x50D5 -#xCBCE #x535C -#xCBCF #x58A8 -#xCBD0 #x64B2 -#xCBD1 #x6734 -#xCBD2 #x7267 -#xCBD3 #x7766 -#xCBD4 #x7A46 -#xCBD5 #x91E6 -#xCBD6 #x52C3 -#xCBD7 #x6CA1 -#xCBD8 #x6B86 -#xCBD9 #x5800 -#xCBDA #x5E4C -#xCBDB #x5954 -#xCBDC #x672C -#xCBDD #x7FFB -#xCBDE #x51E1 -#xCBDF #x76C6 -#xCBE0 #x6469 -#xCBE1 #x78E8 -#xCBE2 #x9B54 -#xCBE3 #x9EBB -#xCBE4 #x57CB -#xCBE5 #x59B9 -#xCBE6 #x6627 -#xCBE7 #x679A -#xCBE8 #x6BCE -#xCBE9 #x54E9 -#xCBEA #x69D9 -#xCBEB #x5E55 -#xCBEC #x819C -#xCBED #x6795 -#xCBEE #x9BAA -#xCBEF #x67FE -#xCBF0 #x9C52 -#xCBF1 #x685D -#xCBF2 #x4EA6 -#xCBF3 #x4FE3 -#xCBF4 #x53C8 -#xCBF5 #x62B9 -#xCBF6 #x672B -#xCBF7 #x6CAB -#xCBF8 #x8FC4 -#xCBF9 #x4FAD -#xCBFA #x7E6D -#xCBFB #x9EBF -#xCBFC #x4E07 -#xCBFD #x6162 -#xCBFE #x6E80 -#xCCA1 #x6F2B -#xCCA2 #x8513 -#xCCA3 #x5473 -#xCCA4 #x672A -#xCCA5 #x9B45 -#xCCA6 #x5DF3 -#xCCA7 #x7B95 -#xCCA8 #x5CAC -#xCCA9 #x5BC6 -#xCCAA #x871C -#xCCAB #x6E4A -#xCCAC #x84D1 -#xCCAD #x7A14 -#xCCAE #x8108 -#xCCAF #x5999 -#xCCB0 #x7C8D -#xCCB1 #x6C11 -#xCCB2 #x7720 -#xCCB3 #x52D9 -#xCCB4 #x5922 -#xCCB5 #x7121 -#xCCB6 #x725F -#xCCB7 #x77DB -#xCCB8 #x9727 -#xCCB9 #x9D61 -#xCCBA #x690B -#xCCBB #x5A7F -#xCCBC #x5A18 -#xCCBD #x51A5 -#xCCBE #x540D -#xCCBF #x547D -#xCCC0 #x660E -#xCCC1 #x76DF -#xCCC2 #x8FF7 -#xCCC3 #x9298 -#xCCC4 #x9CF4 -#xCCC5 #x59EA -#xCCC6 #x725D -#xCCC7 #x6EC5 -#xCCC8 #x514D -#xCCC9 #x68C9 -#xCCCA #x7DBF -#xCCCB #x7DEC -#xCCCC #x9762 -#xCCCD #x9EBA -#xCCCE #x6478 -#xCCCF #x6A21 -#xCCD0 #x8302 -#xCCD1 #x5984 -#xCCD2 #x5B5F -#xCCD3 #x6BDB -#xCCD4 #x731B -#xCCD5 #x76F2 -#xCCD6 #x7DB2 -#xCCD7 #x8017 -#xCCD8 #x8499 -#xCCD9 #x5132 -#xCCDA #x6728 -#xCCDB #x9ED9 -#xCCDC #x76EE -#xCCDD #x6762 -#xCCDE #x52FF -#xCCDF #x9905 -#xCCE0 #x5C24 -#xCCE1 #x623B -#xCCE2 #x7C7E -#xCCE3 #x8CB0 -#xCCE4 #x554F -#xCCE5 #x60B6 -#xCCE6 #x7D0B -#xCCE7 #x9580 -#xCCE8 #x5301 -#xCCE9 #x4E5F -#xCCEA #x51B6 -#xCCEB #x591C -#xCCEC #x723A -#xCCED #x8036 -#xCCEE #x91CE -#xCCEF #x5F25 -#xCCF0 #x77E2 -#xCCF1 #x5384 -#xCCF2 #x5F79 -#xCCF3 #x7D04 -#xCCF4 #x85AC -#xCCF5 #x8A33 -#xCCF6 #x8E8D -#xCCF7 #x9756 -#xCCF8 #x67F3 -#xCCF9 #x85AE -#xCCFA #x9453 -#xCCFB #x6109 -#xCCFC #x6108 -#xCCFD #x6CB9 -#xCCFE #x7652 -#xCDA1 #x8AED -#xCDA2 #x8F38 -#xCDA3 #x552F -#xCDA4 #x4F51 -#xCDA5 #x512A -#xCDA6 #x52C7 -#xCDA7 #x53CB -#xCDA8 #x5BA5 -#xCDA9 #x5E7D -#xCDAA #x60A0 -#xCDAB #x6182 -#xCDAC #x63D6 -#xCDAD #x6709 -#xCDAE #x67DA -#xCDAF #x6E67 -#xCDB0 #x6D8C -#xCDB1 #x7336 -#xCDB2 #x7337 -#xCDB3 #x7531 -#xCDB4 #x7950 -#xCDB5 #x88D5 -#xCDB6 #x8A98 -#xCDB7 #x904A -#xCDB8 #x9091 -#xCDB9 #x90F5 -#xCDBA #x96C4 -#xCDBB #x878D -#xCDBC #x5915 -#xCDBD #x4E88 -#xCDBE #x4F59 -#xCDBF #x4E0E -#xCDC0 #x8A89 -#xCDC1 #x8F3F -#xCDC2 #x9810 -#xCDC3 #x50AD -#xCDC4 #x5E7C -#xCDC5 #x5996 -#xCDC6 #x5BB9 -#xCDC7 #x5EB8 -#xCDC8 #x63DA -#xCDC9 #x63FA -#xCDCA #x64C1 -#xCDCB #x66DC -#xCDCC #x694A -#xCDCD #x69D8 -#xCDCE #x6D0B -#xCDCF #x6EB6 -#xCDD0 #x7194 -#xCDD1 #x7528 -#xCDD2 #x7AAF -#xCDD3 #x7F8A -#xCDD4 #x8000 -#xCDD5 #x8449 -#xCDD6 #x84C9 -#xCDD7 #x8981 -#xCDD8 #x8B21 -#xCDD9 #x8E0A -#xCDDA #x9065 -#xCDDB #x967D -#xCDDC #x990A -#xCDDD #x617E -#xCDDE #x6291 -#xCDDF #x6B32 -#xCDE0 #x6C83 -#xCDE1 #x6D74 -#xCDE2 #x7FCC -#xCDE3 #x7FFC -#xCDE4 #x6DC0 -#xCDE5 #x7F85 -#xCDE6 #x87BA -#xCDE7 #x88F8 -#xCDE8 #x6765 -#xCDE9 #x83B1 -#xCDEA #x983C -#xCDEB #x96F7 -#xCDEC #x6D1B -#xCDED #x7D61 -#xCDEE #x843D -#xCDEF #x916A -#xCDF0 #x4E71 -#xCDF1 #x5375 -#xCDF2 #x5D50 -#xCDF3 #x6B04 -#xCDF4 #x6FEB -#xCDF5 #x85CD -#xCDF6 #x862D -#xCDF7 #x89A7 -#xCDF8 #x5229 -#xCDF9 #x540F -#xCDFA #x5C65 -#xCDFB #x674E -#xCDFC #x68A8 -#xCDFD #x7406 -#xCDFE #x7483 -#xCEA1 #x75E2 -#xCEA2 #x88CF -#xCEA3 #x88E1 -#xCEA4 #x91CC -#xCEA5 #x96E2 -#xCEA6 #x9678 -#xCEA7 #x5F8B -#xCEA8 #x7387 -#xCEA9 #x7ACB -#xCEAA #x844E -#xCEAB #x63A0 -#xCEAC #x7565 -#xCEAD #x5289 -#xCEAE #x6D41 -#xCEAF #x6E9C -#xCEB0 #x7409 -#xCEB1 #x7559 -#xCEB2 #x786B -#xCEB3 #x7C92 -#xCEB4 #x9686 -#xCEB5 #x7ADC -#xCEB6 #x9F8D -#xCEB7 #x4FB6 -#xCEB8 #x616E -#xCEB9 #x65C5 -#xCEBA #x865C -#xCEBB #x4E86 -#xCEBC #x4EAE -#xCEBD #x50DA -#xCEBE #x4E21 -#xCEBF #x51CC -#xCEC0 #x5BEE -#xCEC1 #x6599 -#xCEC2 #x6881 -#xCEC3 #x6DBC -#xCEC4 #x731F -#xCEC5 #x7642 -#xCEC6 #x77AD -#xCEC7 #x7A1C -#xCEC8 #x7CE7 -#xCEC9 #x826F -#xCECA #x8AD2 -#xCECB #x907C -#xCECC #x91CF -#xCECD #x9675 -#xCECE #x9818 -#xCECF #x529B -#xCED0 #x7DD1 -#xCED1 #x502B -#xCED2 #x5398 -#xCED3 #x6797 -#xCED4 #x6DCB -#xCED5 #x71D0 -#xCED6 #x7433 -#xCED7 #x81E8 -#xCED8 #x8F2A -#xCED9 #x96A3 -#xCEDA #x9C57 -#xCEDB #x9E9F -#xCEDC #x7460 -#xCEDD #x5841 -#xCEDE #x6D99 -#xCEDF #x7D2F -#xCEE0 #x985E -#xCEE1 #x4EE4 -#xCEE2 #x4F36 -#xCEE3 #x4F8B -#xCEE4 #x51B7 -#xCEE5 #x52B1 -#xCEE6 #x5DBA -#xCEE7 #x601C -#xCEE8 #x73B2 -#xCEE9 #x793C -#xCEEA #x82D3 -#xCEEB #x9234 -#xCEEC #x96B7 -#xCEED #x96F6 -#xCEEE #x970A -#xCEEF #x9E97 -#xCEF0 #x9F62 -#xCEF1 #x66A6 -#xCEF2 #x6B74 -#xCEF3 #x5217 -#xCEF4 #x52A3 -#xCEF5 #x70C8 -#xCEF6 #x88C2 -#xCEF7 #x5EC9 -#xCEF8 #x604B -#xCEF9 #x6190 -#xCEFA #x6F23 -#xCEFB #x7149 -#xCEFC #x7C3E -#xCEFD #x7DF4 -#xCEFE #x806F -#xCFA1 #x84EE -#xCFA2 #x9023 -#xCFA3 #x932C -#xCFA4 #x5442 -#xCFA5 #x9B6F -#xCFA6 #x6AD3 -#xCFA7 #x7089 -#xCFA8 #x8CC2 -#xCFA9 #x8DEF -#xCFAA #x9732 -#xCFAB #x52B4 -#xCFAC #x5A41 -#xCFAD #x5ECA -#xCFAE #x5F04 -#xCFAF #x6717 -#xCFB0 #x697C -#xCFB1 #x6994 -#xCFB2 #x6D6A -#xCFB3 #x6F0F -#xCFB4 #x7262 -#xCFB5 #x72FC -#xCFB6 #x7BED -#xCFB7 #x8001 -#xCFB8 #x807E -#xCFB9 #x874B -#xCFBA #x90CE -#xCFBB #x516D -#xCFBC #x9E93 -#xCFBD #x7984 -#xCFBE #x808B -#xCFBF #x9332 -#xCFC0 #x8AD6 -#xCFC1 #x502D -#xCFC2 #x548C -#xCFC3 #x8A71 -#xCFC4 #x6B6A -#xCFC5 #x8CC4 -#xCFC6 #x8107 -#xCFC7 #x60D1 -#xCFC8 #x67A0 -#xCFC9 #x9DF2 -#xCFCA #x4E99 -#xCFCB #x4E98 -#xCFCC #x9C10 -#xCFCD #x8A6B -#xCFCE #x85C1 -#xCFCF #x8568 -#xCFD0 #x6900 -#xCFD1 #x6E7E -#xCFD2 #x7897 -#xCFD3 #x8155 -#xD0A1 #x5F0C -#xD0A2 #x4E10 -#xD0A3 #x4E15 -#xD0A4 #x4E2A -#xD0A5 #x4E31 -#xD0A6 #x4E36 -#xD0A7 #x4E3C -#xD0A8 #x4E3F -#xD0A9 #x4E42 -#xD0AA #x4E56 -#xD0AB #x4E58 -#xD0AC #x4E82 -#xD0AD #x4E85 -#xD0AE #x8C6B -#xD0AF #x4E8A -#xD0B0 #x8212 -#xD0B1 #x5F0D -#xD0B2 #x4E8E -#xD0B3 #x4E9E -#xD0B4 #x4E9F -#xD0B5 #x4EA0 -#xD0B6 #x4EA2 -#xD0B7 #x4EB0 -#xD0B8 #x4EB3 -#xD0B9 #x4EB6 -#xD0BA #x4ECE -#xD0BB #x4ECD -#xD0BC #x4EC4 -#xD0BD #x4EC6 -#xD0BE #x4EC2 -#xD0BF #x4ED7 -#xD0C0 #x4EDE -#xD0C1 #x4EED -#xD0C2 #x4EDF -#xD0C3 #x4EF7 -#xD0C4 #x4F09 -#xD0C5 #x4F5A -#xD0C6 #x4F30 -#xD0C7 #x4F5B -#xD0C8 #x4F5D -#xD0C9 #x4F57 -#xD0CA #x4F47 -#xD0CB #x4F76 -#xD0CC #x4F88 -#xD0CD #x4F8F -#xD0CE #x4F98 -#xD0CF #x4F7B -#xD0D0 #x4F69 -#xD0D1 #x4F70 -#xD0D2 #x4F91 -#xD0D3 #x4F6F -#xD0D4 #x4F86 -#xD0D5 #x4F96 -#xD0D6 #x5118 -#xD0D7 #x4FD4 -#xD0D8 #x4FDF -#xD0D9 #x4FCE -#xD0DA #x4FD8 -#xD0DB #x4FDB -#xD0DC #x4FD1 -#xD0DD #x4FDA -#xD0DE #x4FD0 -#xD0DF #x4FE4 -#xD0E0 #x4FE5 -#xD0E1 #x501A -#xD0E2 #x5028 -#xD0E3 #x5014 -#xD0E4 #x502A -#xD0E5 #x5025 -#xD0E6 #x5005 -#xD0E7 #x4F1C -#xD0E8 #x4FF6 -#xD0E9 #x5021 -#xD0EA #x5029 -#xD0EB #x502C -#xD0EC #x4FFE -#xD0ED #x4FEF -#xD0EE #x5011 -#xD0EF #x5006 -#xD0F0 #x5043 -#xD0F1 #x5047 -#xD0F2 #x6703 -#xD0F3 #x5055 -#xD0F4 #x5050 -#xD0F5 #x5048 -#xD0F6 #x505A -#xD0F7 #x5056 -#xD0F8 #x506C -#xD0F9 #x5078 -#xD0FA #x5080 -#xD0FB #x509A -#xD0FC #x5085 -#xD0FD #x50B4 -#xD0FE #x50B2 -#xD1A1 #x50C9 -#xD1A2 #x50CA -#xD1A3 #x50B3 -#xD1A4 #x50C2 -#xD1A5 #x50D6 -#xD1A6 #x50DE -#xD1A7 #x50E5 -#xD1A8 #x50ED -#xD1A9 #x50E3 -#xD1AA #x50EE -#xD1AB #x50F9 -#xD1AC #x50F5 -#xD1AD #x5109 -#xD1AE #x5101 -#xD1AF #x5102 -#xD1B0 #x5116 -#xD1B1 #x5115 -#xD1B2 #x5114 -#xD1B3 #x511A -#xD1B4 #x5121 -#xD1B5 #x513A -#xD1B6 #x5137 -#xD1B7 #x513C -#xD1B8 #x513B -#xD1B9 #x513F -#xD1BA #x5140 -#xD1BB #x5152 -#xD1BC #x514C -#xD1BD #x5154 -#xD1BE #x5162 -#xD1BF #x7AF8 -#xD1C0 #x5169 -#xD1C1 #x516A -#xD1C2 #x516E -#xD1C3 #x5180 -#xD1C4 #x5182 -#xD1C5 #x56D8 -#xD1C6 #x518C -#xD1C7 #x5189 -#xD1C8 #x518F -#xD1C9 #x5191 -#xD1CA #x5193 -#xD1CB #x5195 -#xD1CC #x5196 -#xD1CD #x51A4 -#xD1CE #x51A6 -#xD1CF #x51A2 -#xD1D0 #x51A9 -#xD1D1 #x51AA -#xD1D2 #x51AB -#xD1D3 #x51B3 -#xD1D4 #x51B1 -#xD1D5 #x51B2 -#xD1D6 #x51B0 -#xD1D7 #x51B5 -#xD1D8 #x51BD -#xD1D9 #x51C5 -#xD1DA #x51C9 -#xD1DB #x51DB -#xD1DC #x51E0 -#xD1DD #x8655 -#xD1DE #x51E9 -#xD1DF #x51ED -#xD1E0 #x51F0 -#xD1E1 #x51F5 -#xD1E2 #x51FE -#xD1E3 #x5204 -#xD1E4 #x520B -#xD1E5 #x5214 -#xD1E6 #x520E -#xD1E7 #x5227 -#xD1E8 #x522A -#xD1E9 #x522E -#xD1EA #x5233 -#xD1EB #x5239 -#xD1EC #x524F -#xD1ED #x5244 -#xD1EE #x524B -#xD1EF #x524C -#xD1F0 #x525E -#xD1F1 #x5254 -#xD1F2 #x526A -#xD1F3 #x5274 -#xD1F4 #x5269 -#xD1F5 #x5273 -#xD1F6 #x527F -#xD1F7 #x527D -#xD1F8 #x528D -#xD1F9 #x5294 -#xD1FA #x5292 -#xD1FB #x5271 -#xD1FC #x5288 -#xD1FD #x5291 -#xD1FE #x8FA8 -#xD2A1 #x8FA7 -#xD2A2 #x52AC -#xD2A3 #x52AD -#xD2A4 #x52BC -#xD2A5 #x52B5 -#xD2A6 #x52C1 -#xD2A7 #x52CD -#xD2A8 #x52D7 -#xD2A9 #x52DE -#xD2AA #x52E3 -#xD2AB #x52E6 -#xD2AC #x98ED -#xD2AD #x52E0 -#xD2AE #x52F3 -#xD2AF #x52F5 -#xD2B0 #x52F8 -#xD2B1 #x52F9 -#xD2B2 #x5306 -#xD2B3 #x5308 -#xD2B4 #x7538 -#xD2B5 #x530D -#xD2B6 #x5310 -#xD2B7 #x530F -#xD2B8 #x5315 -#xD2B9 #x531A -#xD2BA #x5323 -#xD2BB #x532F -#xD2BC #x5331 -#xD2BD #x5333 -#xD2BE #x5338 -#xD2BF #x5340 -#xD2C0 #x5346 -#xD2C1 #x5345 -#xD2C2 #x4E17 -#xD2C3 #x5349 -#xD2C4 #x534D -#xD2C5 #x51D6 -#xD2C6 #x535E -#xD2C7 #x5369 -#xD2C8 #x536E -#xD2C9 #x5918 -#xD2CA #x537B -#xD2CB #x5377 -#xD2CC #x5382 -#xD2CD #x5396 -#xD2CE #x53A0 -#xD2CF #x53A6 -#xD2D0 #x53A5 -#xD2D1 #x53AE -#xD2D2 #x53B0 -#xD2D3 #x53B6 -#xD2D4 #x53C3 -#xD2D5 #x7C12 -#xD2D6 #x96D9 -#xD2D7 #x53DF -#xD2D8 #x66FC -#xD2D9 #x71EE -#xD2DA #x53EE -#xD2DB #x53E8 -#xD2DC #x53ED -#xD2DD #x53FA -#xD2DE #x5401 -#xD2DF #x543D -#xD2E0 #x5440 -#xD2E1 #x542C -#xD2E2 #x542D -#xD2E3 #x543C -#xD2E4 #x542E -#xD2E5 #x5436 -#xD2E6 #x5429 -#xD2E7 #x541D -#xD2E8 #x544E -#xD2E9 #x548F -#xD2EA #x5475 -#xD2EB #x548E -#xD2EC #x545F -#xD2ED #x5471 -#xD2EE #x5477 -#xD2EF #x5470 -#xD2F0 #x5492 -#xD2F1 #x547B -#xD2F2 #x5480 -#xD2F3 #x5476 -#xD2F4 #x5484 -#xD2F5 #x5490 -#xD2F6 #x5486 -#xD2F7 #x54C7 -#xD2F8 #x54A2 -#xD2F9 #x54B8 -#xD2FA #x54A5 -#xD2FB #x54AC -#xD2FC #x54C4 -#xD2FD #x54C8 -#xD2FE #x54A8 -#xD3A1 #x54AB -#xD3A2 #x54C2 -#xD3A3 #x54A4 -#xD3A4 #x54BE -#xD3A5 #x54BC -#xD3A6 #x54D8 -#xD3A7 #x54E5 -#xD3A8 #x54E6 -#xD3A9 #x550F -#xD3AA #x5514 -#xD3AB #x54FD -#xD3AC #x54EE -#xD3AD #x54ED -#xD3AE #x54FA -#xD3AF #x54E2 -#xD3B0 #x5539 -#xD3B1 #x5540 -#xD3B2 #x5563 -#xD3B3 #x554C -#xD3B4 #x552E -#xD3B5 #x555C -#xD3B6 #x5545 -#xD3B7 #x5556 -#xD3B8 #x5557 -#xD3B9 #x5538 -#xD3BA #x5533 -#xD3BB #x555D -#xD3BC #x5599 -#xD3BD #x5580 -#xD3BE #x54AF -#xD3BF #x558A -#xD3C0 #x559F -#xD3C1 #x557B -#xD3C2 #x557E -#xD3C3 #x5598 -#xD3C4 #x559E -#xD3C5 #x55AE -#xD3C6 #x557C -#xD3C7 #x5583 -#xD3C8 #x55A9 -#xD3C9 #x5587 -#xD3CA #x55A8 -#xD3CB #x55DA -#xD3CC #x55C5 -#xD3CD #x55DF -#xD3CE #x55C4 -#xD3CF #x55DC -#xD3D0 #x55E4 -#xD3D1 #x55D4 -#xD3D2 #x5614 -#xD3D3 #x55F7 -#xD3D4 #x5616 -#xD3D5 #x55FE -#xD3D6 #x55FD -#xD3D7 #x561B -#xD3D8 #x55F9 -#xD3D9 #x564E -#xD3DA #x5650 -#xD3DB #x71DF -#xD3DC #x5634 -#xD3DD #x5636 -#xD3DE #x5632 -#xD3DF #x5638 -#xD3E0 #x566B -#xD3E1 #x5664 -#xD3E2 #x562F -#xD3E3 #x566C -#xD3E4 #x566A -#xD3E5 #x5686 -#xD3E6 #x5680 -#xD3E7 #x568A -#xD3E8 #x56A0 -#xD3E9 #x5694 -#xD3EA #x568F -#xD3EB #x56A5 -#xD3EC #x56AE -#xD3ED #x56B6 -#xD3EE #x56B4 -#xD3EF #x56C2 -#xD3F0 #x56BC -#xD3F1 #x56C1 -#xD3F2 #x56C3 -#xD3F3 #x56C0 -#xD3F4 #x56C8 -#xD3F5 #x56CE -#xD3F6 #x56D1 -#xD3F7 #x56D3 -#xD3F8 #x56D7 -#xD3F9 #x56EE -#xD3FA #x56F9 -#xD3FB #x5700 -#xD3FC #x56FF -#xD3FD #x5704 -#xD3FE #x5709 -#xD4A1 #x5708 -#xD4A2 #x570B -#xD4A3 #x570D -#xD4A4 #x5713 -#xD4A5 #x5718 -#xD4A6 #x5716 -#xD4A7 #x55C7 -#xD4A8 #x571C -#xD4A9 #x5726 -#xD4AA #x5737 -#xD4AB #x5738 -#xD4AC #x574E -#xD4AD #x573B -#xD4AE #x5740 -#xD4AF #x574F -#xD4B0 #x5769 -#xD4B1 #x57C0 -#xD4B2 #x5788 -#xD4B3 #x5761 -#xD4B4 #x577F -#xD4B5 #x5789 -#xD4B6 #x5793 -#xD4B7 #x57A0 -#xD4B8 #x57B3 -#xD4B9 #x57A4 -#xD4BA #x57AA -#xD4BB #x57B0 -#xD4BC #x57C3 -#xD4BD #x57C6 -#xD4BE #x57D4 -#xD4BF #x57D2 -#xD4C0 #x57D3 -#xD4C1 #x580A -#xD4C2 #x57D6 -#xD4C3 #x57E3 -#xD4C4 #x580B -#xD4C5 #x5819 -#xD4C6 #x581D -#xD4C7 #x5872 -#xD4C8 #x5821 -#xD4C9 #x5862 -#xD4CA #x584B -#xD4CB #x5870 -#xD4CC #x6BC0 -#xD4CD #x5852 -#xD4CE #x583D -#xD4CF #x5879 -#xD4D0 #x5885 -#xD4D1 #x58B9 -#xD4D2 #x589F -#xD4D3 #x58AB -#xD4D4 #x58BA -#xD4D5 #x58DE -#xD4D6 #x58BB -#xD4D7 #x58B8 -#xD4D8 #x58AE -#xD4D9 #x58C5 -#xD4DA #x58D3 -#xD4DB #x58D1 -#xD4DC #x58D7 -#xD4DD #x58D9 -#xD4DE #x58D8 -#xD4DF #x58E5 -#xD4E0 #x58DC -#xD4E1 #x58E4 -#xD4E2 #x58DF -#xD4E3 #x58EF -#xD4E4 #x58FA -#xD4E5 #x58F9 -#xD4E6 #x58FB -#xD4E7 #x58FC -#xD4E8 #x58FD -#xD4E9 #x5902 -#xD4EA #x590A -#xD4EB #x5910 -#xD4EC #x591B -#xD4ED #x68A6 -#xD4EE #x5925 -#xD4EF #x592C -#xD4F0 #x592D -#xD4F1 #x5932 -#xD4F2 #x5938 -#xD4F3 #x593E -#xD4F4 #x7AD2 -#xD4F5 #x5955 -#xD4F6 #x5950 -#xD4F7 #x594E -#xD4F8 #x595A -#xD4F9 #x5958 -#xD4FA #x5962 -#xD4FB #x5960 -#xD4FC #x5967 -#xD4FD #x596C -#xD4FE #x5969 -#xD5A1 #x5978 -#xD5A2 #x5981 -#xD5A3 #x599D -#xD5A4 #x4F5E -#xD5A5 #x4FAB -#xD5A6 #x59A3 -#xD5A7 #x59B2 -#xD5A8 #x59C6 -#xD5A9 #x59E8 -#xD5AA #x59DC -#xD5AB #x598D -#xD5AC #x59D9 -#xD5AD #x59DA -#xD5AE #x5A25 -#xD5AF #x5A1F -#xD5B0 #x5A11 -#xD5B1 #x5A1C -#xD5B2 #x5A09 -#xD5B3 #x5A1A -#xD5B4 #x5A40 -#xD5B5 #x5A6C -#xD5B6 #x5A49 -#xD5B7 #x5A35 -#xD5B8 #x5A36 -#xD5B9 #x5A62 -#xD5BA #x5A6A -#xD5BB #x5A9A -#xD5BC #x5ABC -#xD5BD #x5ABE -#xD5BE #x5ACB -#xD5BF #x5AC2 -#xD5C0 #x5ABD -#xD5C1 #x5AE3 -#xD5C2 #x5AD7 -#xD5C3 #x5AE6 -#xD5C4 #x5AE9 -#xD5C5 #x5AD6 -#xD5C6 #x5AFA -#xD5C7 #x5AFB -#xD5C8 #x5B0C -#xD5C9 #x5B0B -#xD5CA #x5B16 -#xD5CB #x5B32 -#xD5CC #x5AD0 -#xD5CD #x5B2A -#xD5CE #x5B36 -#xD5CF #x5B3E -#xD5D0 #x5B43 -#xD5D1 #x5B45 -#xD5D2 #x5B40 -#xD5D3 #x5B51 -#xD5D4 #x5B55 -#xD5D5 #x5B5A -#xD5D6 #x5B5B -#xD5D7 #x5B65 -#xD5D8 #x5B69 -#xD5D9 #x5B70 -#xD5DA #x5B73 -#xD5DB #x5B75 -#xD5DC #x5B78 -#xD5DD #x6588 -#xD5DE #x5B7A -#xD5DF #x5B80 -#xD5E0 #x5B83 -#xD5E1 #x5BA6 -#xD5E2 #x5BB8 -#xD5E3 #x5BC3 -#xD5E4 #x5BC7 -#xD5E5 #x5BC9 -#xD5E6 #x5BD4 -#xD5E7 #x5BD0 -#xD5E8 #x5BE4 -#xD5E9 #x5BE6 -#xD5EA #x5BE2 -#xD5EB #x5BDE -#xD5EC #x5BE5 -#xD5ED #x5BEB -#xD5EE #x5BF0 -#xD5EF #x5BF6 -#xD5F0 #x5BF3 -#xD5F1 #x5C05 -#xD5F2 #x5C07 -#xD5F3 #x5C08 -#xD5F4 #x5C0D -#xD5F5 #x5C13 -#xD5F6 #x5C20 -#xD5F7 #x5C22 -#xD5F8 #x5C28 -#xD5F9 #x5C38 -#xD5FA #x5C39 -#xD5FB #x5C41 -#xD5FC #x5C46 -#xD5FD #x5C4E -#xD5FE #x5C53 -#xD6A1 #x5C50 -#xD6A2 #x5C4F -#xD6A3 #x5B71 -#xD6A4 #x5C6C -#xD6A5 #x5C6E -#xD6A6 #x4E62 -#xD6A7 #x5C76 -#xD6A8 #x5C79 -#xD6A9 #x5C8C -#xD6AA #x5C91 -#xD6AB #x5C94 -#xD6AC #x599B -#xD6AD #x5CAB -#xD6AE #x5CBB -#xD6AF #x5CB6 -#xD6B0 #x5CBC -#xD6B1 #x5CB7 -#xD6B2 #x5CC5 -#xD6B3 #x5CBE -#xD6B4 #x5CC7 -#xD6B5 #x5CD9 -#xD6B6 #x5CE9 -#xD6B7 #x5CFD -#xD6B8 #x5CFA -#xD6B9 #x5CED -#xD6BA #x5D8C -#xD6BB #x5CEA -#xD6BC #x5D0B -#xD6BD #x5D15 -#xD6BE #x5D17 -#xD6BF #x5D5C -#xD6C0 #x5D1F -#xD6C1 #x5D1B -#xD6C2 #x5D11 -#xD6C3 #x5D14 -#xD6C4 #x5D22 -#xD6C5 #x5D1A -#xD6C6 #x5D19 -#xD6C7 #x5D18 -#xD6C8 #x5D4C -#xD6C9 #x5D52 -#xD6CA #x5D4E -#xD6CB #x5D4B -#xD6CC #x5D6C -#xD6CD #x5D73 -#xD6CE #x5D76 -#xD6CF #x5D87 -#xD6D0 #x5D84 -#xD6D1 #x5D82 -#xD6D2 #x5DA2 -#xD6D3 #x5D9D -#xD6D4 #x5DAC -#xD6D5 #x5DAE -#xD6D6 #x5DBD -#xD6D7 #x5D90 -#xD6D8 #x5DB7 -#xD6D9 #x5DBC -#xD6DA #x5DC9 -#xD6DB #x5DCD -#xD6DC #x5DD3 -#xD6DD #x5DD2 -#xD6DE #x5DD6 -#xD6DF #x5DDB -#xD6E0 #x5DEB -#xD6E1 #x5DF2 -#xD6E2 #x5DF5 -#xD6E3 #x5E0B -#xD6E4 #x5E1A -#xD6E5 #x5E19 -#xD6E6 #x5E11 -#xD6E7 #x5E1B -#xD6E8 #x5E36 -#xD6E9 #x5E37 -#xD6EA #x5E44 -#xD6EB #x5E43 -#xD6EC #x5E40 -#xD6ED #x5E4E -#xD6EE #x5E57 -#xD6EF #x5E54 -#xD6F0 #x5E5F -#xD6F1 #x5E62 -#xD6F2 #x5E64 -#xD6F3 #x5E47 -#xD6F4 #x5E75 -#xD6F5 #x5E76 -#xD6F6 #x5E7A -#xD6F7 #x9EBC -#xD6F8 #x5E7F -#xD6F9 #x5EA0 -#xD6FA #x5EC1 -#xD6FB #x5EC2 -#xD6FC #x5EC8 -#xD6FD #x5ED0 -#xD6FE #x5ECF -#xD7A1 #x5ED6 -#xD7A2 #x5EE3 -#xD7A3 #x5EDD -#xD7A4 #x5EDA -#xD7A5 #x5EDB -#xD7A6 #x5EE2 -#xD7A7 #x5EE1 -#xD7A8 #x5EE8 -#xD7A9 #x5EE9 -#xD7AA #x5EEC -#xD7AB #x5EF1 -#xD7AC #x5EF3 -#xD7AD #x5EF0 -#xD7AE #x5EF4 -#xD7AF #x5EF8 -#xD7B0 #x5EFE -#xD7B1 #x5F03 -#xD7B2 #x5F09 -#xD7B3 #x5F5D -#xD7B4 #x5F5C -#xD7B5 #x5F0B -#xD7B6 #x5F11 -#xD7B7 #x5F16 -#xD7B8 #x5F29 -#xD7B9 #x5F2D -#xD7BA #x5F38 -#xD7BB #x5F41 -#xD7BC #x5F48 -#xD7BD #x5F4C -#xD7BE #x5F4E -#xD7BF #x5F2F -#xD7C0 #x5F51 -#xD7C1 #x5F56 -#xD7C2 #x5F57 -#xD7C3 #x5F59 -#xD7C4 #x5F61 -#xD7C5 #x5F6D -#xD7C6 #x5F73 -#xD7C7 #x5F77 -#xD7C8 #x5F83 -#xD7C9 #x5F82 -#xD7CA #x5F7F -#xD7CB #x5F8A -#xD7CC #x5F88 -#xD7CD #x5F91 -#xD7CE #x5F87 -#xD7CF #x5F9E -#xD7D0 #x5F99 -#xD7D1 #x5F98 -#xD7D2 #x5FA0 -#xD7D3 #x5FA8 -#xD7D4 #x5FAD -#xD7D5 #x5FBC -#xD7D6 #x5FD6 -#xD7D7 #x5FFB -#xD7D8 #x5FE4 -#xD7D9 #x5FF8 -#xD7DA #x5FF1 -#xD7DB #x5FDD -#xD7DC #x60B3 -#xD7DD #x5FFF -#xD7DE #x6021 -#xD7DF #x6060 -#xD7E0 #x6019 -#xD7E1 #x6010 -#xD7E2 #x6029 -#xD7E3 #x600E -#xD7E4 #x6031 -#xD7E5 #x601B -#xD7E6 #x6015 -#xD7E7 #x602B -#xD7E8 #x6026 -#xD7E9 #x600F -#xD7EA #x603A -#xD7EB #x605A -#xD7EC #x6041 -#xD7ED #x606A -#xD7EE #x6077 -#xD7EF #x605F -#xD7F0 #x604A -#xD7F1 #x6046 -#xD7F2 #x604D -#xD7F3 #x6063 -#xD7F4 #x6043 -#xD7F5 #x6064 -#xD7F6 #x6042 -#xD7F7 #x606C -#xD7F8 #x606B -#xD7F9 #x6059 -#xD7FA #x6081 -#xD7FB #x608D -#xD7FC #x60E7 -#xD7FD #x6083 -#xD7FE #x609A -#xD8A1 #x6084 -#xD8A2 #x609B -#xD8A3 #x6096 -#xD8A4 #x6097 -#xD8A5 #x6092 -#xD8A6 #x60A7 -#xD8A7 #x608B -#xD8A8 #x60E1 -#xD8A9 #x60B8 -#xD8AA #x60E0 -#xD8AB #x60D3 -#xD8AC #x60B4 -#xD8AD #x5FF0 -#xD8AE #x60BD -#xD8AF #x60C6 -#xD8B0 #x60B5 -#xD8B1 #x60D8 -#xD8B2 #x614D -#xD8B3 #x6115 -#xD8B4 #x6106 -#xD8B5 #x60F6 -#xD8B6 #x60F7 -#xD8B7 #x6100 -#xD8B8 #x60F4 -#xD8B9 #x60FA -#xD8BA #x6103 -#xD8BB #x6121 -#xD8BC #x60FB -#xD8BD #x60F1 -#xD8BE #x610D -#xD8BF #x610E -#xD8C0 #x6147 -#xD8C1 #x613E -#xD8C2 #x6128 -#xD8C3 #x6127 -#xD8C4 #x614A -#xD8C5 #x613F -#xD8C6 #x613C -#xD8C7 #x612C -#xD8C8 #x6134 -#xD8C9 #x613D -#xD8CA #x6142 -#xD8CB #x6144 -#xD8CC #x6173 -#xD8CD #x6177 -#xD8CE #x6158 -#xD8CF #x6159 -#xD8D0 #x615A -#xD8D1 #x616B -#xD8D2 #x6174 -#xD8D3 #x616F -#xD8D4 #x6165 -#xD8D5 #x6171 -#xD8D6 #x615F -#xD8D7 #x615D -#xD8D8 #x6153 -#xD8D9 #x6175 -#xD8DA #x6199 -#xD8DB #x6196 -#xD8DC #x6187 -#xD8DD #x61AC -#xD8DE #x6194 -#xD8DF #x619A -#xD8E0 #x618A -#xD8E1 #x6191 -#xD8E2 #x61AB -#xD8E3 #x61AE -#xD8E4 #x61CC -#xD8E5 #x61CA -#xD8E6 #x61C9 -#xD8E7 #x61F7 -#xD8E8 #x61C8 -#xD8E9 #x61C3 -#xD8EA #x61C6 -#xD8EB #x61BA -#xD8EC #x61CB -#xD8ED #x7F79 -#xD8EE #x61CD -#xD8EF #x61E6 -#xD8F0 #x61E3 -#xD8F1 #x61F6 -#xD8F2 #x61FA -#xD8F3 #x61F4 -#xD8F4 #x61FF -#xD8F5 #x61FD -#xD8F6 #x61FC -#xD8F7 #x61FE -#xD8F8 #x6200 -#xD8F9 #x6208 -#xD8FA #x6209 -#xD8FB #x620D -#xD8FC #x620C -#xD8FD #x6214 -#xD8FE #x621B -#xD9A1 #x621E -#xD9A2 #x6221 -#xD9A3 #x622A -#xD9A4 #x622E -#xD9A5 #x6230 -#xD9A6 #x6232 -#xD9A7 #x6233 -#xD9A8 #x6241 -#xD9A9 #x624E -#xD9AA #x625E -#xD9AB #x6263 -#xD9AC #x625B -#xD9AD #x6260 -#xD9AE #x6268 -#xD9AF #x627C -#xD9B0 #x6282 -#xD9B1 #x6289 -#xD9B2 #x627E -#xD9B3 #x6292 -#xD9B4 #x6293 -#xD9B5 #x6296 -#xD9B6 #x62D4 -#xD9B7 #x6283 -#xD9B8 #x6294 -#xD9B9 #x62D7 -#xD9BA #x62D1 -#xD9BB #x62BB -#xD9BC #x62CF -#xD9BD #x62FF -#xD9BE #x62C6 -#xD9BF #x64D4 -#xD9C0 #x62C8 -#xD9C1 #x62DC -#xD9C2 #x62CC -#xD9C3 #x62CA -#xD9C4 #x62C2 -#xD9C5 #x62C7 -#xD9C6 #x629B -#xD9C7 #x62C9 -#xD9C8 #x630C -#xD9C9 #x62EE -#xD9CA #x62F1 -#xD9CB #x6327 -#xD9CC #x6302 -#xD9CD #x6308 -#xD9CE #x62EF -#xD9CF #x62F5 -#xD9D0 #x6350 -#xD9D1 #x633E -#xD9D2 #x634D -#xD9D3 #x641C -#xD9D4 #x634F -#xD9D5 #x6396 -#xD9D6 #x638E -#xD9D7 #x6380 -#xD9D8 #x63AB -#xD9D9 #x6376 -#xD9DA #x63A3 -#xD9DB #x638F -#xD9DC #x6389 -#xD9DD #x639F -#xD9DE #x63B5 -#xD9DF #x636B -#xD9E0 #x6369 -#xD9E1 #x63BE -#xD9E2 #x63E9 -#xD9E3 #x63C0 -#xD9E4 #x63C6 -#xD9E5 #x63E3 -#xD9E6 #x63C9 -#xD9E7 #x63D2 -#xD9E8 #x63F6 -#xD9E9 #x63C4 -#xD9EA #x6416 -#xD9EB #x6434 -#xD9EC #x6406 -#xD9ED #x6413 -#xD9EE #x6426 -#xD9EF #x6436 -#xD9F0 #x651D -#xD9F1 #x6417 -#xD9F2 #x6428 -#xD9F3 #x640F -#xD9F4 #x6467 -#xD9F5 #x646F -#xD9F6 #x6476 -#xD9F7 #x644E -#xD9F8 #x652A -#xD9F9 #x6495 -#xD9FA #x6493 -#xD9FB #x64A5 -#xD9FC #x64A9 -#xD9FD #x6488 -#xD9FE #x64BC -#xDAA1 #x64DA -#xDAA2 #x64D2 -#xDAA3 #x64C5 -#xDAA4 #x64C7 -#xDAA5 #x64BB -#xDAA6 #x64D8 -#xDAA7 #x64C2 -#xDAA8 #x64F1 -#xDAA9 #x64E7 -#xDAAA #x8209 -#xDAAB #x64E0 -#xDAAC #x64E1 -#xDAAD #x62AC -#xDAAE #x64E3 -#xDAAF #x64EF -#xDAB0 #x652C -#xDAB1 #x64F6 -#xDAB2 #x64F4 -#xDAB3 #x64F2 -#xDAB4 #x64FA -#xDAB5 #x6500 -#xDAB6 #x64FD -#xDAB7 #x6518 -#xDAB8 #x651C -#xDAB9 #x6505 -#xDABA #x6524 -#xDABB #x6523 -#xDABC #x652B -#xDABD #x6534 -#xDABE #x6535 -#xDABF #x6537 -#xDAC0 #x6536 -#xDAC1 #x6538 -#xDAC2 #x754B -#xDAC3 #x6548 -#xDAC4 #x6556 -#xDAC5 #x6555 -#xDAC6 #x654D -#xDAC7 #x6558 -#xDAC8 #x655E -#xDAC9 #x655D -#xDACA #x6572 -#xDACB #x6578 -#xDACC #x6582 -#xDACD #x6583 -#xDACE #x8B8A -#xDACF #x659B -#xDAD0 #x659F -#xDAD1 #x65AB -#xDAD2 #x65B7 -#xDAD3 #x65C3 -#xDAD4 #x65C6 -#xDAD5 #x65C1 -#xDAD6 #x65C4 -#xDAD7 #x65CC -#xDAD8 #x65D2 -#xDAD9 #x65DB -#xDADA #x65D9 -#xDADB #x65E0 -#xDADC #x65E1 -#xDADD #x65F1 -#xDADE #x6772 -#xDADF #x660A -#xDAE0 #x6603 -#xDAE1 #x65FB -#xDAE2 #x6773 -#xDAE3 #x6635 -#xDAE4 #x6636 -#xDAE5 #x6634 -#xDAE6 #x661C -#xDAE7 #x664F -#xDAE8 #x6644 -#xDAE9 #x6649 -#xDAEA #x6641 -#xDAEB #x665E -#xDAEC #x665D -#xDAED #x6664 -#xDAEE #x6667 -#xDAEF #x6668 -#xDAF0 #x665F -#xDAF1 #x6662 -#xDAF2 #x6670 -#xDAF3 #x6683 -#xDAF4 #x6688 -#xDAF5 #x668E -#xDAF6 #x6689 -#xDAF7 #x6684 -#xDAF8 #x6698 -#xDAF9 #x669D -#xDAFA #x66C1 -#xDAFB #x66B9 -#xDAFC #x66C9 -#xDAFD #x66BE -#xDAFE #x66BC -#xDBA1 #x66C4 -#xDBA2 #x66B8 -#xDBA3 #x66D6 -#xDBA4 #x66DA -#xDBA5 #x66E0 -#xDBA6 #x663F -#xDBA7 #x66E6 -#xDBA8 #x66E9 -#xDBA9 #x66F0 -#xDBAA #x66F5 -#xDBAB #x66F7 -#xDBAC #x670F -#xDBAD #x6716 -#xDBAE #x671E -#xDBAF #x6726 -#xDBB0 #x6727 -#xDBB1 #x9738 -#xDBB2 #x672E -#xDBB3 #x673F -#xDBB4 #x6736 -#xDBB5 #x6741 -#xDBB6 #x6738 -#xDBB7 #x6737 -#xDBB8 #x6746 -#xDBB9 #x675E -#xDBBA #x6760 -#xDBBB #x6759 -#xDBBC #x6763 -#xDBBD #x6764 -#xDBBE #x6789 -#xDBBF #x6770 -#xDBC0 #x67A9 -#xDBC1 #x677C -#xDBC2 #x676A -#xDBC3 #x678C -#xDBC4 #x678B -#xDBC5 #x67A6 -#xDBC6 #x67A1 -#xDBC7 #x6785 -#xDBC8 #x67B7 -#xDBC9 #x67EF -#xDBCA #x67B4 -#xDBCB #x67EC -#xDBCC #x67B3 -#xDBCD #x67E9 -#xDBCE #x67B8 -#xDBCF #x67E4 -#xDBD0 #x67DE -#xDBD1 #x67DD -#xDBD2 #x67E2 -#xDBD3 #x67EE -#xDBD4 #x67B9 -#xDBD5 #x67CE -#xDBD6 #x67C6 -#xDBD7 #x67E7 -#xDBD8 #x6A9C -#xDBD9 #x681E -#xDBDA #x6846 -#xDBDB #x6829 -#xDBDC #x6840 -#xDBDD #x684D -#xDBDE #x6832 -#xDBDF #x684E -#xDBE0 #x68B3 -#xDBE1 #x682B -#xDBE2 #x6859 -#xDBE3 #x6863 -#xDBE4 #x6877 -#xDBE5 #x687F -#xDBE6 #x689F -#xDBE7 #x688F -#xDBE8 #x68AD -#xDBE9 #x6894 -#xDBEA #x689D -#xDBEB #x689B -#xDBEC #x6883 -#xDBED #x6AAE -#xDBEE #x68B9 -#xDBEF #x6874 -#xDBF0 #x68B5 -#xDBF1 #x68A0 -#xDBF2 #x68BA -#xDBF3 #x690F -#xDBF4 #x688D -#xDBF5 #x687E -#xDBF6 #x6901 -#xDBF7 #x68CA -#xDBF8 #x6908 -#xDBF9 #x68D8 -#xDBFA #x6922 -#xDBFB #x6926 -#xDBFC #x68E1 -#xDBFD #x690C -#xDBFE #x68CD -#xDCA1 #x68D4 -#xDCA2 #x68E7 -#xDCA3 #x68D5 -#xDCA4 #x6936 -#xDCA5 #x6912 -#xDCA6 #x6904 -#xDCA7 #x68D7 -#xDCA8 #x68E3 -#xDCA9 #x6925 -#xDCAA #x68F9 -#xDCAB #x68E0 -#xDCAC #x68EF -#xDCAD #x6928 -#xDCAE #x692A -#xDCAF #x691A -#xDCB0 #x6923 -#xDCB1 #x6921 -#xDCB2 #x68C6 -#xDCB3 #x6979 -#xDCB4 #x6977 -#xDCB5 #x695C -#xDCB6 #x6978 -#xDCB7 #x696B -#xDCB8 #x6954 -#xDCB9 #x697E -#xDCBA #x696E -#xDCBB #x6939 -#xDCBC #x6974 -#xDCBD #x693D -#xDCBE #x6959 -#xDCBF #x6930 -#xDCC0 #x6961 -#xDCC1 #x695E -#xDCC2 #x695D -#xDCC3 #x6981 -#xDCC4 #x696A -#xDCC5 #x69B2 -#xDCC6 #x69AE -#xDCC7 #x69D0 -#xDCC8 #x69BF -#xDCC9 #x69C1 -#xDCCA #x69D3 -#xDCCB #x69BE -#xDCCC #x69CE -#xDCCD #x5BE8 -#xDCCE #x69CA -#xDCCF #x69DD -#xDCD0 #x69BB -#xDCD1 #x69C3 -#xDCD2 #x69A7 -#xDCD3 #x6A2E -#xDCD4 #x6991 -#xDCD5 #x69A0 -#xDCD6 #x699C -#xDCD7 #x6995 -#xDCD8 #x69B4 -#xDCD9 #x69DE -#xDCDA #x69E8 -#xDCDB #x6A02 -#xDCDC #x6A1B -#xDCDD #x69FF -#xDCDE #x6B0A -#xDCDF #x69F9 -#xDCE0 #x69F2 -#xDCE1 #x69E7 -#xDCE2 #x6A05 -#xDCE3 #x69B1 -#xDCE4 #x6A1E -#xDCE5 #x69ED -#xDCE6 #x6A14 -#xDCE7 #x69EB -#xDCE8 #x6A0A -#xDCE9 #x6A12 -#xDCEA #x6AC1 -#xDCEB #x6A23 -#xDCEC #x6A13 -#xDCED #x6A44 -#xDCEE #x6A0C -#xDCEF #x6A72 -#xDCF0 #x6A36 -#xDCF1 #x6A78 -#xDCF2 #x6A47 -#xDCF3 #x6A62 -#xDCF4 #x6A59 -#xDCF5 #x6A66 -#xDCF6 #x6A48 -#xDCF7 #x6A38 -#xDCF8 #x6A22 -#xDCF9 #x6A90 -#xDCFA #x6A8D -#xDCFB #x6AA0 -#xDCFC #x6A84 -#xDCFD #x6AA2 -#xDCFE #x6AA3 -#xDDA1 #x6A97 -#xDDA2 #x8617 -#xDDA3 #x6ABB -#xDDA4 #x6AC3 -#xDDA5 #x6AC2 -#xDDA6 #x6AB8 -#xDDA7 #x6AB3 -#xDDA8 #x6AAC -#xDDA9 #x6ADE -#xDDAA #x6AD1 -#xDDAB #x6ADF -#xDDAC #x6AAA -#xDDAD #x6ADA -#xDDAE #x6AEA -#xDDAF #x6AFB -#xDDB0 #x6B05 -#xDDB1 #x8616 -#xDDB2 #x6AFA -#xDDB3 #x6B12 -#xDDB4 #x6B16 -#xDDB5 #x9B31 -#xDDB6 #x6B1F -#xDDB7 #x6B38 -#xDDB8 #x6B37 -#xDDB9 #x76DC -#xDDBA #x6B39 -#xDDBB #x98EE -#xDDBC #x6B47 -#xDDBD #x6B43 -#xDDBE #x6B49 -#xDDBF #x6B50 -#xDDC0 #x6B59 -#xDDC1 #x6B54 -#xDDC2 #x6B5B -#xDDC3 #x6B5F -#xDDC4 #x6B61 -#xDDC5 #x6B78 -#xDDC6 #x6B79 -#xDDC7 #x6B7F -#xDDC8 #x6B80 -#xDDC9 #x6B84 -#xDDCA #x6B83 -#xDDCB #x6B8D -#xDDCC #x6B98 -#xDDCD #x6B95 -#xDDCE #x6B9E -#xDDCF #x6BA4 -#xDDD0 #x6BAA -#xDDD1 #x6BAB -#xDDD2 #x6BAF -#xDDD3 #x6BB2 -#xDDD4 #x6BB1 -#xDDD5 #x6BB3 -#xDDD6 #x6BB7 -#xDDD7 #x6BBC -#xDDD8 #x6BC6 -#xDDD9 #x6BCB -#xDDDA #x6BD3 -#xDDDB #x6BDF -#xDDDC #x6BEC -#xDDDD #x6BEB -#xDDDE #x6BF3 -#xDDDF #x6BEF -#xDDE0 #x9EBE -#xDDE1 #x6C08 -#xDDE2 #x6C13 -#xDDE3 #x6C14 -#xDDE4 #x6C1B -#xDDE5 #x6C24 -#xDDE6 #x6C23 -#xDDE7 #x6C5E -#xDDE8 #x6C55 -#xDDE9 #x6C62 -#xDDEA #x6C6A -#xDDEB #x6C82 -#xDDEC #x6C8D -#xDDED #x6C9A -#xDDEE #x6C81 -#xDDEF #x6C9B -#xDDF0 #x6C7E -#xDDF1 #x6C68 -#xDDF2 #x6C73 -#xDDF3 #x6C92 -#xDDF4 #x6C90 -#xDDF5 #x6CC4 -#xDDF6 #x6CF1 -#xDDF7 #x6CD3 -#xDDF8 #x6CBD -#xDDF9 #x6CD7 -#xDDFA #x6CC5 -#xDDFB #x6CDD -#xDDFC #x6CAE -#xDDFD #x6CB1 -#xDDFE #x6CBE -#xDEA1 #x6CBA -#xDEA2 #x6CDB -#xDEA3 #x6CEF -#xDEA4 #x6CD9 -#xDEA5 #x6CEA -#xDEA6 #x6D1F -#xDEA7 #x884D -#xDEA8 #x6D36 -#xDEA9 #x6D2B -#xDEAA #x6D3D -#xDEAB #x6D38 -#xDEAC #x6D19 -#xDEAD #x6D35 -#xDEAE #x6D33 -#xDEAF #x6D12 -#xDEB0 #x6D0C -#xDEB1 #x6D63 -#xDEB2 #x6D93 -#xDEB3 #x6D64 -#xDEB4 #x6D5A -#xDEB5 #x6D79 -#xDEB6 #x6D59 -#xDEB7 #x6D8E -#xDEB8 #x6D95 -#xDEB9 #x6FE4 -#xDEBA #x6D85 -#xDEBB #x6DF9 -#xDEBC #x6E15 -#xDEBD #x6E0A -#xDEBE #x6DB5 -#xDEBF #x6DC7 -#xDEC0 #x6DE6 -#xDEC1 #x6DB8 -#xDEC2 #x6DC6 -#xDEC3 #x6DEC -#xDEC4 #x6DDE -#xDEC5 #x6DCC -#xDEC6 #x6DE8 -#xDEC7 #x6DD2 -#xDEC8 #x6DC5 -#xDEC9 #x6DFA -#xDECA #x6DD9 -#xDECB #x6DE4 -#xDECC #x6DD5 -#xDECD #x6DEA -#xDECE #x6DEE -#xDECF #x6E2D -#xDED0 #x6E6E -#xDED1 #x6E2E -#xDED2 #x6E19 -#xDED3 #x6E72 -#xDED4 #x6E5F -#xDED5 #x6E3E -#xDED6 #x6E23 -#xDED7 #x6E6B -#xDED8 #x6E2B -#xDED9 #x6E76 -#xDEDA #x6E4D -#xDEDB #x6E1F -#xDEDC #x6E43 -#xDEDD #x6E3A -#xDEDE #x6E4E -#xDEDF #x6E24 -#xDEE0 #x6EFF -#xDEE1 #x6E1D -#xDEE2 #x6E38 -#xDEE3 #x6E82 -#xDEE4 #x6EAA -#xDEE5 #x6E98 -#xDEE6 #x6EC9 -#xDEE7 #x6EB7 -#xDEE8 #x6ED3 -#xDEE9 #x6EBD -#xDEEA #x6EAF -#xDEEB #x6EC4 -#xDEEC #x6EB2 -#xDEED #x6ED4 -#xDEEE #x6ED5 -#xDEEF #x6E8F -#xDEF0 #x6EA5 -#xDEF1 #x6EC2 -#xDEF2 #x6E9F -#xDEF3 #x6F41 -#xDEF4 #x6F11 -#xDEF5 #x704C -#xDEF6 #x6EEC -#xDEF7 #x6EF8 -#xDEF8 #x6EFE -#xDEF9 #x6F3F -#xDEFA #x6EF2 -#xDEFB #x6F31 -#xDEFC #x6EEF -#xDEFD #x6F32 -#xDEFE #x6ECC -#xDFA1 #x6F3E -#xDFA2 #x6F13 -#xDFA3 #x6EF7 -#xDFA4 #x6F86 -#xDFA5 #x6F7A -#xDFA6 #x6F78 -#xDFA7 #x6F81 -#xDFA8 #x6F80 -#xDFA9 #x6F6F -#xDFAA #x6F5B -#xDFAB #x6FF3 -#xDFAC #x6F6D -#xDFAD #x6F82 -#xDFAE #x6F7C -#xDFAF #x6F58 -#xDFB0 #x6F8E -#xDFB1 #x6F91 -#xDFB2 #x6FC2 -#xDFB3 #x6F66 -#xDFB4 #x6FB3 -#xDFB5 #x6FA3 -#xDFB6 #x6FA1 -#xDFB7 #x6FA4 -#xDFB8 #x6FB9 -#xDFB9 #x6FC6 -#xDFBA #x6FAA -#xDFBB #x6FDF -#xDFBC #x6FD5 -#xDFBD #x6FEC -#xDFBE #x6FD4 -#xDFBF #x6FD8 -#xDFC0 #x6FF1 -#xDFC1 #x6FEE -#xDFC2 #x6FDB -#xDFC3 #x7009 -#xDFC4 #x700B -#xDFC5 #x6FFA -#xDFC6 #x7011 -#xDFC7 #x7001 -#xDFC8 #x700F -#xDFC9 #x6FFE -#xDFCA #x701B -#xDFCB #x701A -#xDFCC #x6F74 -#xDFCD #x701D -#xDFCE #x7018 -#xDFCF #x701F -#xDFD0 #x7030 -#xDFD1 #x703E -#xDFD2 #x7032 -#xDFD3 #x7051 -#xDFD4 #x7063 -#xDFD5 #x7099 -#xDFD6 #x7092 -#xDFD7 #x70AF -#xDFD8 #x70F1 -#xDFD9 #x70AC -#xDFDA #x70B8 -#xDFDB #x70B3 -#xDFDC #x70AE -#xDFDD #x70DF -#xDFDE #x70CB -#xDFDF #x70DD -#xDFE0 #x70D9 -#xDFE1 #x7109 -#xDFE2 #x70FD -#xDFE3 #x711C -#xDFE4 #x7119 -#xDFE5 #x7165 -#xDFE6 #x7155 -#xDFE7 #x7188 -#xDFE8 #x7166 -#xDFE9 #x7162 -#xDFEA #x714C -#xDFEB #x7156 -#xDFEC #x716C -#xDFED #x718F -#xDFEE #x71FB -#xDFEF #x7184 -#xDFF0 #x7195 -#xDFF1 #x71A8 -#xDFF2 #x71AC -#xDFF3 #x71D7 -#xDFF4 #x71B9 -#xDFF5 #x71BE -#xDFF6 #x71D2 -#xDFF7 #x71C9 -#xDFF8 #x71D4 -#xDFF9 #x71CE -#xDFFA #x71E0 -#xDFFB #x71EC -#xDFFC #x71E7 -#xDFFD #x71F5 -#xDFFE #x71FC -#xE0A1 #x71F9 -#xE0A2 #x71FF -#xE0A3 #x720D -#xE0A4 #x7210 -#xE0A5 #x721B -#xE0A6 #x7228 -#xE0A7 #x722D -#xE0A8 #x722C -#xE0A9 #x7230 -#xE0AA #x7232 -#xE0AB #x723B -#xE0AC #x723C -#xE0AD #x723F -#xE0AE #x7240 -#xE0AF #x7246 -#xE0B0 #x724B -#xE0B1 #x7258 -#xE0B2 #x7274 -#xE0B3 #x727E -#xE0B4 #x7282 -#xE0B5 #x7281 -#xE0B6 #x7287 -#xE0B7 #x7292 -#xE0B8 #x7296 -#xE0B9 #x72A2 -#xE0BA #x72A7 -#xE0BB #x72B9 -#xE0BC #x72B2 -#xE0BD #x72C3 -#xE0BE #x72C6 -#xE0BF #x72C4 -#xE0C0 #x72CE -#xE0C1 #x72D2 -#xE0C2 #x72E2 -#xE0C3 #x72E0 -#xE0C4 #x72E1 -#xE0C5 #x72F9 -#xE0C6 #x72F7 -#xE0C7 #x500F -#xE0C8 #x7317 -#xE0C9 #x730A -#xE0CA #x731C -#xE0CB #x7316 -#xE0CC #x731D -#xE0CD #x7334 -#xE0CE #x732F -#xE0CF #x7329 -#xE0D0 #x7325 -#xE0D1 #x733E -#xE0D2 #x734E -#xE0D3 #x734F -#xE0D4 #x9ED8 -#xE0D5 #x7357 -#xE0D6 #x736A -#xE0D7 #x7368 -#xE0D8 #x7370 -#xE0D9 #x7378 -#xE0DA #x7375 -#xE0DB #x737B -#xE0DC #x737A -#xE0DD #x73C8 -#xE0DE #x73B3 -#xE0DF #x73CE -#xE0E0 #x73BB -#xE0E1 #x73C0 -#xE0E2 #x73E5 -#xE0E3 #x73EE -#xE0E4 #x73DE -#xE0E5 #x74A2 -#xE0E6 #x7405 -#xE0E7 #x746F -#xE0E8 #x7425 -#xE0E9 #x73F8 -#xE0EA #x7432 -#xE0EB #x743A -#xE0EC #x7455 -#xE0ED #x743F -#xE0EE #x745F -#xE0EF #x7459 -#xE0F0 #x7441 -#xE0F1 #x745C -#xE0F2 #x7469 -#xE0F3 #x7470 -#xE0F4 #x7463 -#xE0F5 #x746A -#xE0F6 #x7476 -#xE0F7 #x747E -#xE0F8 #x748B -#xE0F9 #x749E -#xE0FA #x74A7 -#xE0FB #x74CA -#xE0FC #x74CF -#xE0FD #x74D4 -#xE0FE #x73F1 -#xE1A1 #x74E0 -#xE1A2 #x74E3 -#xE1A3 #x74E7 -#xE1A4 #x74E9 -#xE1A5 #x74EE -#xE1A6 #x74F2 -#xE1A7 #x74F0 -#xE1A8 #x74F1 -#xE1A9 #x74F8 -#xE1AA #x74F7 -#xE1AB #x7504 -#xE1AC #x7503 -#xE1AD #x7505 -#xE1AE #x750C -#xE1AF #x750E -#xE1B0 #x750D -#xE1B1 #x7515 -#xE1B2 #x7513 -#xE1B3 #x751E -#xE1B4 #x7526 -#xE1B5 #x752C -#xE1B6 #x753C -#xE1B7 #x7544 -#xE1B8 #x754D -#xE1B9 #x754A -#xE1BA #x7549 -#xE1BB #x755B -#xE1BC #x7546 -#xE1BD #x755A -#xE1BE #x7569 -#xE1BF #x7564 -#xE1C0 #x7567 -#xE1C1 #x756B -#xE1C2 #x756D -#xE1C3 #x7578 -#xE1C4 #x7576 -#xE1C5 #x7586 -#xE1C6 #x7587 -#xE1C7 #x7574 -#xE1C8 #x758A -#xE1C9 #x7589 -#xE1CA #x7582 -#xE1CB #x7594 -#xE1CC #x759A -#xE1CD #x759D -#xE1CE #x75A5 -#xE1CF #x75A3 -#xE1D0 #x75C2 -#xE1D1 #x75B3 -#xE1D2 #x75C3 -#xE1D3 #x75B5 -#xE1D4 #x75BD -#xE1D5 #x75B8 -#xE1D6 #x75BC -#xE1D7 #x75B1 -#xE1D8 #x75CD -#xE1D9 #x75CA -#xE1DA #x75D2 -#xE1DB #x75D9 -#xE1DC #x75E3 -#xE1DD #x75DE -#xE1DE #x75FE -#xE1DF #x75FF -#xE1E0 #x75FC -#xE1E1 #x7601 -#xE1E2 #x75F0 -#xE1E3 #x75FA -#xE1E4 #x75F2 -#xE1E5 #x75F3 -#xE1E6 #x760B -#xE1E7 #x760D -#xE1E8 #x7609 -#xE1E9 #x761F -#xE1EA #x7627 -#xE1EB #x7620 -#xE1EC #x7621 -#xE1ED #x7622 -#xE1EE #x7624 -#xE1EF #x7634 -#xE1F0 #x7630 -#xE1F1 #x763B -#xE1F2 #x7647 -#xE1F3 #x7648 -#xE1F4 #x7646 -#xE1F5 #x765C -#xE1F6 #x7658 -#xE1F7 #x7661 -#xE1F8 #x7662 -#xE1F9 #x7668 -#xE1FA #x7669 -#xE1FB #x766A -#xE1FC #x7667 -#xE1FD #x766C -#xE1FE #x7670 -#xE2A1 #x7672 -#xE2A2 #x7676 -#xE2A3 #x7678 -#xE2A4 #x767C -#xE2A5 #x7680 -#xE2A6 #x7683 -#xE2A7 #x7688 -#xE2A8 #x768B -#xE2A9 #x768E -#xE2AA #x7696 -#xE2AB #x7693 -#xE2AC #x7699 -#xE2AD #x769A -#xE2AE #x76B0 -#xE2AF #x76B4 -#xE2B0 #x76B8 -#xE2B1 #x76B9 -#xE2B2 #x76BA -#xE2B3 #x76C2 -#xE2B4 #x76CD -#xE2B5 #x76D6 -#xE2B6 #x76D2 -#xE2B7 #x76DE -#xE2B8 #x76E1 -#xE2B9 #x76E5 -#xE2BA #x76E7 -#xE2BB #x76EA -#xE2BC #x862F -#xE2BD #x76FB -#xE2BE #x7708 -#xE2BF #x7707 -#xE2C0 #x7704 -#xE2C1 #x7729 -#xE2C2 #x7724 -#xE2C3 #x771E -#xE2C4 #x7725 -#xE2C5 #x7726 -#xE2C6 #x771B -#xE2C7 #x7737 -#xE2C8 #x7738 -#xE2C9 #x7747 -#xE2CA #x775A -#xE2CB #x7768 -#xE2CC #x776B -#xE2CD #x775B -#xE2CE #x7765 -#xE2CF #x777F -#xE2D0 #x777E -#xE2D1 #x7779 -#xE2D2 #x778E -#xE2D3 #x778B -#xE2D4 #x7791 -#xE2D5 #x77A0 -#xE2D6 #x779E -#xE2D7 #x77B0 -#xE2D8 #x77B6 -#xE2D9 #x77B9 -#xE2DA #x77BF -#xE2DB #x77BC -#xE2DC #x77BD -#xE2DD #x77BB -#xE2DE #x77C7 -#xE2DF #x77CD -#xE2E0 #x77D7 -#xE2E1 #x77DA -#xE2E2 #x77DC -#xE2E3 #x77E3 -#xE2E4 #x77EE -#xE2E5 #x77FC -#xE2E6 #x780C -#xE2E7 #x7812 -#xE2E8 #x7926 -#xE2E9 #x7820 -#xE2EA #x792A -#xE2EB #x7845 -#xE2EC #x788E -#xE2ED #x7874 -#xE2EE #x7886 -#xE2EF #x787C -#xE2F0 #x789A -#xE2F1 #x788C -#xE2F2 #x78A3 -#xE2F3 #x78B5 -#xE2F4 #x78AA -#xE2F5 #x78AF -#xE2F6 #x78D1 -#xE2F7 #x78C6 -#xE2F8 #x78CB -#xE2F9 #x78D4 -#xE2FA #x78BE -#xE2FB #x78BC -#xE2FC #x78C5 -#xE2FD #x78CA -#xE2FE #x78EC -#xE3A1 #x78E7 -#xE3A2 #x78DA -#xE3A3 #x78FD -#xE3A4 #x78F4 -#xE3A5 #x7907 -#xE3A6 #x7912 -#xE3A7 #x7911 -#xE3A8 #x7919 -#xE3A9 #x792C -#xE3AA #x792B -#xE3AB #x7940 -#xE3AC #x7960 -#xE3AD #x7957 -#xE3AE #x795F -#xE3AF #x795A -#xE3B0 #x7955 -#xE3B1 #x7953 -#xE3B2 #x797A -#xE3B3 #x797F -#xE3B4 #x798A -#xE3B5 #x799D -#xE3B6 #x79A7 -#xE3B7 #x9F4B -#xE3B8 #x79AA -#xE3B9 #x79AE -#xE3BA #x79B3 -#xE3BB #x79B9 -#xE3BC #x79BA -#xE3BD #x79C9 -#xE3BE #x79D5 -#xE3BF #x79E7 -#xE3C0 #x79EC -#xE3C1 #x79E1 -#xE3C2 #x79E3 -#xE3C3 #x7A08 -#xE3C4 #x7A0D -#xE3C5 #x7A18 -#xE3C6 #x7A19 -#xE3C7 #x7A20 -#xE3C8 #x7A1F -#xE3C9 #x7980 -#xE3CA #x7A31 -#xE3CB #x7A3B -#xE3CC #x7A3E -#xE3CD #x7A37 -#xE3CE #x7A43 -#xE3CF #x7A57 -#xE3D0 #x7A49 -#xE3D1 #x7A61 -#xE3D2 #x7A62 -#xE3D3 #x7A69 -#xE3D4 #x9F9D -#xE3D5 #x7A70 -#xE3D6 #x7A79 -#xE3D7 #x7A7D -#xE3D8 #x7A88 -#xE3D9 #x7A97 -#xE3DA #x7A95 -#xE3DB #x7A98 -#xE3DC #x7A96 -#xE3DD #x7AA9 -#xE3DE #x7AC8 -#xE3DF #x7AB0 -#xE3E0 #x7AB6 -#xE3E1 #x7AC5 -#xE3E2 #x7AC4 -#xE3E3 #x7ABF -#xE3E4 #x9083 -#xE3E5 #x7AC7 -#xE3E6 #x7ACA -#xE3E7 #x7ACD -#xE3E8 #x7ACF -#xE3E9 #x7AD5 -#xE3EA #x7AD3 -#xE3EB #x7AD9 -#xE3EC #x7ADA -#xE3ED #x7ADD -#xE3EE #x7AE1 -#xE3EF #x7AE2 -#xE3F0 #x7AE6 -#xE3F1 #x7AED -#xE3F2 #x7AF0 -#xE3F3 #x7B02 -#xE3F4 #x7B0F -#xE3F5 #x7B0A -#xE3F6 #x7B06 -#xE3F7 #x7B33 -#xE3F8 #x7B18 -#xE3F9 #x7B19 -#xE3FA #x7B1E -#xE3FB #x7B35 -#xE3FC #x7B28 -#xE3FD #x7B36 -#xE3FE #x7B50 -#xE4A1 #x7B7A -#xE4A2 #x7B04 -#xE4A3 #x7B4D -#xE4A4 #x7B0B -#xE4A5 #x7B4C -#xE4A6 #x7B45 -#xE4A7 #x7B75 -#xE4A8 #x7B65 -#xE4A9 #x7B74 -#xE4AA #x7B67 -#xE4AB #x7B70 -#xE4AC #x7B71 -#xE4AD #x7B6C -#xE4AE #x7B6E -#xE4AF #x7B9D -#xE4B0 #x7B98 -#xE4B1 #x7B9F -#xE4B2 #x7B8D -#xE4B3 #x7B9C -#xE4B4 #x7B9A -#xE4B5 #x7B8B -#xE4B6 #x7B92 -#xE4B7 #x7B8F -#xE4B8 #x7B5D -#xE4B9 #x7B99 -#xE4BA #x7BCB -#xE4BB #x7BC1 -#xE4BC #x7BCC -#xE4BD #x7BCF -#xE4BE #x7BB4 -#xE4BF #x7BC6 -#xE4C0 #x7BDD -#xE4C1 #x7BE9 -#xE4C2 #x7C11 -#xE4C3 #x7C14 -#xE4C4 #x7BE6 -#xE4C5 #x7BE5 -#xE4C6 #x7C60 -#xE4C7 #x7C00 -#xE4C8 #x7C07 -#xE4C9 #x7C13 -#xE4CA #x7BF3 -#xE4CB #x7BF7 -#xE4CC #x7C17 -#xE4CD #x7C0D -#xE4CE #x7BF6 -#xE4CF #x7C23 -#xE4D0 #x7C27 -#xE4D1 #x7C2A -#xE4D2 #x7C1F -#xE4D3 #x7C37 -#xE4D4 #x7C2B -#xE4D5 #x7C3D -#xE4D6 #x7C4C -#xE4D7 #x7C43 -#xE4D8 #x7C54 -#xE4D9 #x7C4F -#xE4DA #x7C40 -#xE4DB #x7C50 -#xE4DC #x7C58 -#xE4DD #x7C5F -#xE4DE #x7C64 -#xE4DF #x7C56 -#xE4E0 #x7C65 -#xE4E1 #x7C6C -#xE4E2 #x7C75 -#xE4E3 #x7C83 -#xE4E4 #x7C90 -#xE4E5 #x7CA4 -#xE4E6 #x7CAD -#xE4E7 #x7CA2 -#xE4E8 #x7CAB -#xE4E9 #x7CA1 -#xE4EA #x7CA8 -#xE4EB #x7CB3 -#xE4EC #x7CB2 -#xE4ED #x7CB1 -#xE4EE #x7CAE -#xE4EF #x7CB9 -#xE4F0 #x7CBD -#xE4F1 #x7CC0 -#xE4F2 #x7CC5 -#xE4F3 #x7CC2 -#xE4F4 #x7CD8 -#xE4F5 #x7CD2 -#xE4F6 #x7CDC -#xE4F7 #x7CE2 -#xE4F8 #x9B3B -#xE4F9 #x7CEF -#xE4FA #x7CF2 -#xE4FB #x7CF4 -#xE4FC #x7CF6 -#xE4FD #x7CFA -#xE4FE #x7D06 -#xE5A1 #x7D02 -#xE5A2 #x7D1C -#xE5A3 #x7D15 -#xE5A4 #x7D0A -#xE5A5 #x7D45 -#xE5A6 #x7D4B -#xE5A7 #x7D2E -#xE5A8 #x7D32 -#xE5A9 #x7D3F -#xE5AA #x7D35 -#xE5AB #x7D46 -#xE5AC #x7D73 -#xE5AD #x7D56 -#xE5AE #x7D4E -#xE5AF #x7D72 -#xE5B0 #x7D68 -#xE5B1 #x7D6E -#xE5B2 #x7D4F -#xE5B3 #x7D63 -#xE5B4 #x7D93 -#xE5B5 #x7D89 -#xE5B6 #x7D5B -#xE5B7 #x7D8F -#xE5B8 #x7D7D -#xE5B9 #x7D9B -#xE5BA #x7DBA -#xE5BB #x7DAE -#xE5BC #x7DA3 -#xE5BD #x7DB5 -#xE5BE #x7DC7 -#xE5BF #x7DBD -#xE5C0 #x7DAB -#xE5C1 #x7E3D -#xE5C2 #x7DA2 -#xE5C3 #x7DAF -#xE5C4 #x7DDC -#xE5C5 #x7DB8 -#xE5C6 #x7D9F -#xE5C7 #x7DB0 -#xE5C8 #x7DD8 -#xE5C9 #x7DDD -#xE5CA #x7DE4 -#xE5CB #x7DDE -#xE5CC #x7DFB -#xE5CD #x7DF2 -#xE5CE #x7DE1 -#xE5CF #x7E05 -#xE5D0 #x7E0A -#xE5D1 #x7E23 -#xE5D2 #x7E21 -#xE5D3 #x7E12 -#xE5D4 #x7E31 -#xE5D5 #x7E1F -#xE5D6 #x7E09 -#xE5D7 #x7E0B -#xE5D8 #x7E22 -#xE5D9 #x7E46 -#xE5DA #x7E66 -#xE5DB #x7E3B -#xE5DC #x7E35 -#xE5DD #x7E39 -#xE5DE #x7E43 -#xE5DF #x7E37 -#xE5E0 #x7E32 -#xE5E1 #x7E3A -#xE5E2 #x7E67 -#xE5E3 #x7E5D -#xE5E4 #x7E56 -#xE5E5 #x7E5E -#xE5E6 #x7E59 -#xE5E7 #x7E5A -#xE5E8 #x7E79 -#xE5E9 #x7E6A -#xE5EA #x7E69 -#xE5EB #x7E7C -#xE5EC #x7E7B -#xE5ED #x7E83 -#xE5EE #x7DD5 -#xE5EF #x7E7D -#xE5F0 #x8FAE -#xE5F1 #x7E7F -#xE5F2 #x7E88 -#xE5F3 #x7E89 -#xE5F4 #x7E8C -#xE5F5 #x7E92 -#xE5F6 #x7E90 -#xE5F7 #x7E93 -#xE5F8 #x7E94 -#xE5F9 #x7E96 -#xE5FA #x7E8E -#xE5FB #x7E9B -#xE5FC #x7E9C -#xE5FD #x7F38 -#xE5FE #x7F3A -#xE6A1 #x7F45 -#xE6A2 #x7F4C -#xE6A3 #x7F4D -#xE6A4 #x7F4E -#xE6A5 #x7F50 -#xE6A6 #x7F51 -#xE6A7 #x7F55 -#xE6A8 #x7F54 -#xE6A9 #x7F58 -#xE6AA #x7F5F -#xE6AB #x7F60 -#xE6AC #x7F68 -#xE6AD #x7F69 -#xE6AE #x7F67 -#xE6AF #x7F78 -#xE6B0 #x7F82 -#xE6B1 #x7F86 -#xE6B2 #x7F83 -#xE6B3 #x7F88 -#xE6B4 #x7F87 -#xE6B5 #x7F8C -#xE6B6 #x7F94 -#xE6B7 #x7F9E -#xE6B8 #x7F9D -#xE6B9 #x7F9A -#xE6BA #x7FA3 -#xE6BB #x7FAF -#xE6BC #x7FB2 -#xE6BD #x7FB9 -#xE6BE #x7FAE -#xE6BF #x7FB6 -#xE6C0 #x7FB8 -#xE6C1 #x8B71 -#xE6C2 #x7FC5 -#xE6C3 #x7FC6 -#xE6C4 #x7FCA -#xE6C5 #x7FD5 -#xE6C6 #x7FD4 -#xE6C7 #x7FE1 -#xE6C8 #x7FE6 -#xE6C9 #x7FE9 -#xE6CA #x7FF3 -#xE6CB #x7FF9 -#xE6CC #x98DC -#xE6CD #x8006 -#xE6CE #x8004 -#xE6CF #x800B -#xE6D0 #x8012 -#xE6D1 #x8018 -#xE6D2 #x8019 -#xE6D3 #x801C -#xE6D4 #x8021 -#xE6D5 #x8028 -#xE6D6 #x803F -#xE6D7 #x803B -#xE6D8 #x804A -#xE6D9 #x8046 -#xE6DA #x8052 -#xE6DB #x8058 -#xE6DC #x805A -#xE6DD #x805F -#xE6DE #x8062 -#xE6DF #x8068 -#xE6E0 #x8073 -#xE6E1 #x8072 -#xE6E2 #x8070 -#xE6E3 #x8076 -#xE6E4 #x8079 -#xE6E5 #x807D -#xE6E6 #x807F -#xE6E7 #x8084 -#xE6E8 #x8086 -#xE6E9 #x8085 -#xE6EA #x809B -#xE6EB #x8093 -#xE6EC #x809A -#xE6ED #x80AD -#xE6EE #x5190 -#xE6EF #x80AC -#xE6F0 #x80DB -#xE6F1 #x80E5 -#xE6F2 #x80D9 -#xE6F3 #x80DD -#xE6F4 #x80C4 -#xE6F5 #x80DA -#xE6F6 #x80D6 -#xE6F7 #x8109 -#xE6F8 #x80EF -#xE6F9 #x80F1 -#xE6FA #x811B -#xE6FB #x8129 -#xE6FC #x8123 -#xE6FD #x812F -#xE6FE #x814B -#xE7A1 #x968B -#xE7A2 #x8146 -#xE7A3 #x813E -#xE7A4 #x8153 -#xE7A5 #x8151 -#xE7A6 #x80FC -#xE7A7 #x8171 -#xE7A8 #x816E -#xE7A9 #x8165 -#xE7AA #x8166 -#xE7AB #x8174 -#xE7AC #x8183 -#xE7AD #x8188 -#xE7AE #x818A -#xE7AF #x8180 -#xE7B0 #x8182 -#xE7B1 #x81A0 -#xE7B2 #x8195 -#xE7B3 #x81A4 -#xE7B4 #x81A3 -#xE7B5 #x815F -#xE7B6 #x8193 -#xE7B7 #x81A9 -#xE7B8 #x81B0 -#xE7B9 #x81B5 -#xE7BA #x81BE -#xE7BB #x81B8 -#xE7BC #x81BD -#xE7BD #x81C0 -#xE7BE #x81C2 -#xE7BF #x81BA -#xE7C0 #x81C9 -#xE7C1 #x81CD -#xE7C2 #x81D1 -#xE7C3 #x81D9 -#xE7C4 #x81D8 -#xE7C5 #x81C8 -#xE7C6 #x81DA -#xE7C7 #x81DF -#xE7C8 #x81E0 -#xE7C9 #x81E7 -#xE7CA #x81FA -#xE7CB #x81FB -#xE7CC #x81FE -#xE7CD #x8201 -#xE7CE #x8202 -#xE7CF #x8205 -#xE7D0 #x8207 -#xE7D1 #x820A -#xE7D2 #x820D -#xE7D3 #x8210 -#xE7D4 #x8216 -#xE7D5 #x8229 -#xE7D6 #x822B -#xE7D7 #x8238 -#xE7D8 #x8233 -#xE7D9 #x8240 -#xE7DA #x8259 -#xE7DB #x8258 -#xE7DC #x825D -#xE7DD #x825A -#xE7DE #x825F -#xE7DF #x8264 -#xE7E0 #x8262 -#xE7E1 #x8268 -#xE7E2 #x826A -#xE7E3 #x826B -#xE7E4 #x822E -#xE7E5 #x8271 -#xE7E6 #x8277 -#xE7E7 #x8278 -#xE7E8 #x827E -#xE7E9 #x828D -#xE7EA #x8292 -#xE7EB #x82AB -#xE7EC #x829F -#xE7ED #x82BB -#xE7EE #x82AC -#xE7EF #x82E1 -#xE7F0 #x82E3 -#xE7F1 #x82DF -#xE7F2 #x82D2 -#xE7F3 #x82F4 -#xE7F4 #x82F3 -#xE7F5 #x82FA -#xE7F6 #x8393 -#xE7F7 #x8303 -#xE7F8 #x82FB -#xE7F9 #x82F9 -#xE7FA #x82DE -#xE7FB #x8306 -#xE7FC #x82DC -#xE7FD #x8309 -#xE7FE #x82D9 -#xE8A1 #x8335 -#xE8A2 #x8334 -#xE8A3 #x8316 -#xE8A4 #x8332 -#xE8A5 #x8331 -#xE8A6 #x8340 -#xE8A7 #x8339 -#xE8A8 #x8350 -#xE8A9 #x8345 -#xE8AA #x832F -#xE8AB #x832B -#xE8AC #x8317 -#xE8AD #x8318 -#xE8AE #x8385 -#xE8AF #x839A -#xE8B0 #x83AA -#xE8B1 #x839F -#xE8B2 #x83A2 -#xE8B3 #x8396 -#xE8B4 #x8323 -#xE8B5 #x838E -#xE8B6 #x8387 -#xE8B7 #x838A -#xE8B8 #x837C -#xE8B9 #x83B5 -#xE8BA #x8373 -#xE8BB #x8375 -#xE8BC #x83A0 -#xE8BD #x8389 -#xE8BE #x83A8 -#xE8BF #x83F4 -#xE8C0 #x8413 -#xE8C1 #x83EB -#xE8C2 #x83CE -#xE8C3 #x83FD -#xE8C4 #x8403 -#xE8C5 #x83D8 -#xE8C6 #x840B -#xE8C7 #x83C1 -#xE8C8 #x83F7 -#xE8C9 #x8407 -#xE8CA #x83E0 -#xE8CB #x83F2 -#xE8CC #x840D -#xE8CD #x8422 -#xE8CE #x8420 -#xE8CF #x83BD -#xE8D0 #x8438 -#xE8D1 #x8506 -#xE8D2 #x83FB -#xE8D3 #x846D -#xE8D4 #x842A -#xE8D5 #x843C -#xE8D6 #x855A -#xE8D7 #x8484 -#xE8D8 #x8477 -#xE8D9 #x846B -#xE8DA #x84AD -#xE8DB #x846E -#xE8DC #x8482 -#xE8DD #x8469 -#xE8DE #x8446 -#xE8DF #x842C -#xE8E0 #x846F -#xE8E1 #x8479 -#xE8E2 #x8435 -#xE8E3 #x84CA -#xE8E4 #x8462 -#xE8E5 #x84B9 -#xE8E6 #x84BF -#xE8E7 #x849F -#xE8E8 #x84D9 -#xE8E9 #x84CD -#xE8EA #x84BB -#xE8EB #x84DA -#xE8EC #x84D0 -#xE8ED #x84C1 -#xE8EE #x84C6 -#xE8EF #x84D6 -#xE8F0 #x84A1 -#xE8F1 #x8521 -#xE8F2 #x84FF -#xE8F3 #x84F4 -#xE8F4 #x8517 -#xE8F5 #x8518 -#xE8F6 #x852C -#xE8F7 #x851F -#xE8F8 #x8515 -#xE8F9 #x8514 -#xE8FA #x84FC -#xE8FB #x8540 -#xE8FC #x8563 -#xE8FD #x8558 -#xE8FE #x8548 -#xE9A1 #x8541 -#xE9A2 #x8602 -#xE9A3 #x854B -#xE9A4 #x8555 -#xE9A5 #x8580 -#xE9A6 #x85A4 -#xE9A7 #x8588 -#xE9A8 #x8591 -#xE9A9 #x858A -#xE9AA #x85A8 -#xE9AB #x856D -#xE9AC #x8594 -#xE9AD #x859B -#xE9AE #x85EA -#xE9AF #x8587 -#xE9B0 #x859C -#xE9B1 #x8577 -#xE9B2 #x857E -#xE9B3 #x8590 -#xE9B4 #x85C9 -#xE9B5 #x85BA -#xE9B6 #x85CF -#xE9B7 #x85B9 -#xE9B8 #x85D0 -#xE9B9 #x85D5 -#xE9BA #x85DD -#xE9BB #x85E5 -#xE9BC #x85DC -#xE9BD #x85F9 -#xE9BE #x860A -#xE9BF #x8613 -#xE9C0 #x860B -#xE9C1 #x85FE -#xE9C2 #x85FA -#xE9C3 #x8606 -#xE9C4 #x8622 -#xE9C5 #x861A -#xE9C6 #x8630 -#xE9C7 #x863F -#xE9C8 #x864D -#xE9C9 #x4E55 -#xE9CA #x8654 -#xE9CB #x865F -#xE9CC #x8667 -#xE9CD #x8671 -#xE9CE #x8693 -#xE9CF #x86A3 -#xE9D0 #x86A9 -#xE9D1 #x86AA -#xE9D2 #x868B -#xE9D3 #x868C -#xE9D4 #x86B6 -#xE9D5 #x86AF -#xE9D6 #x86C4 -#xE9D7 #x86C6 -#xE9D8 #x86B0 -#xE9D9 #x86C9 -#xE9DA #x8823 -#xE9DB #x86AB -#xE9DC #x86D4 -#xE9DD #x86DE -#xE9DE #x86E9 -#xE9DF #x86EC -#xE9E0 #x86DF -#xE9E1 #x86DB -#xE9E2 #x86EF -#xE9E3 #x8712 -#xE9E4 #x8706 -#xE9E5 #x8708 -#xE9E6 #x8700 -#xE9E7 #x8703 -#xE9E8 #x86FB -#xE9E9 #x8711 -#xE9EA #x8709 -#xE9EB #x870D -#xE9EC #x86F9 -#xE9ED #x870A -#xE9EE #x8734 -#xE9EF #x873F -#xE9F0 #x8737 -#xE9F1 #x873B -#xE9F2 #x8725 -#xE9F3 #x8729 -#xE9F4 #x871A -#xE9F5 #x8760 -#xE9F6 #x875F -#xE9F7 #x8778 -#xE9F8 #x874C -#xE9F9 #x874E -#xE9FA #x8774 -#xE9FB #x8757 -#xE9FC #x8768 -#xE9FD #x876E -#xE9FE #x8759 -#xEAA1 #x8753 -#xEAA2 #x8763 -#xEAA3 #x876A -#xEAA4 #x8805 -#xEAA5 #x87A2 -#xEAA6 #x879F -#xEAA7 #x8782 -#xEAA8 #x87AF -#xEAA9 #x87CB -#xEAAA #x87BD -#xEAAB #x87C0 -#xEAAC #x87D0 -#xEAAD #x96D6 -#xEAAE #x87AB -#xEAAF #x87C4 -#xEAB0 #x87B3 -#xEAB1 #x87C7 -#xEAB2 #x87C6 -#xEAB3 #x87BB -#xEAB4 #x87EF -#xEAB5 #x87F2 -#xEAB6 #x87E0 -#xEAB7 #x880F -#xEAB8 #x880D -#xEAB9 #x87FE -#xEABA #x87F6 -#xEABB #x87F7 -#xEABC #x880E -#xEABD #x87D2 -#xEABE #x8811 -#xEABF #x8816 -#xEAC0 #x8815 -#xEAC1 #x8822 -#xEAC2 #x8821 -#xEAC3 #x8831 -#xEAC4 #x8836 -#xEAC5 #x8839 -#xEAC6 #x8827 -#xEAC7 #x883B -#xEAC8 #x8844 -#xEAC9 #x8842 -#xEACA #x8852 -#xEACB #x8859 -#xEACC #x885E -#xEACD #x8862 -#xEACE #x886B -#xEACF #x8881 -#xEAD0 #x887E -#xEAD1 #x889E -#xEAD2 #x8875 -#xEAD3 #x887D -#xEAD4 #x88B5 -#xEAD5 #x8872 -#xEAD6 #x8882 -#xEAD7 #x8897 -#xEAD8 #x8892 -#xEAD9 #x88AE -#xEADA #x8899 -#xEADB #x88A2 -#xEADC #x888D -#xEADD #x88A4 -#xEADE #x88B0 -#xEADF #x88BF -#xEAE0 #x88B1 -#xEAE1 #x88C3 -#xEAE2 #x88C4 -#xEAE3 #x88D4 -#xEAE4 #x88D8 -#xEAE5 #x88D9 -#xEAE6 #x88DD -#xEAE7 #x88F9 -#xEAE8 #x8902 -#xEAE9 #x88FC -#xEAEA #x88F4 -#xEAEB #x88E8 -#xEAEC #x88F2 -#xEAED #x8904 -#xEAEE #x890C -#xEAEF #x890A -#xEAF0 #x8913 -#xEAF1 #x8943 -#xEAF2 #x891E -#xEAF3 #x8925 -#xEAF4 #x892A -#xEAF5 #x892B -#xEAF6 #x8941 -#xEAF7 #x8944 -#xEAF8 #x893B -#xEAF9 #x8936 -#xEAFA #x8938 -#xEAFB #x894C -#xEAFC #x891D -#xEAFD #x8960 -#xEAFE #x895E -#xEBA1 #x8966 -#xEBA2 #x8964 -#xEBA3 #x896D -#xEBA4 #x896A -#xEBA5 #x896F -#xEBA6 #x8974 -#xEBA7 #x8977 -#xEBA8 #x897E -#xEBA9 #x8983 -#xEBAA #x8988 -#xEBAB #x898A -#xEBAC #x8993 -#xEBAD #x8998 -#xEBAE #x89A1 -#xEBAF #x89A9 -#xEBB0 #x89A6 -#xEBB1 #x89AC -#xEBB2 #x89AF -#xEBB3 #x89B2 -#xEBB4 #x89BA -#xEBB5 #x89BD -#xEBB6 #x89BF -#xEBB7 #x89C0 -#xEBB8 #x89DA -#xEBB9 #x89DC -#xEBBA #x89DD -#xEBBB #x89E7 -#xEBBC #x89F4 -#xEBBD #x89F8 -#xEBBE #x8A03 -#xEBBF #x8A16 -#xEBC0 #x8A10 -#xEBC1 #x8A0C -#xEBC2 #x8A1B -#xEBC3 #x8A1D -#xEBC4 #x8A25 -#xEBC5 #x8A36 -#xEBC6 #x8A41 -#xEBC7 #x8A5B -#xEBC8 #x8A52 -#xEBC9 #x8A46 -#xEBCA #x8A48 -#xEBCB #x8A7C -#xEBCC #x8A6D -#xEBCD #x8A6C -#xEBCE #x8A62 -#xEBCF #x8A85 -#xEBD0 #x8A82 -#xEBD1 #x8A84 -#xEBD2 #x8AA8 -#xEBD3 #x8AA1 -#xEBD4 #x8A91 -#xEBD5 #x8AA5 -#xEBD6 #x8AA6 -#xEBD7 #x8A9A -#xEBD8 #x8AA3 -#xEBD9 #x8AC4 -#xEBDA #x8ACD -#xEBDB #x8AC2 -#xEBDC #x8ADA -#xEBDD #x8AEB -#xEBDE #x8AF3 -#xEBDF #x8AE7 -#xEBE0 #x8AE4 -#xEBE1 #x8AF1 -#xEBE2 #x8B14 -#xEBE3 #x8AE0 -#xEBE4 #x8AE2 -#xEBE5 #x8AF7 -#xEBE6 #x8ADE -#xEBE7 #x8ADB -#xEBE8 #x8B0C -#xEBE9 #x8B07 -#xEBEA #x8B1A -#xEBEB #x8AE1 -#xEBEC #x8B16 -#xEBED #x8B10 -#xEBEE #x8B17 -#xEBEF #x8B20 -#xEBF0 #x8B33 -#xEBF1 #x97AB -#xEBF2 #x8B26 -#xEBF3 #x8B2B -#xEBF4 #x8B3E -#xEBF5 #x8B28 -#xEBF6 #x8B41 -#xEBF7 #x8B4C -#xEBF8 #x8B4F -#xEBF9 #x8B4E -#xEBFA #x8B49 -#xEBFB #x8B56 -#xEBFC #x8B5B -#xEBFD #x8B5A -#xEBFE #x8B6B -#xECA1 #x8B5F -#xECA2 #x8B6C -#xECA3 #x8B6F -#xECA4 #x8B74 -#xECA5 #x8B7D -#xECA6 #x8B80 -#xECA7 #x8B8C -#xECA8 #x8B8E -#xECA9 #x8B92 -#xECAA #x8B93 -#xECAB #x8B96 -#xECAC #x8B99 -#xECAD #x8B9A -#xECAE #x8C3A -#xECAF #x8C41 -#xECB0 #x8C3F -#xECB1 #x8C48 -#xECB2 #x8C4C -#xECB3 #x8C4E -#xECB4 #x8C50 -#xECB5 #x8C55 -#xECB6 #x8C62 -#xECB7 #x8C6C -#xECB8 #x8C78 -#xECB9 #x8C7A -#xECBA #x8C82 -#xECBB #x8C89 -#xECBC #x8C85 -#xECBD #x8C8A -#xECBE #x8C8D -#xECBF #x8C8E -#xECC0 #x8C94 -#xECC1 #x8C7C -#xECC2 #x8C98 -#xECC3 #x621D -#xECC4 #x8CAD -#xECC5 #x8CAA -#xECC6 #x8CBD -#xECC7 #x8CB2 -#xECC8 #x8CB3 -#xECC9 #x8CAE -#xECCA #x8CB6 -#xECCB #x8CC8 -#xECCC #x8CC1 -#xECCD #x8CE4 -#xECCE #x8CE3 -#xECCF #x8CDA -#xECD0 #x8CFD -#xECD1 #x8CFA -#xECD2 #x8CFB -#xECD3 #x8D04 -#xECD4 #x8D05 -#xECD5 #x8D0A -#xECD6 #x8D07 -#xECD7 #x8D0F -#xECD8 #x8D0D -#xECD9 #x8D10 -#xECDA #x9F4E -#xECDB #x8D13 -#xECDC #x8CCD -#xECDD #x8D14 -#xECDE #x8D16 -#xECDF #x8D67 -#xECE0 #x8D6D -#xECE1 #x8D71 -#xECE2 #x8D73 -#xECE3 #x8D81 -#xECE4 #x8D99 -#xECE5 #x8DC2 -#xECE6 #x8DBE -#xECE7 #x8DBA -#xECE8 #x8DCF -#xECE9 #x8DDA -#xECEA #x8DD6 -#xECEB #x8DCC -#xECEC #x8DDB -#xECED #x8DCB -#xECEE #x8DEA -#xECEF #x8DEB -#xECF0 #x8DDF -#xECF1 #x8DE3 -#xECF2 #x8DFC -#xECF3 #x8E08 -#xECF4 #x8E09 -#xECF5 #x8DFF -#xECF6 #x8E1D -#xECF7 #x8E1E -#xECF8 #x8E10 -#xECF9 #x8E1F -#xECFA #x8E42 -#xECFB #x8E35 -#xECFC #x8E30 -#xECFD #x8E34 -#xECFE #x8E4A -#xEDA1 #x8E47 -#xEDA2 #x8E49 -#xEDA3 #x8E4C -#xEDA4 #x8E50 -#xEDA5 #x8E48 -#xEDA6 #x8E59 -#xEDA7 #x8E64 -#xEDA8 #x8E60 -#xEDA9 #x8E2A -#xEDAA #x8E63 -#xEDAB #x8E55 -#xEDAC #x8E76 -#xEDAD #x8E72 -#xEDAE #x8E7C -#xEDAF #x8E81 -#xEDB0 #x8E87 -#xEDB1 #x8E85 -#xEDB2 #x8E84 -#xEDB3 #x8E8B -#xEDB4 #x8E8A -#xEDB5 #x8E93 -#xEDB6 #x8E91 -#xEDB7 #x8E94 -#xEDB8 #x8E99 -#xEDB9 #x8EAA -#xEDBA #x8EA1 -#xEDBB #x8EAC -#xEDBC #x8EB0 -#xEDBD #x8EC6 -#xEDBE #x8EB1 -#xEDBF #x8EBE -#xEDC0 #x8EC5 -#xEDC1 #x8EC8 -#xEDC2 #x8ECB -#xEDC3 #x8EDB -#xEDC4 #x8EE3 -#xEDC5 #x8EFC -#xEDC6 #x8EFB -#xEDC7 #x8EEB -#xEDC8 #x8EFE -#xEDC9 #x8F0A -#xEDCA #x8F05 -#xEDCB #x8F15 -#xEDCC #x8F12 -#xEDCD #x8F19 -#xEDCE #x8F13 -#xEDCF #x8F1C -#xEDD0 #x8F1F -#xEDD1 #x8F1B -#xEDD2 #x8F0C -#xEDD3 #x8F26 -#xEDD4 #x8F33 -#xEDD5 #x8F3B -#xEDD6 #x8F39 -#xEDD7 #x8F45 -#xEDD8 #x8F42 -#xEDD9 #x8F3E -#xEDDA #x8F4C -#xEDDB #x8F49 -#xEDDC #x8F46 -#xEDDD #x8F4E -#xEDDE #x8F57 -#xEDDF #x8F5C -#xEDE0 #x8F62 -#xEDE1 #x8F63 -#xEDE2 #x8F64 -#xEDE3 #x8F9C -#xEDE4 #x8F9F -#xEDE5 #x8FA3 -#xEDE6 #x8FAD -#xEDE7 #x8FAF -#xEDE8 #x8FB7 -#xEDE9 #x8FDA -#xEDEA #x8FE5 -#xEDEB #x8FE2 -#xEDEC #x8FEA -#xEDED #x8FEF -#xEDEE #x9087 -#xEDEF #x8FF4 -#xEDF0 #x9005 -#xEDF1 #x8FF9 -#xEDF2 #x8FFA -#xEDF3 #x9011 -#xEDF4 #x9015 -#xEDF5 #x9021 -#xEDF6 #x900D -#xEDF7 #x901E -#xEDF8 #x9016 -#xEDF9 #x900B -#xEDFA #x9027 -#xEDFB #x9036 -#xEDFC #x9035 -#xEDFD #x9039 -#xEDFE #x8FF8 -#xEEA1 #x904F -#xEEA2 #x9050 -#xEEA3 #x9051 -#xEEA4 #x9052 -#xEEA5 #x900E -#xEEA6 #x9049 -#xEEA7 #x903E -#xEEA8 #x9056 -#xEEA9 #x9058 -#xEEAA #x905E -#xEEAB #x9068 -#xEEAC #x906F -#xEEAD #x9076 -#xEEAE #x96A8 -#xEEAF #x9072 -#xEEB0 #x9082 -#xEEB1 #x907D -#xEEB2 #x9081 -#xEEB3 #x9080 -#xEEB4 #x908A -#xEEB5 #x9089 -#xEEB6 #x908F -#xEEB7 #x90A8 -#xEEB8 #x90AF -#xEEB9 #x90B1 -#xEEBA #x90B5 -#xEEBB #x90E2 -#xEEBC #x90E4 -#xEEBD #x6248 -#xEEBE #x90DB -#xEEBF #x9102 -#xEEC0 #x9112 -#xEEC1 #x9119 -#xEEC2 #x9132 -#xEEC3 #x9130 -#xEEC4 #x914A -#xEEC5 #x9156 -#xEEC6 #x9158 -#xEEC7 #x9163 -#xEEC8 #x9165 -#xEEC9 #x9169 -#xEECA #x9173 -#xEECB #x9172 -#xEECC #x918B -#xEECD #x9189 -#xEECE #x9182 -#xEECF #x91A2 -#xEED0 #x91AB -#xEED1 #x91AF -#xEED2 #x91AA -#xEED3 #x91B5 -#xEED4 #x91B4 -#xEED5 #x91BA -#xEED6 #x91C0 -#xEED7 #x91C1 -#xEED8 #x91C9 -#xEED9 #x91CB -#xEEDA #x91D0 -#xEEDB #x91D6 -#xEEDC #x91DF -#xEEDD #x91E1 -#xEEDE #x91DB -#xEEDF #x91FC -#xEEE0 #x91F5 -#xEEE1 #x91F6 -#xEEE2 #x921E -#xEEE3 #x91FF -#xEEE4 #x9214 -#xEEE5 #x922C -#xEEE6 #x9215 -#xEEE7 #x9211 -#xEEE8 #x925E -#xEEE9 #x9257 -#xEEEA #x9245 -#xEEEB #x9249 -#xEEEC #x9264 -#xEEED #x9248 -#xEEEE #x9295 -#xEEEF #x923F -#xEEF0 #x924B -#xEEF1 #x9250 -#xEEF2 #x929C -#xEEF3 #x9296 -#xEEF4 #x9293 -#xEEF5 #x929B -#xEEF6 #x925A -#xEEF7 #x92CF -#xEEF8 #x92B9 -#xEEF9 #x92B7 -#xEEFA #x92E9 -#xEEFB #x930F -#xEEFC #x92FA -#xEEFD #x9344 -#xEEFE #x932E -#xEFA1 #x9319 -#xEFA2 #x9322 -#xEFA3 #x931A -#xEFA4 #x9323 -#xEFA5 #x933A -#xEFA6 #x9335 -#xEFA7 #x933B -#xEFA8 #x935C -#xEFA9 #x9360 -#xEFAA #x937C -#xEFAB #x936E -#xEFAC #x9356 -#xEFAD #x93B0 -#xEFAE #x93AC -#xEFAF #x93AD -#xEFB0 #x9394 -#xEFB1 #x93B9 -#xEFB2 #x93D6 -#xEFB3 #x93D7 -#xEFB4 #x93E8 -#xEFB5 #x93E5 -#xEFB6 #x93D8 -#xEFB7 #x93C3 -#xEFB8 #x93DD -#xEFB9 #x93D0 -#xEFBA #x93C8 -#xEFBB #x93E4 -#xEFBC #x941A -#xEFBD #x9414 -#xEFBE #x9413 -#xEFBF #x9403 -#xEFC0 #x9407 -#xEFC1 #x9410 -#xEFC2 #x9436 -#xEFC3 #x942B -#xEFC4 #x9435 -#xEFC5 #x9421 -#xEFC6 #x943A -#xEFC7 #x9441 -#xEFC8 #x9452 -#xEFC9 #x9444 -#xEFCA #x945B -#xEFCB #x9460 -#xEFCC #x9462 -#xEFCD #x945E -#xEFCE #x946A -#xEFCF #x9229 -#xEFD0 #x9470 -#xEFD1 #x9475 -#xEFD2 #x9477 -#xEFD3 #x947D -#xEFD4 #x945A -#xEFD5 #x947C -#xEFD6 #x947E -#xEFD7 #x9481 -#xEFD8 #x947F -#xEFD9 #x9582 -#xEFDA #x9587 -#xEFDB #x958A -#xEFDC #x9594 -#xEFDD #x9596 -#xEFDE #x9598 -#xEFDF #x9599 -#xEFE0 #x95A0 -#xEFE1 #x95A8 -#xEFE2 #x95A7 -#xEFE3 #x95AD -#xEFE4 #x95BC -#xEFE5 #x95BB -#xEFE6 #x95B9 -#xEFE7 #x95BE -#xEFE8 #x95CA -#xEFE9 #x6FF6 -#xEFEA #x95C3 -#xEFEB #x95CD -#xEFEC #x95CC -#xEFED #x95D5 -#xEFEE #x95D4 -#xEFEF #x95D6 -#xEFF0 #x95DC -#xEFF1 #x95E1 -#xEFF2 #x95E5 -#xEFF3 #x95E2 -#xEFF4 #x9621 -#xEFF5 #x9628 -#xEFF6 #x962E -#xEFF7 #x962F -#xEFF8 #x9642 -#xEFF9 #x964C -#xEFFA #x964F -#xEFFB #x964B -#xEFFC #x9677 -#xEFFD #x965C -#xEFFE #x965E -#xF0A1 #x965D -#xF0A2 #x965F -#xF0A3 #x9666 -#xF0A4 #x9672 -#xF0A5 #x966C -#xF0A6 #x968D -#xF0A7 #x9698 -#xF0A8 #x9695 -#xF0A9 #x9697 -#xF0AA #x96AA -#xF0AB #x96A7 -#xF0AC #x96B1 -#xF0AD #x96B2 -#xF0AE #x96B0 -#xF0AF #x96B4 -#xF0B0 #x96B6 -#xF0B1 #x96B8 -#xF0B2 #x96B9 -#xF0B3 #x96CE -#xF0B4 #x96CB -#xF0B5 #x96C9 -#xF0B6 #x96CD -#xF0B7 #x894D -#xF0B8 #x96DC -#xF0B9 #x970D -#xF0BA #x96D5 -#xF0BB #x96F9 -#xF0BC #x9704 -#xF0BD #x9706 -#xF0BE #x9708 -#xF0BF #x9713 -#xF0C0 #x970E -#xF0C1 #x9711 -#xF0C2 #x970F -#xF0C3 #x9716 -#xF0C4 #x9719 -#xF0C5 #x9724 -#xF0C6 #x972A -#xF0C7 #x9730 -#xF0C8 #x9739 -#xF0C9 #x973D -#xF0CA #x973E -#xF0CB #x9744 -#xF0CC #x9746 -#xF0CD #x9748 -#xF0CE #x9742 -#xF0CF #x9749 -#xF0D0 #x975C -#xF0D1 #x9760 -#xF0D2 #x9764 -#xF0D3 #x9766 -#xF0D4 #x9768 -#xF0D5 #x52D2 -#xF0D6 #x976B -#xF0D7 #x9771 -#xF0D8 #x9779 -#xF0D9 #x9785 -#xF0DA #x977C -#xF0DB #x9781 -#xF0DC #x977A -#xF0DD #x9786 -#xF0DE #x978B -#xF0DF #x978F -#xF0E0 #x9790 -#xF0E1 #x979C -#xF0E2 #x97A8 -#xF0E3 #x97A6 -#xF0E4 #x97A3 -#xF0E5 #x97B3 -#xF0E6 #x97B4 -#xF0E7 #x97C3 -#xF0E8 #x97C6 -#xF0E9 #x97C8 -#xF0EA #x97CB -#xF0EB #x97DC -#xF0EC #x97ED -#xF0ED #x9F4F -#xF0EE #x97F2 -#xF0EF #x7ADF -#xF0F0 #x97F6 -#xF0F1 #x97F5 -#xF0F2 #x980F -#xF0F3 #x980C -#xF0F4 #x9838 -#xF0F5 #x9824 -#xF0F6 #x9821 -#xF0F7 #x9837 -#xF0F8 #x983D -#xF0F9 #x9846 -#xF0FA #x984F -#xF0FB #x984B -#xF0FC #x986B -#xF0FD #x986F -#xF0FE #x9870 -#xF1A1 #x9871 -#xF1A2 #x9874 -#xF1A3 #x9873 -#xF1A4 #x98AA -#xF1A5 #x98AF -#xF1A6 #x98B1 -#xF1A7 #x98B6 -#xF1A8 #x98C4 -#xF1A9 #x98C3 -#xF1AA #x98C6 -#xF1AB #x98E9 -#xF1AC #x98EB -#xF1AD #x9903 -#xF1AE #x9909 -#xF1AF #x9912 -#xF1B0 #x9914 -#xF1B1 #x9918 -#xF1B2 #x9921 -#xF1B3 #x991D -#xF1B4 #x991E -#xF1B5 #x9924 -#xF1B6 #x9920 -#xF1B7 #x992C -#xF1B8 #x992E -#xF1B9 #x993D -#xF1BA #x993E -#xF1BB #x9942 -#xF1BC #x9949 -#xF1BD #x9945 -#xF1BE #x9950 -#xF1BF #x994B -#xF1C0 #x9951 -#xF1C1 #x9952 -#xF1C2 #x994C -#xF1C3 #x9955 -#xF1C4 #x9997 -#xF1C5 #x9998 -#xF1C6 #x99A5 -#xF1C7 #x99AD -#xF1C8 #x99AE -#xF1C9 #x99BC -#xF1CA #x99DF -#xF1CB #x99DB -#xF1CC #x99DD -#xF1CD #x99D8 -#xF1CE #x99D1 -#xF1CF #x99ED -#xF1D0 #x99EE -#xF1D1 #x99F1 -#xF1D2 #x99F2 -#xF1D3 #x99FB -#xF1D4 #x99F8 -#xF1D5 #x9A01 -#xF1D6 #x9A0F -#xF1D7 #x9A05 -#xF1D8 #x99E2 -#xF1D9 #x9A19 -#xF1DA #x9A2B -#xF1DB #x9A37 -#xF1DC #x9A45 -#xF1DD #x9A42 -#xF1DE #x9A40 -#xF1DF #x9A43 -#xF1E0 #x9A3E -#xF1E1 #x9A55 -#xF1E2 #x9A4D -#xF1E3 #x9A5B -#xF1E4 #x9A57 -#xF1E5 #x9A5F -#xF1E6 #x9A62 -#xF1E7 #x9A65 -#xF1E8 #x9A64 -#xF1E9 #x9A69 -#xF1EA #x9A6B -#xF1EB #x9A6A -#xF1EC #x9AAD -#xF1ED #x9AB0 -#xF1EE #x9ABC -#xF1EF #x9AC0 -#xF1F0 #x9ACF -#xF1F1 #x9AD1 -#xF1F2 #x9AD3 -#xF1F3 #x9AD4 -#xF1F4 #x9ADE -#xF1F5 #x9ADF -#xF1F6 #x9AE2 -#xF1F7 #x9AE3 -#xF1F8 #x9AE6 -#xF1F9 #x9AEF -#xF1FA #x9AEB -#xF1FB #x9AEE -#xF1FC #x9AF4 -#xF1FD #x9AF1 -#xF1FE #x9AF7 -#xF2A1 #x9AFB -#xF2A2 #x9B06 -#xF2A3 #x9B18 -#xF2A4 #x9B1A -#xF2A5 #x9B1F -#xF2A6 #x9B22 -#xF2A7 #x9B23 -#xF2A8 #x9B25 -#xF2A9 #x9B27 -#xF2AA #x9B28 -#xF2AB #x9B29 -#xF2AC #x9B2A -#xF2AD #x9B2E -#xF2AE #x9B2F -#xF2AF #x9B32 -#xF2B0 #x9B44 -#xF2B1 #x9B43 -#xF2B2 #x9B4F -#xF2B3 #x9B4D -#xF2B4 #x9B4E -#xF2B5 #x9B51 -#xF2B6 #x9B58 -#xF2B7 #x9B74 -#xF2B8 #x9B93 -#xF2B9 #x9B83 -#xF2BA #x9B91 -#xF2BB #x9B96 -#xF2BC #x9B97 -#xF2BD #x9B9F -#xF2BE #x9BA0 -#xF2BF #x9BA8 -#xF2C0 #x9BB4 -#xF2C1 #x9BC0 -#xF2C2 #x9BCA -#xF2C3 #x9BB9 -#xF2C4 #x9BC6 -#xF2C5 #x9BCF -#xF2C6 #x9BD1 -#xF2C7 #x9BD2 -#xF2C8 #x9BE3 -#xF2C9 #x9BE2 -#xF2CA #x9BE4 -#xF2CB #x9BD4 -#xF2CC #x9BE1 -#xF2CD #x9C3A -#xF2CE #x9BF2 -#xF2CF #x9BF1 -#xF2D0 #x9BF0 -#xF2D1 #x9C15 -#xF2D2 #x9C14 -#xF2D3 #x9C09 -#xF2D4 #x9C13 -#xF2D5 #x9C0C -#xF2D6 #x9C06 -#xF2D7 #x9C08 -#xF2D8 #x9C12 -#xF2D9 #x9C0A -#xF2DA #x9C04 -#xF2DB #x9C2E -#xF2DC #x9C1B -#xF2DD #x9C25 -#xF2DE #x9C24 -#xF2DF #x9C21 -#xF2E0 #x9C30 -#xF2E1 #x9C47 -#xF2E2 #x9C32 -#xF2E3 #x9C46 -#xF2E4 #x9C3E -#xF2E5 #x9C5A -#xF2E6 #x9C60 -#xF2E7 #x9C67 -#xF2E8 #x9C76 -#xF2E9 #x9C78 -#xF2EA #x9CE7 -#xF2EB #x9CEC -#xF2EC #x9CF0 -#xF2ED #x9D09 -#xF2EE #x9D08 -#xF2EF #x9CEB -#xF2F0 #x9D03 -#xF2F1 #x9D06 -#xF2F2 #x9D2A -#xF2F3 #x9D26 -#xF2F4 #x9DAF -#xF2F5 #x9D23 -#xF2F6 #x9D1F -#xF2F7 #x9D44 -#xF2F8 #x9D15 -#xF2F9 #x9D12 -#xF2FA #x9D41 -#xF2FB #x9D3F -#xF2FC #x9D3E -#xF2FD #x9D46 -#xF2FE #x9D48 -#xF3A1 #x9D5D -#xF3A2 #x9D5E -#xF3A3 #x9D64 -#xF3A4 #x9D51 -#xF3A5 #x9D50 -#xF3A6 #x9D59 -#xF3A7 #x9D72 -#xF3A8 #x9D89 -#xF3A9 #x9D87 -#xF3AA #x9DAB -#xF3AB #x9D6F -#xF3AC #x9D7A -#xF3AD #x9D9A -#xF3AE #x9DA4 -#xF3AF #x9DA9 -#xF3B0 #x9DB2 -#xF3B1 #x9DC4 -#xF3B2 #x9DC1 -#xF3B3 #x9DBB -#xF3B4 #x9DB8 -#xF3B5 #x9DBA -#xF3B6 #x9DC6 -#xF3B7 #x9DCF -#xF3B8 #x9DC2 -#xF3B9 #x9DD9 -#xF3BA #x9DD3 -#xF3BB #x9DF8 -#xF3BC #x9DE6 -#xF3BD #x9DED -#xF3BE #x9DEF -#xF3BF #x9DFD -#xF3C0 #x9E1A -#xF3C1 #x9E1B -#xF3C2 #x9E1E -#xF3C3 #x9E75 -#xF3C4 #x9E79 -#xF3C5 #x9E7D -#xF3C6 #x9E81 -#xF3C7 #x9E88 -#xF3C8 #x9E8B -#xF3C9 #x9E8C -#xF3CA #x9E92 -#xF3CB #x9E95 -#xF3CC #x9E91 -#xF3CD #x9E9D -#xF3CE #x9EA5 -#xF3CF #x9EA9 -#xF3D0 #x9EB8 -#xF3D1 #x9EAA -#xF3D2 #x9EAD -#xF3D3 #x9761 -#xF3D4 #x9ECC -#xF3D5 #x9ECE -#xF3D6 #x9ECF -#xF3D7 #x9ED0 -#xF3D8 #x9ED4 -#xF3D9 #x9EDC -#xF3DA #x9EDE -#xF3DB #x9EDD -#xF3DC #x9EE0 -#xF3DD #x9EE5 -#xF3DE #x9EE8 -#xF3DF #x9EEF -#xF3E0 #x9EF4 -#xF3E1 #x9EF6 -#xF3E2 #x9EF7 -#xF3E3 #x9EF9 -#xF3E4 #x9EFB -#xF3E5 #x9EFC -#xF3E6 #x9EFD -#xF3E7 #x9F07 -#xF3E8 #x9F08 -#xF3E9 #x76B7 -#xF3EA #x9F15 -#xF3EB #x9F21 -#xF3EC #x9F2C -#xF3ED #x9F3E -#xF3EE #x9F4A -#xF3EF #x9F52 -#xF3F0 #x9F54 -#xF3F1 #x9F63 -#xF3F2 #x9F5F -#xF3F3 #x9F60 -#xF3F4 #x9F61 -#xF3F5 #x9F66 -#xF3F6 #x9F67 -#xF3F7 #x9F6C -#xF3F8 #x9F6A -#xF3F9 #x9F77 -#xF3FA #x9F72 -#xF3FB #x9F76 -#xF3FC #x9F95 -#xF3FD #x9F9C -#xF3FE #x9FA0 -#xF4A1 #x582F -#xF4A2 #x69C7 -#xF4A3 #x9059 -#xF4A4 #x7464 -#xF4A5 #x51DC -#xF4A6 #x7199 -#x8FA2AF #x02D8 -#x8FA2B0 #x02C7 -#x8FA2B1 #x00B8 -#x8FA2B2 #x02D9 -#x8FA2B3 #x02DD -#x8FA2B4 #x00AF -#x8FA2B5 #x02DB -#x8FA2B6 #x02DA -#x8FA2B7 #xFF5E -#x8FA2B8 #x0384 -#x8FA2B9 #x0385 -#x8FA2C2 #x00A1 -#x8FA2C3 #x00A6 -#x8FA2C4 #x00BF -#x8FA2EB #x00BA -#x8FA2EC #x00AA -#x8FA2ED #x00A9 -#x8FA2EE #x00AE -#x8FA2EF #x2122 -#x8FA2F0 #x00A4 -#x8FA2F1 #x2116 -#x8FA6E1 #x0386 -#x8FA6E2 #x0388 -#x8FA6E3 #x0389 -#x8FA6E4 #x038A -#x8FA6E5 #x03AA -#x8FA6E7 #x038C -#x8FA6E9 #x038E -#x8FA6EA #x03AB -#x8FA6EC #x038F -#x8FA6F1 #x03AC -#x8FA6F2 #x03AD -#x8FA6F3 #x03AE -#x8FA6F4 #x03AF -#x8FA6F5 #x03CA -#x8FA6F6 #x0390 -#x8FA6F7 #x03CC -#x8FA6F8 #x03C2 -#x8FA6F9 #x03CD -#x8FA6FA #x03CB -#x8FA6FB #x03B0 -#x8FA6FC #x03CE -#x8FA7C2 #x0402 -#x8FA7C3 #x0403 -#x8FA7C4 #x0404 -#x8FA7C5 #x0405 -#x8FA7C6 #x0406 -#x8FA7C7 #x0407 -#x8FA7C8 #x0408 -#x8FA7C9 #x0409 -#x8FA7CA #x040A -#x8FA7CB #x040B -#x8FA7CC #x040C -#x8FA7CD #x040E -#x8FA7CE #x040F -#x8FA7F2 #x0452 -#x8FA7F3 #x0453 -#x8FA7F4 #x0454 -#x8FA7F5 #x0455 -#x8FA7F6 #x0456 -#x8FA7F7 #x0457 -#x8FA7F8 #x0458 -#x8FA7F9 #x0459 -#x8FA7FA #x045A -#x8FA7FB #x045B -#x8FA7FC #x045C -#x8FA7FD #x045E -#x8FA7FE #x045F -#x8FA9A1 #x00C6 -#x8FA9A2 #x0110 -#x8FA9A4 #x0126 -#x8FA9A6 #x0132 -#x8FA9A8 #x0141 -#x8FA9A9 #x013F -#x8FA9AB #x014A -#x8FA9AC #x00D8 -#x8FA9AD #x0152 -#x8FA9AF #x0166 -#x8FA9B0 #x00DE -#x8FA9C1 #x00E6 -#x8FA9C2 #x0111 -#x8FA9C3 #x00F0 -#x8FA9C4 #x0127 -#x8FA9C5 #x0131 -#x8FA9C6 #x0133 -#x8FA9C7 #x0138 -#x8FA9C8 #x0142 -#x8FA9C9 #x0140 -#x8FA9CA #x0149 -#x8FA9CB #x014B -#x8FA9CC #x00F8 -#x8FA9CD #x0153 -#x8FA9CE #x00DF -#x8FA9CF #x0167 -#x8FA9D0 #x00FE -#x8FAAA1 #x00C1 -#x8FAAA2 #x00C0 -#x8FAAA3 #x00C4 -#x8FAAA4 #x00C2 -#x8FAAA5 #x0102 -#x8FAAA6 #x01CD -#x8FAAA7 #x0100 -#x8FAAA8 #x0104 -#x8FAAA9 #x00C5 -#x8FAAAA #x00C3 -#x8FAAAB #x0106 -#x8FAAAC #x0108 -#x8FAAAD #x010C -#x8FAAAE #x00C7 -#x8FAAAF #x010A -#x8FAAB0 #x010E -#x8FAAB1 #x00C9 -#x8FAAB2 #x00C8 -#x8FAAB3 #x00CB -#x8FAAB4 #x00CA -#x8FAAB5 #x011A -#x8FAAB6 #x0116 -#x8FAAB7 #x0112 -#x8FAAB8 #x0118 -#x8FAABA #x011C -#x8FAABB #x011E -#x8FAABC #x0122 -#x8FAABD #x0120 -#x8FAABE #x0124 -#x8FAABF #x00CD -#x8FAAC0 #x00CC -#x8FAAC1 #x00CF -#x8FAAC2 #x00CE -#x8FAAC3 #x01CF -#x8FAAC4 #x0130 -#x8FAAC5 #x012A -#x8FAAC6 #x012E -#x8FAAC7 #x0128 -#x8FAAC8 #x0134 -#x8FAAC9 #x0136 -#x8FAACA #x0139 -#x8FAACB #x013D -#x8FAACC #x013B -#x8FAACD #x0143 -#x8FAACE #x0147 -#x8FAACF #x0145 -#x8FAAD0 #x00D1 -#x8FAAD1 #x00D3 -#x8FAAD2 #x00D2 -#x8FAAD3 #x00D6 -#x8FAAD4 #x00D4 -#x8FAAD5 #x01D1 -#x8FAAD6 #x0150 -#x8FAAD7 #x014C -#x8FAAD8 #x00D5 -#x8FAAD9 #x0154 -#x8FAADA #x0158 -#x8FAADB #x0156 -#x8FAADC #x015A -#x8FAADD #x015C -#x8FAADE #x0160 -#x8FAADF #x015E -#x8FAAE0 #x0164 -#x8FAAE1 #x0162 -#x8FAAE2 #x00DA -#x8FAAE3 #x00D9 -#x8FAAE4 #x00DC -#x8FAAE5 #x00DB -#x8FAAE6 #x016C -#x8FAAE7 #x01D3 -#x8FAAE8 #x0170 -#x8FAAE9 #x016A -#x8FAAEA #x0172 -#x8FAAEB #x016E -#x8FAAEC #x0168 -#x8FAAED #x01D7 -#x8FAAEE #x01DB -#x8FAAEF #x01D9 -#x8FAAF0 #x01D5 -#x8FAAF1 #x0174 -#x8FAAF2 #x00DD -#x8FAAF3 #x0178 -#x8FAAF4 #x0176 -#x8FAAF5 #x0179 -#x8FAAF6 #x017D -#x8FAAF7 #x017B -#x8FABA1 #x00E1 -#x8FABA2 #x00E0 -#x8FABA3 #x00E4 -#x8FABA4 #x00E2 -#x8FABA5 #x0103 -#x8FABA6 #x01CE -#x8FABA7 #x0101 -#x8FABA8 #x0105 -#x8FABA9 #x00E5 -#x8FABAA #x00E3 -#x8FABAB #x0107 -#x8FABAC #x0109 -#x8FABAD #x010D -#x8FABAE #x00E7 -#x8FABAF #x010B -#x8FABB0 #x010F -#x8FABB1 #x00E9 -#x8FABB2 #x00E8 -#x8FABB3 #x00EB -#x8FABB4 #x00EA -#x8FABB5 #x011B -#x8FABB6 #x0117 -#x8FABB7 #x0113 -#x8FABB8 #x0119 -#x8FABB9 #x01F5 -#x8FABBA #x011D -#x8FABBB #x011F -#x8FABBD #x0121 -#x8FABBE #x0125 -#x8FABBF #x00ED -#x8FABC0 #x00EC -#x8FABC1 #x00EF -#x8FABC2 #x00EE -#x8FABC3 #x01D0 -#x8FABC5 #x012B -#x8FABC6 #x012F -#x8FABC7 #x0129 -#x8FABC8 #x0135 -#x8FABC9 #x0137 -#x8FABCA #x013A -#x8FABCB #x013E -#x8FABCC #x013C -#x8FABCD #x0144 -#x8FABCE #x0148 -#x8FABCF #x0146 -#x8FABD0 #x00F1 -#x8FABD1 #x00F3 -#x8FABD2 #x00F2 -#x8FABD3 #x00F6 -#x8FABD4 #x00F4 -#x8FABD5 #x01D2 -#x8FABD6 #x0151 -#x8FABD7 #x014D -#x8FABD8 #x00F5 -#x8FABD9 #x0155 -#x8FABDA #x0159 -#x8FABDB #x0157 -#x8FABDC #x015B -#x8FABDD #x015D -#x8FABDE #x0161 -#x8FABDF #x015F -#x8FABE0 #x0165 -#x8FABE1 #x0163 -#x8FABE2 #x00FA -#x8FABE3 #x00F9 -#x8FABE4 #x00FC -#x8FABE5 #x00FB -#x8FABE6 #x016D -#x8FABE7 #x01D4 -#x8FABE8 #x0171 -#x8FABE9 #x016B -#x8FABEA #x0173 -#x8FABEB #x016F -#x8FABEC #x0169 -#x8FABED #x01D8 -#x8FABEE #x01DC -#x8FABEF #x01DA -#x8FABF0 #x01D6 -#x8FABF1 #x0175 -#x8FABF2 #x00FD -#x8FABF3 #x00FF -#x8FABF4 #x0177 -#x8FABF5 #x017A -#x8FABF6 #x017E -#x8FABF7 #x017C -#x8FB0A1 #x4E02 -#x8FB0A2 #x4E04 -#x8FB0A3 #x4E05 -#x8FB0A4 #x4E0C -#x8FB0A5 #x4E12 -#x8FB0A6 #x4E1F -#x8FB0A7 #x4E23 -#x8FB0A8 #x4E24 -#x8FB0A9 #x4E28 -#x8FB0AA #x4E2B -#x8FB0AB #x4E2E -#x8FB0AC #x4E2F -#x8FB0AD #x4E30 -#x8FB0AE #x4E35 -#x8FB0AF #x4E40 -#x8FB0B0 #x4E41 -#x8FB0B1 #x4E44 -#x8FB0B2 #x4E47 -#x8FB0B3 #x4E51 -#x8FB0B4 #x4E5A -#x8FB0B5 #x4E5C -#x8FB0B6 #x4E63 -#x8FB0B7 #x4E68 -#x8FB0B8 #x4E69 -#x8FB0B9 #x4E74 -#x8FB0BA #x4E75 -#x8FB0BB #x4E79 -#x8FB0BC #x4E7F -#x8FB0BD #x4E8D -#x8FB0BE #x4E96 -#x8FB0BF #x4E97 -#x8FB0C0 #x4E9D -#x8FB0C1 #x4EAF -#x8FB0C2 #x4EB9 -#x8FB0C3 #x4EC3 -#x8FB0C4 #x4ED0 -#x8FB0C5 #x4EDA -#x8FB0C6 #x4EDB -#x8FB0C7 #x4EE0 -#x8FB0C8 #x4EE1 -#x8FB0C9 #x4EE2 -#x8FB0CA #x4EE8 -#x8FB0CB #x4EEF -#x8FB0CC #x4EF1 -#x8FB0CD #x4EF3 -#x8FB0CE #x4EF5 -#x8FB0CF #x4EFD -#x8FB0D0 #x4EFE -#x8FB0D1 #x4EFF -#x8FB0D2 #x4F00 -#x8FB0D3 #x4F02 -#x8FB0D4 #x4F03 -#x8FB0D5 #x4F08 -#x8FB0D6 #x4F0B -#x8FB0D7 #x4F0C -#x8FB0D8 #x4F12 -#x8FB0D9 #x4F15 -#x8FB0DA #x4F16 -#x8FB0DB #x4F17 -#x8FB0DC #x4F19 -#x8FB0DD #x4F2E -#x8FB0DE #x4F31 -#x8FB0DF #x4F60 -#x8FB0E0 #x4F33 -#x8FB0E1 #x4F35 -#x8FB0E2 #x4F37 -#x8FB0E3 #x4F39 -#x8FB0E4 #x4F3B -#x8FB0E5 #x4F3E -#x8FB0E6 #x4F40 -#x8FB0E7 #x4F42 -#x8FB0E8 #x4F48 -#x8FB0E9 #x4F49 -#x8FB0EA #x4F4B -#x8FB0EB #x4F4C -#x8FB0EC #x4F52 -#x8FB0ED #x4F54 -#x8FB0EE #x4F56 -#x8FB0EF #x4F58 -#x8FB0F0 #x4F5F -#x8FB0F1 #x4F63 -#x8FB0F2 #x4F6A -#x8FB0F3 #x4F6C -#x8FB0F4 #x4F6E -#x8FB0F5 #x4F71 -#x8FB0F6 #x4F77 -#x8FB0F7 #x4F78 -#x8FB0F8 #x4F79 -#x8FB0F9 #x4F7A -#x8FB0FA #x4F7D -#x8FB0FB #x4F7E -#x8FB0FC #x4F81 -#x8FB0FD #x4F82 -#x8FB0FE #x4F84 -#x8FB1A1 #x4F85 -#x8FB1A2 #x4F89 -#x8FB1A3 #x4F8A -#x8FB1A4 #x4F8C -#x8FB1A5 #x4F8E -#x8FB1A6 #x4F90 -#x8FB1A7 #x4F92 -#x8FB1A8 #x4F93 -#x8FB1A9 #x4F94 -#x8FB1AA #x4F97 -#x8FB1AB #x4F99 -#x8FB1AC #x4F9A -#x8FB1AD #x4F9E -#x8FB1AE #x4F9F -#x8FB1AF #x4FB2 -#x8FB1B0 #x4FB7 -#x8FB1B1 #x4FB9 -#x8FB1B2 #x4FBB -#x8FB1B3 #x4FBC -#x8FB1B4 #x4FBD -#x8FB1B5 #x4FBE -#x8FB1B6 #x4FC0 -#x8FB1B7 #x4FC1 -#x8FB1B8 #x4FC5 -#x8FB1B9 #x4FC6 -#x8FB1BA #x4FC8 -#x8FB1BB #x4FC9 -#x8FB1BC #x4FCB -#x8FB1BD #x4FCC -#x8FB1BE #x4FCD -#x8FB1BF #x4FCF -#x8FB1C0 #x4FD2 -#x8FB1C1 #x4FDC -#x8FB1C2 #x4FE0 -#x8FB1C3 #x4FE2 -#x8FB1C4 #x4FF0 -#x8FB1C5 #x4FF2 -#x8FB1C6 #x4FFC -#x8FB1C7 #x4FFD -#x8FB1C8 #x4FFF -#x8FB1C9 #x5000 -#x8FB1CA #x5001 -#x8FB1CB #x5004 -#x8FB1CC #x5007 -#x8FB1CD #x500A -#x8FB1CE #x500C -#x8FB1CF #x500E -#x8FB1D0 #x5010 -#x8FB1D1 #x5013 -#x8FB1D2 #x5017 -#x8FB1D3 #x5018 -#x8FB1D4 #x501B -#x8FB1D5 #x501C -#x8FB1D6 #x501D -#x8FB1D7 #x501E -#x8FB1D8 #x5022 -#x8FB1D9 #x5027 -#x8FB1DA #x502E -#x8FB1DB #x5030 -#x8FB1DC #x5032 -#x8FB1DD #x5033 -#x8FB1DE #x5035 -#x8FB1DF #x5040 -#x8FB1E0 #x5041 -#x8FB1E1 #x5042 -#x8FB1E2 #x5045 -#x8FB1E3 #x5046 -#x8FB1E4 #x504A -#x8FB1E5 #x504C -#x8FB1E6 #x504E -#x8FB1E7 #x5051 -#x8FB1E8 #x5052 -#x8FB1E9 #x5053 -#x8FB1EA #x5057 -#x8FB1EB #x5059 -#x8FB1EC #x505F -#x8FB1ED #x5060 -#x8FB1EE #x5062 -#x8FB1EF #x5063 -#x8FB1F0 #x5066 -#x8FB1F1 #x5067 -#x8FB1F2 #x506A -#x8FB1F3 #x506D -#x8FB1F4 #x5070 -#x8FB1F5 #x5071 -#x8FB1F6 #x503B -#x8FB1F7 #x5081 -#x8FB1F8 #x5083 -#x8FB1F9 #x5084 -#x8FB1FA #x5086 -#x8FB1FB #x508A -#x8FB1FC #x508E -#x8FB1FD #x508F -#x8FB1FE #x5090 -#x8FB2A1 #x5092 -#x8FB2A2 #x5093 -#x8FB2A3 #x5094 -#x8FB2A4 #x5096 -#x8FB2A5 #x509B -#x8FB2A6 #x509C -#x8FB2A7 #x509E -#x8FB2A8 #x509F -#x8FB2A9 #x50A0 -#x8FB2AA #x50A1 -#x8FB2AB #x50A2 -#x8FB2AC #x50AA -#x8FB2AD #x50AF -#x8FB2AE #x50B0 -#x8FB2AF #x50B9 -#x8FB2B0 #x50BA -#x8FB2B1 #x50BD -#x8FB2B2 #x50C0 -#x8FB2B3 #x50C3 -#x8FB2B4 #x50C4 -#x8FB2B5 #x50C7 -#x8FB2B6 #x50CC -#x8FB2B7 #x50CE -#x8FB2B8 #x50D0 -#x8FB2B9 #x50D3 -#x8FB2BA #x50D4 -#x8FB2BB #x50D8 -#x8FB2BC #x50DC -#x8FB2BD #x50DD -#x8FB2BE #x50DF -#x8FB2BF #x50E2 -#x8FB2C0 #x50E4 -#x8FB2C1 #x50E6 -#x8FB2C2 #x50E8 -#x8FB2C3 #x50E9 -#x8FB2C4 #x50EF -#x8FB2C5 #x50F1 -#x8FB2C6 #x50F6 -#x8FB2C7 #x50FA -#x8FB2C8 #x50FE -#x8FB2C9 #x5103 -#x8FB2CA #x5106 -#x8FB2CB #x5107 -#x8FB2CC #x5108 -#x8FB2CD #x510B -#x8FB2CE #x510C -#x8FB2CF #x510D -#x8FB2D0 #x510E -#x8FB2D1 #x50F2 -#x8FB2D2 #x5110 -#x8FB2D3 #x5117 -#x8FB2D4 #x5119 -#x8FB2D5 #x511B -#x8FB2D6 #x511C -#x8FB2D7 #x511D -#x8FB2D8 #x511E -#x8FB2D9 #x5123 -#x8FB2DA #x5127 -#x8FB2DB #x5128 -#x8FB2DC #x512C -#x8FB2DD #x512D -#x8FB2DE #x512F -#x8FB2DF #x5131 -#x8FB2E0 #x5133 -#x8FB2E1 #x5134 -#x8FB2E2 #x5135 -#x8FB2E3 #x5138 -#x8FB2E4 #x5139 -#x8FB2E5 #x5142 -#x8FB2E6 #x514A -#x8FB2E7 #x514F -#x8FB2E8 #x5153 -#x8FB2E9 #x5155 -#x8FB2EA #x5157 -#x8FB2EB #x5158 -#x8FB2EC #x515F -#x8FB2ED #x5164 -#x8FB2EE #x5166 -#x8FB2EF #x517E -#x8FB2F0 #x5183 -#x8FB2F1 #x5184 -#x8FB2F2 #x518B -#x8FB2F3 #x518E -#x8FB2F4 #x5198 -#x8FB2F5 #x519D -#x8FB2F6 #x51A1 -#x8FB2F7 #x51A3 -#x8FB2F8 #x51AD -#x8FB2F9 #x51B8 -#x8FB2FA #x51BA -#x8FB2FB #x51BC -#x8FB2FC #x51BE -#x8FB2FD #x51BF -#x8FB2FE #x51C2 -#x8FB3A1 #x51C8 -#x8FB3A2 #x51CF -#x8FB3A3 #x51D1 -#x8FB3A4 #x51D2 -#x8FB3A5 #x51D3 -#x8FB3A6 #x51D5 -#x8FB3A7 #x51D8 -#x8FB3A8 #x51DE -#x8FB3A9 #x51E2 -#x8FB3AA #x51E5 -#x8FB3AB #x51EE -#x8FB3AC #x51F2 -#x8FB3AD #x51F3 -#x8FB3AE #x51F4 -#x8FB3AF #x51F7 -#x8FB3B0 #x5201 -#x8FB3B1 #x5202 -#x8FB3B2 #x5205 -#x8FB3B3 #x5212 -#x8FB3B4 #x5213 -#x8FB3B5 #x5215 -#x8FB3B6 #x5216 -#x8FB3B7 #x5218 -#x8FB3B8 #x5222 -#x8FB3B9 #x5228 -#x8FB3BA #x5231 -#x8FB3BB #x5232 -#x8FB3BC #x5235 -#x8FB3BD #x523C -#x8FB3BE #x5245 -#x8FB3BF #x5249 -#x8FB3C0 #x5255 -#x8FB3C1 #x5257 -#x8FB3C2 #x5258 -#x8FB3C3 #x525A -#x8FB3C4 #x525C -#x8FB3C5 #x525F -#x8FB3C6 #x5260 -#x8FB3C7 #x5261 -#x8FB3C8 #x5266 -#x8FB3C9 #x526E -#x8FB3CA #x5277 -#x8FB3CB #x5278 -#x8FB3CC #x5279 -#x8FB3CD #x5280 -#x8FB3CE #x5282 -#x8FB3CF #x5285 -#x8FB3D0 #x528A -#x8FB3D1 #x528C -#x8FB3D2 #x5293 -#x8FB3D3 #x5295 -#x8FB3D4 #x5296 -#x8FB3D5 #x5297 -#x8FB3D6 #x5298 -#x8FB3D7 #x529A -#x8FB3D8 #x529C -#x8FB3D9 #x52A4 -#x8FB3DA #x52A5 -#x8FB3DB #x52A6 -#x8FB3DC #x52A7 -#x8FB3DD #x52AF -#x8FB3DE #x52B0 -#x8FB3DF #x52B6 -#x8FB3E0 #x52B7 -#x8FB3E1 #x52B8 -#x8FB3E2 #x52BA -#x8FB3E3 #x52BB -#x8FB3E4 #x52BD -#x8FB3E5 #x52C0 -#x8FB3E6 #x52C4 -#x8FB3E7 #x52C6 -#x8FB3E8 #x52C8 -#x8FB3E9 #x52CC -#x8FB3EA #x52CF -#x8FB3EB #x52D1 -#x8FB3EC #x52D4 -#x8FB3ED #x52D6 -#x8FB3EE #x52DB -#x8FB3EF #x52DC -#x8FB3F0 #x52E1 -#x8FB3F1 #x52E5 -#x8FB3F2 #x52E8 -#x8FB3F3 #x52E9 -#x8FB3F4 #x52EA -#x8FB3F5 #x52EC -#x8FB3F6 #x52F0 -#x8FB3F7 #x52F1 -#x8FB3F8 #x52F4 -#x8FB3F9 #x52F6 -#x8FB3FA #x52F7 -#x8FB3FB #x5300 -#x8FB3FC #x5303 -#x8FB3FD #x530A -#x8FB3FE #x530B -#x8FB4A1 #x530C -#x8FB4A2 #x5311 -#x8FB4A3 #x5313 -#x8FB4A4 #x5318 -#x8FB4A5 #x531B -#x8FB4A6 #x531C -#x8FB4A7 #x531E -#x8FB4A8 #x531F -#x8FB4A9 #x5325 -#x8FB4AA #x5327 -#x8FB4AB #x5328 -#x8FB4AC #x5329 -#x8FB4AD #x532B -#x8FB4AE #x532C -#x8FB4AF #x532D -#x8FB4B0 #x5330 -#x8FB4B1 #x5332 -#x8FB4B2 #x5335 -#x8FB4B3 #x533C -#x8FB4B4 #x533D -#x8FB4B5 #x533E -#x8FB4B6 #x5342 -#x8FB4B7 #x534C -#x8FB4B8 #x534B -#x8FB4B9 #x5359 -#x8FB4BA #x535B -#x8FB4BB #x5361 -#x8FB4BC #x5363 -#x8FB4BD #x5365 -#x8FB4BE #x536C -#x8FB4BF #x536D -#x8FB4C0 #x5372 -#x8FB4C1 #x5379 -#x8FB4C2 #x537E -#x8FB4C3 #x5383 -#x8FB4C4 #x5387 -#x8FB4C5 #x5388 -#x8FB4C6 #x538E -#x8FB4C7 #x5393 -#x8FB4C8 #x5394 -#x8FB4C9 #x5399 -#x8FB4CA #x539D -#x8FB4CB #x53A1 -#x8FB4CC #x53A4 -#x8FB4CD #x53AA -#x8FB4CE #x53AB -#x8FB4CF #x53AF -#x8FB4D0 #x53B2 -#x8FB4D1 #x53B4 -#x8FB4D2 #x53B5 -#x8FB4D3 #x53B7 -#x8FB4D4 #x53B8 -#x8FB4D5 #x53BA -#x8FB4D6 #x53BD -#x8FB4D7 #x53C0 -#x8FB4D8 #x53C5 -#x8FB4D9 #x53CF -#x8FB4DA #x53D2 -#x8FB4DB #x53D3 -#x8FB4DC #x53D5 -#x8FB4DD #x53DA -#x8FB4DE #x53DD -#x8FB4DF #x53DE -#x8FB4E0 #x53E0 -#x8FB4E1 #x53E6 -#x8FB4E2 #x53E7 -#x8FB4E3 #x53F5 -#x8FB4E4 #x5402 -#x8FB4E5 #x5413 -#x8FB4E6 #x541A -#x8FB4E7 #x5421 -#x8FB4E8 #x5427 -#x8FB4E9 #x5428 -#x8FB4EA #x542A -#x8FB4EB #x542F -#x8FB4EC #x5431 -#x8FB4ED #x5434 -#x8FB4EE #x5435 -#x8FB4EF #x5443 -#x8FB4F0 #x5444 -#x8FB4F1 #x5447 -#x8FB4F2 #x544D -#x8FB4F3 #x544F -#x8FB4F4 #x545E -#x8FB4F5 #x5462 -#x8FB4F6 #x5464 -#x8FB4F7 #x5466 -#x8FB4F8 #x5467 -#x8FB4F9 #x5469 -#x8FB4FA #x546B -#x8FB4FB #x546D -#x8FB4FC #x546E -#x8FB4FD #x5474 -#x8FB4FE #x547F -#x8FB5A1 #x5481 -#x8FB5A2 #x5483 -#x8FB5A3 #x5485 -#x8FB5A4 #x5488 -#x8FB5A5 #x5489 -#x8FB5A6 #x548D -#x8FB5A7 #x5491 -#x8FB5A8 #x5495 -#x8FB5A9 #x5496 -#x8FB5AA #x549C -#x8FB5AB #x549F -#x8FB5AC #x54A1 -#x8FB5AD #x54A6 -#x8FB5AE #x54A7 -#x8FB5AF #x54A9 -#x8FB5B0 #x54AA -#x8FB5B1 #x54AD -#x8FB5B2 #x54AE -#x8FB5B3 #x54B1 -#x8FB5B4 #x54B7 -#x8FB5B5 #x54B9 -#x8FB5B6 #x54BA -#x8FB5B7 #x54BB -#x8FB5B8 #x54BF -#x8FB5B9 #x54C6 -#x8FB5BA #x54CA -#x8FB5BB #x54CD -#x8FB5BC #x54CE -#x8FB5BD #x54E0 -#x8FB5BE #x54EA -#x8FB5BF #x54EC -#x8FB5C0 #x54EF -#x8FB5C1 #x54F6 -#x8FB5C2 #x54FC -#x8FB5C3 #x54FE -#x8FB5C4 #x54FF -#x8FB5C5 #x5500 -#x8FB5C6 #x5501 -#x8FB5C7 #x5505 -#x8FB5C8 #x5508 -#x8FB5C9 #x5509 -#x8FB5CA #x550C -#x8FB5CB #x550D -#x8FB5CC #x550E -#x8FB5CD #x5515 -#x8FB5CE #x552A -#x8FB5CF #x552B -#x8FB5D0 #x5532 -#x8FB5D1 #x5535 -#x8FB5D2 #x5536 -#x8FB5D3 #x553B -#x8FB5D4 #x553C -#x8FB5D5 #x553D -#x8FB5D6 #x5541 -#x8FB5D7 #x5547 -#x8FB5D8 #x5549 -#x8FB5D9 #x554A -#x8FB5DA #x554D -#x8FB5DB #x5550 -#x8FB5DC #x5551 -#x8FB5DD #x5558 -#x8FB5DE #x555A -#x8FB5DF #x555B -#x8FB5E0 #x555E -#x8FB5E1 #x5560 -#x8FB5E2 #x5561 -#x8FB5E3 #x5564 -#x8FB5E4 #x5566 -#x8FB5E5 #x557F -#x8FB5E6 #x5581 -#x8FB5E7 #x5582 -#x8FB5E8 #x5586 -#x8FB5E9 #x5588 -#x8FB5EA #x558E -#x8FB5EB #x558F -#x8FB5EC #x5591 -#x8FB5ED #x5592 -#x8FB5EE #x5593 -#x8FB5EF #x5594 -#x8FB5F0 #x5597 -#x8FB5F1 #x55A3 -#x8FB5F2 #x55A4 -#x8FB5F3 #x55AD -#x8FB5F4 #x55B2 -#x8FB5F5 #x55BF -#x8FB5F6 #x55C1 -#x8FB5F7 #x55C3 -#x8FB5F8 #x55C6 -#x8FB5F9 #x55C9 -#x8FB5FA #x55CB -#x8FB5FB #x55CC -#x8FB5FC #x55CE -#x8FB5FD #x55D1 -#x8FB5FE #x55D2 -#x8FB6A1 #x55D3 -#x8FB6A2 #x55D7 -#x8FB6A3 #x55D8 -#x8FB6A4 #x55DB -#x8FB6A5 #x55DE -#x8FB6A6 #x55E2 -#x8FB6A7 #x55E9 -#x8FB6A8 #x55F6 -#x8FB6A9 #x55FF -#x8FB6AA #x5605 -#x8FB6AB #x5608 -#x8FB6AC #x560A -#x8FB6AD #x560D -#x8FB6AE #x560E -#x8FB6AF #x560F -#x8FB6B0 #x5610 -#x8FB6B1 #x5611 -#x8FB6B2 #x5612 -#x8FB6B3 #x5619 -#x8FB6B4 #x562C -#x8FB6B5 #x5630 -#x8FB6B6 #x5633 -#x8FB6B7 #x5635 -#x8FB6B8 #x5637 -#x8FB6B9 #x5639 -#x8FB6BA #x563B -#x8FB6BB #x563C -#x8FB6BC #x563D -#x8FB6BD #x563F -#x8FB6BE #x5640 -#x8FB6BF #x5641 -#x8FB6C0 #x5643 -#x8FB6C1 #x5644 -#x8FB6C2 #x5646 -#x8FB6C3 #x5649 -#x8FB6C4 #x564B -#x8FB6C5 #x564D -#x8FB6C6 #x564F -#x8FB6C7 #x5654 -#x8FB6C8 #x565E -#x8FB6C9 #x5660 -#x8FB6CA #x5661 -#x8FB6CB #x5662 -#x8FB6CC #x5663 -#x8FB6CD #x5666 -#x8FB6CE #x5669 -#x8FB6CF #x566D -#x8FB6D0 #x566F -#x8FB6D1 #x5671 -#x8FB6D2 #x5672 -#x8FB6D3 #x5675 -#x8FB6D4 #x5684 -#x8FB6D5 #x5685 -#x8FB6D6 #x5688 -#x8FB6D7 #x568B -#x8FB6D8 #x568C -#x8FB6D9 #x5695 -#x8FB6DA #x5699 -#x8FB6DB #x569A -#x8FB6DC #x569D -#x8FB6DD #x569E -#x8FB6DE #x569F -#x8FB6DF #x56A6 -#x8FB6E0 #x56A7 -#x8FB6E1 #x56A8 -#x8FB6E2 #x56A9 -#x8FB6E3 #x56AB -#x8FB6E4 #x56AC -#x8FB6E5 #x56AD -#x8FB6E6 #x56B1 -#x8FB6E7 #x56B3 -#x8FB6E8 #x56B7 -#x8FB6E9 #x56BE -#x8FB6EA #x56C5 -#x8FB6EB #x56C9 -#x8FB6EC #x56CA -#x8FB6ED #x56CB -#x8FB6EE #x56CF -#x8FB6EF #x56D0 -#x8FB6F0 #x56CC -#x8FB6F1 #x56CD -#x8FB6F2 #x56D9 -#x8FB6F3 #x56DC -#x8FB6F4 #x56DD -#x8FB6F5 #x56DF -#x8FB6F6 #x56E1 -#x8FB6F7 #x56E4 -#x8FB6F8 #x56E5 -#x8FB6F9 #x56E6 -#x8FB6FA #x56E7 -#x8FB6FB #x56E8 -#x8FB6FC #x56F1 -#x8FB6FD #x56EB -#x8FB6FE #x56ED -#x8FB7A1 #x56F6 -#x8FB7A2 #x56F7 -#x8FB7A3 #x5701 -#x8FB7A4 #x5702 -#x8FB7A5 #x5707 -#x8FB7A6 #x570A -#x8FB7A7 #x570C -#x8FB7A8 #x5711 -#x8FB7A9 #x5715 -#x8FB7AA #x571A -#x8FB7AB #x571B -#x8FB7AC #x571D -#x8FB7AD #x5720 -#x8FB7AE #x5722 -#x8FB7AF #x5723 -#x8FB7B0 #x5724 -#x8FB7B1 #x5725 -#x8FB7B2 #x5729 -#x8FB7B3 #x572A -#x8FB7B4 #x572C -#x8FB7B5 #x572E -#x8FB7B6 #x572F -#x8FB7B7 #x5733 -#x8FB7B8 #x5734 -#x8FB7B9 #x573D -#x8FB7BA #x573E -#x8FB7BB #x573F -#x8FB7BC #x5745 -#x8FB7BD #x5746 -#x8FB7BE #x574C -#x8FB7BF #x574D -#x8FB7C0 #x5752 -#x8FB7C1 #x5762 -#x8FB7C2 #x5765 -#x8FB7C3 #x5767 -#x8FB7C4 #x5768 -#x8FB7C5 #x576B -#x8FB7C6 #x576D -#x8FB7C7 #x576E -#x8FB7C8 #x576F -#x8FB7C9 #x5770 -#x8FB7CA #x5771 -#x8FB7CB #x5773 -#x8FB7CC #x5774 -#x8FB7CD #x5775 -#x8FB7CE #x5777 -#x8FB7CF #x5779 -#x8FB7D0 #x577A -#x8FB7D1 #x577B -#x8FB7D2 #x577C -#x8FB7D3 #x577E -#x8FB7D4 #x5781 -#x8FB7D5 #x5783 -#x8FB7D6 #x578C -#x8FB7D7 #x5794 -#x8FB7D8 #x5797 -#x8FB7D9 #x5799 -#x8FB7DA #x579A -#x8FB7DB #x579C -#x8FB7DC #x579D -#x8FB7DD #x579E -#x8FB7DE #x579F -#x8FB7DF #x57A1 -#x8FB7E0 #x5795 -#x8FB7E1 #x57A7 -#x8FB7E2 #x57A8 -#x8FB7E3 #x57A9 -#x8FB7E4 #x57AC -#x8FB7E5 #x57B8 -#x8FB7E6 #x57BD -#x8FB7E7 #x57C7 -#x8FB7E8 #x57C8 -#x8FB7E9 #x57CC -#x8FB7EA #x57CF -#x8FB7EB #x57D5 -#x8FB7EC #x57DD -#x8FB7ED #x57DE -#x8FB7EE #x57E4 -#x8FB7EF #x57E6 -#x8FB7F0 #x57E7 -#x8FB7F1 #x57E9 -#x8FB7F2 #x57ED -#x8FB7F3 #x57F0 -#x8FB7F4 #x57F5 -#x8FB7F5 #x57F6 -#x8FB7F6 #x57F8 -#x8FB7F7 #x57FD -#x8FB7F8 #x57FE -#x8FB7F9 #x57FF -#x8FB7FA #x5803 -#x8FB7FB #x5804 -#x8FB7FC #x5808 -#x8FB7FD #x5809 -#x8FB7FE #x57E1 -#x8FB8A1 #x580C -#x8FB8A2 #x580D -#x8FB8A3 #x581B -#x8FB8A4 #x581E -#x8FB8A5 #x581F -#x8FB8A6 #x5820 -#x8FB8A7 #x5826 -#x8FB8A8 #x5827 -#x8FB8A9 #x582D -#x8FB8AA #x5832 -#x8FB8AB #x5839 -#x8FB8AC #x583F -#x8FB8AD #x5849 -#x8FB8AE #x584C -#x8FB8AF #x584D -#x8FB8B0 #x584F -#x8FB8B1 #x5850 -#x8FB8B2 #x5855 -#x8FB8B3 #x585F -#x8FB8B4 #x5861 -#x8FB8B5 #x5864 -#x8FB8B6 #x5867 -#x8FB8B7 #x5868 -#x8FB8B8 #x5878 -#x8FB8B9 #x587C -#x8FB8BA #x587F -#x8FB8BB #x5880 -#x8FB8BC #x5881 -#x8FB8BD #x5887 -#x8FB8BE #x5888 -#x8FB8BF #x5889 -#x8FB8C0 #x588A -#x8FB8C1 #x588C -#x8FB8C2 #x588D -#x8FB8C3 #x588F -#x8FB8C4 #x5890 -#x8FB8C5 #x5894 -#x8FB8C6 #x5896 -#x8FB8C7 #x589D -#x8FB8C8 #x58A0 -#x8FB8C9 #x58A1 -#x8FB8CA #x58A2 -#x8FB8CB #x58A6 -#x8FB8CC #x58A9 -#x8FB8CD #x58B1 -#x8FB8CE #x58B2 -#x8FB8CF #x58C4 -#x8FB8D0 #x58BC -#x8FB8D1 #x58C2 -#x8FB8D2 #x58C8 -#x8FB8D3 #x58CD -#x8FB8D4 #x58CE -#x8FB8D5 #x58D0 -#x8FB8D6 #x58D2 -#x8FB8D7 #x58D4 -#x8FB8D8 #x58D6 -#x8FB8D9 #x58DA -#x8FB8DA #x58DD -#x8FB8DB #x58E1 -#x8FB8DC #x58E2 -#x8FB8DD #x58E9 -#x8FB8DE #x58F3 -#x8FB8DF #x5905 -#x8FB8E0 #x5906 -#x8FB8E1 #x590B -#x8FB8E2 #x590C -#x8FB8E3 #x5912 -#x8FB8E4 #x5913 -#x8FB8E5 #x5914 -#x8FB8E6 #x8641 -#x8FB8E7 #x591D -#x8FB8E8 #x5921 -#x8FB8E9 #x5923 -#x8FB8EA #x5924 -#x8FB8EB #x5928 -#x8FB8EC #x592F -#x8FB8ED #x5930 -#x8FB8EE #x5933 -#x8FB8EF #x5935 -#x8FB8F0 #x5936 -#x8FB8F1 #x593F -#x8FB8F2 #x5943 -#x8FB8F3 #x5946 -#x8FB8F4 #x5952 -#x8FB8F5 #x5953 -#x8FB8F6 #x5959 -#x8FB8F7 #x595B -#x8FB8F8 #x595D -#x8FB8F9 #x595E -#x8FB8FA #x595F -#x8FB8FB #x5961 -#x8FB8FC #x5963 -#x8FB8FD #x596B -#x8FB8FE #x596D -#x8FB9A1 #x596F -#x8FB9A2 #x5972 -#x8FB9A3 #x5975 -#x8FB9A4 #x5976 -#x8FB9A5 #x5979 -#x8FB9A6 #x597B -#x8FB9A7 #x597C -#x8FB9A8 #x598B -#x8FB9A9 #x598C -#x8FB9AA #x598E -#x8FB9AB #x5992 -#x8FB9AC #x5995 -#x8FB9AD #x5997 -#x8FB9AE #x599F -#x8FB9AF #x59A4 -#x8FB9B0 #x59A7 -#x8FB9B1 #x59AD -#x8FB9B2 #x59AE -#x8FB9B3 #x59AF -#x8FB9B4 #x59B0 -#x8FB9B5 #x59B3 -#x8FB9B6 #x59B7 -#x8FB9B7 #x59BA -#x8FB9B8 #x59BC -#x8FB9B9 #x59C1 -#x8FB9BA #x59C3 -#x8FB9BB #x59C4 -#x8FB9BC #x59C8 -#x8FB9BD #x59CA -#x8FB9BE #x59CD -#x8FB9BF #x59D2 -#x8FB9C0 #x59DD -#x8FB9C1 #x59DE -#x8FB9C2 #x59DF -#x8FB9C3 #x59E3 -#x8FB9C4 #x59E4 -#x8FB9C5 #x59E7 -#x8FB9C6 #x59EE -#x8FB9C7 #x59EF -#x8FB9C8 #x59F1 -#x8FB9C9 #x59F2 -#x8FB9CA #x59F4 -#x8FB9CB #x59F7 -#x8FB9CC #x5A00 -#x8FB9CD #x5A04 -#x8FB9CE #x5A0C -#x8FB9CF #x5A0D -#x8FB9D0 #x5A0E -#x8FB9D1 #x5A12 -#x8FB9D2 #x5A13 -#x8FB9D3 #x5A1E -#x8FB9D4 #x5A23 -#x8FB9D5 #x5A24 -#x8FB9D6 #x5A27 -#x8FB9D7 #x5A28 -#x8FB9D8 #x5A2A -#x8FB9D9 #x5A2D -#x8FB9DA #x5A30 -#x8FB9DB #x5A44 -#x8FB9DC #x5A45 -#x8FB9DD #x5A47 -#x8FB9DE #x5A48 -#x8FB9DF #x5A4C -#x8FB9E0 #x5A50 -#x8FB9E1 #x5A55 -#x8FB9E2 #x5A5E -#x8FB9E3 #x5A63 -#x8FB9E4 #x5A65 -#x8FB9E5 #x5A67 -#x8FB9E6 #x5A6D -#x8FB9E7 #x5A77 -#x8FB9E8 #x5A7A -#x8FB9E9 #x5A7B -#x8FB9EA #x5A7E -#x8FB9EB #x5A8B -#x8FB9EC #x5A90 -#x8FB9ED #x5A93 -#x8FB9EE #x5A96 -#x8FB9EF #x5A99 -#x8FB9F0 #x5A9C -#x8FB9F1 #x5A9E -#x8FB9F2 #x5A9F -#x8FB9F3 #x5AA0 -#x8FB9F4 #x5AA2 -#x8FB9F5 #x5AA7 -#x8FB9F6 #x5AAC -#x8FB9F7 #x5AB1 -#x8FB9F8 #x5AB2 -#x8FB9F9 #x5AB3 -#x8FB9FA #x5AB5 -#x8FB9FB #x5AB8 -#x8FB9FC #x5ABA -#x8FB9FD #x5ABB -#x8FB9FE #x5ABF -#x8FBAA1 #x5AC4 -#x8FBAA2 #x5AC6 -#x8FBAA3 #x5AC8 -#x8FBAA4 #x5ACF -#x8FBAA5 #x5ADA -#x8FBAA6 #x5ADC -#x8FBAA7 #x5AE0 -#x8FBAA8 #x5AE5 -#x8FBAA9 #x5AEA -#x8FBAAA #x5AEE -#x8FBAAB #x5AF5 -#x8FBAAC #x5AF6 -#x8FBAAD #x5AFD -#x8FBAAE #x5B00 -#x8FBAAF #x5B01 -#x8FBAB0 #x5B08 -#x8FBAB1 #x5B17 -#x8FBAB2 #x5B34 -#x8FBAB3 #x5B19 -#x8FBAB4 #x5B1B -#x8FBAB5 #x5B1D -#x8FBAB6 #x5B21 -#x8FBAB7 #x5B25 -#x8FBAB8 #x5B2D -#x8FBAB9 #x5B38 -#x8FBABA #x5B41 -#x8FBABB #x5B4B -#x8FBABC #x5B4C -#x8FBABD #x5B52 -#x8FBABE #x5B56 -#x8FBABF #x5B5E -#x8FBAC0 #x5B68 -#x8FBAC1 #x5B6E -#x8FBAC2 #x5B6F -#x8FBAC3 #x5B7C -#x8FBAC4 #x5B7D -#x8FBAC5 #x5B7E -#x8FBAC6 #x5B7F -#x8FBAC7 #x5B81 -#x8FBAC8 #x5B84 -#x8FBAC9 #x5B86 -#x8FBACA #x5B8A -#x8FBACB #x5B8E -#x8FBACC #x5B90 -#x8FBACD #x5B91 -#x8FBACE #x5B93 -#x8FBACF #x5B94 -#x8FBAD0 #x5B96 -#x8FBAD1 #x5BA8 -#x8FBAD2 #x5BA9 -#x8FBAD3 #x5BAC -#x8FBAD4 #x5BAD -#x8FBAD5 #x5BAF -#x8FBAD6 #x5BB1 -#x8FBAD7 #x5BB2 -#x8FBAD8 #x5BB7 -#x8FBAD9 #x5BBA -#x8FBADA #x5BBC -#x8FBADB #x5BC0 -#x8FBADC #x5BC1 -#x8FBADD #x5BCD -#x8FBADE #x5BCF -#x8FBADF #x5BD6 -#x8FBAE0 #x5BD7 -#x8FBAE1 #x5BD8 -#x8FBAE2 #x5BD9 -#x8FBAE3 #x5BDA -#x8FBAE4 #x5BE0 -#x8FBAE5 #x5BEF -#x8FBAE6 #x5BF1 -#x8FBAE7 #x5BF4 -#x8FBAE8 #x5BFD -#x8FBAE9 #x5C0C -#x8FBAEA #x5C17 -#x8FBAEB #x5C1E -#x8FBAEC #x5C1F -#x8FBAED #x5C23 -#x8FBAEE #x5C26 -#x8FBAEF #x5C29 -#x8FBAF0 #x5C2B -#x8FBAF1 #x5C2C -#x8FBAF2 #x5C2E -#x8FBAF3 #x5C30 -#x8FBAF4 #x5C32 -#x8FBAF5 #x5C35 -#x8FBAF6 #x5C36 -#x8FBAF7 #x5C59 -#x8FBAF8 #x5C5A -#x8FBAF9 #x5C5C -#x8FBAFA #x5C62 -#x8FBAFB #x5C63 -#x8FBAFC #x5C67 -#x8FBAFD #x5C68 -#x8FBAFE #x5C69 -#x8FBBA1 #x5C6D -#x8FBBA2 #x5C70 -#x8FBBA3 #x5C74 -#x8FBBA4 #x5C75 -#x8FBBA5 #x5C7A -#x8FBBA6 #x5C7B -#x8FBBA7 #x5C7C -#x8FBBA8 #x5C7D -#x8FBBA9 #x5C87 -#x8FBBAA #x5C88 -#x8FBBAB #x5C8A -#x8FBBAC #x5C8F -#x8FBBAD #x5C92 -#x8FBBAE #x5C9D -#x8FBBAF #x5C9F -#x8FBBB0 #x5CA0 -#x8FBBB1 #x5CA2 -#x8FBBB2 #x5CA3 -#x8FBBB3 #x5CA6 -#x8FBBB4 #x5CAA -#x8FBBB5 #x5CB2 -#x8FBBB6 #x5CB4 -#x8FBBB7 #x5CB5 -#x8FBBB8 #x5CBA -#x8FBBB9 #x5CC9 -#x8FBBBA #x5CCB -#x8FBBBB #x5CD2 -#x8FBBBC #x5CDD -#x8FBBBD #x5CD7 -#x8FBBBE #x5CEE -#x8FBBBF #x5CF1 -#x8FBBC0 #x5CF2 -#x8FBBC1 #x5CF4 -#x8FBBC2 #x5D01 -#x8FBBC3 #x5D06 -#x8FBBC4 #x5D0D -#x8FBBC5 #x5D12 -#x8FBBC6 #x5D2B -#x8FBBC7 #x5D23 -#x8FBBC8 #x5D24 -#x8FBBC9 #x5D26 -#x8FBBCA #x5D27 -#x8FBBCB #x5D31 -#x8FBBCC #x5D34 -#x8FBBCD #x5D39 -#x8FBBCE #x5D3D -#x8FBBCF #x5D3F -#x8FBBD0 #x5D42 -#x8FBBD1 #x5D43 -#x8FBBD2 #x5D46 -#x8FBBD3 #x5D48 -#x8FBBD4 #x5D55 -#x8FBBD5 #x5D51 -#x8FBBD6 #x5D59 -#x8FBBD7 #x5D4A -#x8FBBD8 #x5D5F -#x8FBBD9 #x5D60 -#x8FBBDA #x5D61 -#x8FBBDB #x5D62 -#x8FBBDC #x5D64 -#x8FBBDD #x5D6A -#x8FBBDE #x5D6D -#x8FBBDF #x5D70 -#x8FBBE0 #x5D79 -#x8FBBE1 #x5D7A -#x8FBBE2 #x5D7E -#x8FBBE3 #x5D7F -#x8FBBE4 #x5D81 -#x8FBBE5 #x5D83 -#x8FBBE6 #x5D88 -#x8FBBE7 #x5D8A -#x8FBBE8 #x5D92 -#x8FBBE9 #x5D93 -#x8FBBEA #x5D94 -#x8FBBEB #x5D95 -#x8FBBEC #x5D99 -#x8FBBED #x5D9B -#x8FBBEE #x5D9F -#x8FBBEF #x5DA0 -#x8FBBF0 #x5DA7 -#x8FBBF1 #x5DAB -#x8FBBF2 #x5DB0 -#x8FBBF3 #x5DB4 -#x8FBBF4 #x5DB8 -#x8FBBF5 #x5DB9 -#x8FBBF6 #x5DC3 -#x8FBBF7 #x5DC7 -#x8FBBF8 #x5DCB -#x8FBBF9 #x5DD0 -#x8FBBFA #x5DCE -#x8FBBFB #x5DD8 -#x8FBBFC #x5DD9 -#x8FBBFD #x5DE0 -#x8FBBFE #x5DE4 -#x8FBCA1 #x5DE9 -#x8FBCA2 #x5DF8 -#x8FBCA3 #x5DF9 -#x8FBCA4 #x5E00 -#x8FBCA5 #x5E07 -#x8FBCA6 #x5E0D -#x8FBCA7 #x5E12 -#x8FBCA8 #x5E14 -#x8FBCA9 #x5E15 -#x8FBCAA #x5E18 -#x8FBCAB #x5E1F -#x8FBCAC #x5E20 -#x8FBCAD #x5E2E -#x8FBCAE #x5E28 -#x8FBCAF #x5E32 -#x8FBCB0 #x5E35 -#x8FBCB1 #x5E3E -#x8FBCB2 #x5E4B -#x8FBCB3 #x5E50 -#x8FBCB4 #x5E49 -#x8FBCB5 #x5E51 -#x8FBCB6 #x5E56 -#x8FBCB7 #x5E58 -#x8FBCB8 #x5E5B -#x8FBCB9 #x5E5C -#x8FBCBA #x5E5E -#x8FBCBB #x5E68 -#x8FBCBC #x5E6A -#x8FBCBD #x5E6B -#x8FBCBE #x5E6C -#x8FBCBF #x5E6D -#x8FBCC0 #x5E6E -#x8FBCC1 #x5E70 -#x8FBCC2 #x5E80 -#x8FBCC3 #x5E8B -#x8FBCC4 #x5E8E -#x8FBCC5 #x5EA2 -#x8FBCC6 #x5EA4 -#x8FBCC7 #x5EA5 -#x8FBCC8 #x5EA8 -#x8FBCC9 #x5EAA -#x8FBCCA #x5EAC -#x8FBCCB #x5EB1 -#x8FBCCC #x5EB3 -#x8FBCCD #x5EBD -#x8FBCCE #x5EBE -#x8FBCCF #x5EBF -#x8FBCD0 #x5EC6 -#x8FBCD1 #x5ECC -#x8FBCD2 #x5ECB -#x8FBCD3 #x5ECE -#x8FBCD4 #x5ED1 -#x8FBCD5 #x5ED2 -#x8FBCD6 #x5ED4 -#x8FBCD7 #x5ED5 -#x8FBCD8 #x5EDC -#x8FBCD9 #x5EDE -#x8FBCDA #x5EE5 -#x8FBCDB #x5EEB -#x8FBCDC #x5F02 -#x8FBCDD #x5F06 -#x8FBCDE #x5F07 -#x8FBCDF #x5F08 -#x8FBCE0 #x5F0E -#x8FBCE1 #x5F19 -#x8FBCE2 #x5F1C -#x8FBCE3 #x5F1D -#x8FBCE4 #x5F21 -#x8FBCE5 #x5F22 -#x8FBCE6 #x5F23 -#x8FBCE7 #x5F24 -#x8FBCE8 #x5F28 -#x8FBCE9 #x5F2B -#x8FBCEA #x5F2C -#x8FBCEB #x5F2E -#x8FBCEC #x5F30 -#x8FBCED #x5F34 -#x8FBCEE #x5F36 -#x8FBCEF #x5F3B -#x8FBCF0 #x5F3D -#x8FBCF1 #x5F3F -#x8FBCF2 #x5F40 -#x8FBCF3 #x5F44 -#x8FBCF4 #x5F45 -#x8FBCF5 #x5F47 -#x8FBCF6 #x5F4D -#x8FBCF7 #x5F50 -#x8FBCF8 #x5F54 -#x8FBCF9 #x5F58 -#x8FBCFA #x5F5B -#x8FBCFB #x5F60 -#x8FBCFC #x5F63 -#x8FBCFD #x5F64 -#x8FBCFE #x5F67 -#x8FBDA1 #x5F6F -#x8FBDA2 #x5F72 -#x8FBDA3 #x5F74 -#x8FBDA4 #x5F75 -#x8FBDA5 #x5F78 -#x8FBDA6 #x5F7A -#x8FBDA7 #x5F7D -#x8FBDA8 #x5F7E -#x8FBDA9 #x5F89 -#x8FBDAA #x5F8D -#x8FBDAB #x5F8F -#x8FBDAC #x5F96 -#x8FBDAD #x5F9C -#x8FBDAE #x5F9D -#x8FBDAF #x5FA2 -#x8FBDB0 #x5FA7 -#x8FBDB1 #x5FAB -#x8FBDB2 #x5FA4 -#x8FBDB3 #x5FAC -#x8FBDB4 #x5FAF -#x8FBDB5 #x5FB0 -#x8FBDB6 #x5FB1 -#x8FBDB7 #x5FB8 -#x8FBDB8 #x5FC4 -#x8FBDB9 #x5FC7 -#x8FBDBA #x5FC8 -#x8FBDBB #x5FC9 -#x8FBDBC #x5FCB -#x8FBDBD #x5FD0 -#x8FBDBE #x5FD1 -#x8FBDBF #x5FD2 -#x8FBDC0 #x5FD3 -#x8FBDC1 #x5FD4 -#x8FBDC2 #x5FDE -#x8FBDC3 #x5FE1 -#x8FBDC4 #x5FE2 -#x8FBDC5 #x5FE8 -#x8FBDC6 #x5FE9 -#x8FBDC7 #x5FEA -#x8FBDC8 #x5FEC -#x8FBDC9 #x5FED -#x8FBDCA #x5FEE -#x8FBDCB #x5FEF -#x8FBDCC #x5FF2 -#x8FBDCD #x5FF3 -#x8FBDCE #x5FF6 -#x8FBDCF #x5FFA -#x8FBDD0 #x5FFC -#x8FBDD1 #x6007 -#x8FBDD2 #x600A -#x8FBDD3 #x600D -#x8FBDD4 #x6013 -#x8FBDD5 #x6014 -#x8FBDD6 #x6017 -#x8FBDD7 #x6018 -#x8FBDD8 #x601A -#x8FBDD9 #x601F -#x8FBDDA #x6024 -#x8FBDDB #x602D -#x8FBDDC #x6033 -#x8FBDDD #x6035 -#x8FBDDE #x6040 -#x8FBDDF #x6047 -#x8FBDE0 #x6048 -#x8FBDE1 #x6049 -#x8FBDE2 #x604C -#x8FBDE3 #x6051 -#x8FBDE4 #x6054 -#x8FBDE5 #x6056 -#x8FBDE6 #x6057 -#x8FBDE7 #x605D -#x8FBDE8 #x6061 -#x8FBDE9 #x6067 -#x8FBDEA #x6071 -#x8FBDEB #x607E -#x8FBDEC #x607F -#x8FBDED #x6082 -#x8FBDEE #x6086 -#x8FBDEF #x6088 -#x8FBDF0 #x608A -#x8FBDF1 #x608E -#x8FBDF2 #x6091 -#x8FBDF3 #x6093 -#x8FBDF4 #x6095 -#x8FBDF5 #x6098 -#x8FBDF6 #x609D -#x8FBDF7 #x609E -#x8FBDF8 #x60A2 -#x8FBDF9 #x60A4 -#x8FBDFA #x60A5 -#x8FBDFB #x60A8 -#x8FBDFC #x60B0 -#x8FBDFD #x60B1 -#x8FBDFE #x60B7 -#x8FBEA1 #x60BB -#x8FBEA2 #x60BE -#x8FBEA3 #x60C2 -#x8FBEA4 #x60C4 -#x8FBEA5 #x60C8 -#x8FBEA6 #x60C9 -#x8FBEA7 #x60CA -#x8FBEA8 #x60CB -#x8FBEA9 #x60CE -#x8FBEAA #x60CF -#x8FBEAB #x60D4 -#x8FBEAC #x60D5 -#x8FBEAD #x60D9 -#x8FBEAE #x60DB -#x8FBEAF #x60DD -#x8FBEB0 #x60DE -#x8FBEB1 #x60E2 -#x8FBEB2 #x60E5 -#x8FBEB3 #x60F2 -#x8FBEB4 #x60F5 -#x8FBEB5 #x60F8 -#x8FBEB6 #x60FC -#x8FBEB7 #x60FD -#x8FBEB8 #x6102 -#x8FBEB9 #x6107 -#x8FBEBA #x610A -#x8FBEBB #x610C -#x8FBEBC #x6110 -#x8FBEBD #x6111 -#x8FBEBE #x6112 -#x8FBEBF #x6113 -#x8FBEC0 #x6114 -#x8FBEC1 #x6116 -#x8FBEC2 #x6117 -#x8FBEC3 #x6119 -#x8FBEC4 #x611C -#x8FBEC5 #x611E -#x8FBEC6 #x6122 -#x8FBEC7 #x612A -#x8FBEC8 #x612B -#x8FBEC9 #x6130 -#x8FBECA #x6131 -#x8FBECB #x6135 -#x8FBECC #x6136 -#x8FBECD #x6137 -#x8FBECE #x6139 -#x8FBECF #x6141 -#x8FBED0 #x6145 -#x8FBED1 #x6146 -#x8FBED2 #x6149 -#x8FBED3 #x615E -#x8FBED4 #x6160 -#x8FBED5 #x616C -#x8FBED6 #x6172 -#x8FBED7 #x6178 -#x8FBED8 #x617B -#x8FBED9 #x617C -#x8FBEDA #x617F -#x8FBEDB #x6180 -#x8FBEDC #x6181 -#x8FBEDD #x6183 -#x8FBEDE #x6184 -#x8FBEDF #x618B -#x8FBEE0 #x618D -#x8FBEE1 #x6192 -#x8FBEE2 #x6193 -#x8FBEE3 #x6197 -#x8FBEE4 #x6198 -#x8FBEE5 #x619C -#x8FBEE6 #x619D -#x8FBEE7 #x619F -#x8FBEE8 #x61A0 -#x8FBEE9 #x61A5 -#x8FBEEA #x61A8 -#x8FBEEB #x61AA -#x8FBEEC #x61AD -#x8FBEED #x61B8 -#x8FBEEE #x61B9 -#x8FBEEF #x61BC -#x8FBEF0 #x61C0 -#x8FBEF1 #x61C1 -#x8FBEF2 #x61C2 -#x8FBEF3 #x61CE -#x8FBEF4 #x61CF -#x8FBEF5 #x61D5 -#x8FBEF6 #x61DC -#x8FBEF7 #x61DD -#x8FBEF8 #x61DE -#x8FBEF9 #x61DF -#x8FBEFA #x61E1 -#x8FBEFB #x61E2 -#x8FBEFC #x61E7 -#x8FBEFD #x61E9 -#x8FBEFE #x61E5 -#x8FBFA1 #x61EC -#x8FBFA2 #x61ED -#x8FBFA3 #x61EF -#x8FBFA4 #x6201 -#x8FBFA5 #x6203 -#x8FBFA6 #x6204 -#x8FBFA7 #x6207 -#x8FBFA8 #x6213 -#x8FBFA9 #x6215 -#x8FBFAA #x621C -#x8FBFAB #x6220 -#x8FBFAC #x6222 -#x8FBFAD #x6223 -#x8FBFAE #x6227 -#x8FBFAF #x6229 -#x8FBFB0 #x622B -#x8FBFB1 #x6239 -#x8FBFB2 #x623D -#x8FBFB3 #x6242 -#x8FBFB4 #x6243 -#x8FBFB5 #x6244 -#x8FBFB6 #x6246 -#x8FBFB7 #x624C -#x8FBFB8 #x6250 -#x8FBFB9 #x6251 -#x8FBFBA #x6252 -#x8FBFBB #x6254 -#x8FBFBC #x6256 -#x8FBFBD #x625A -#x8FBFBE #x625C -#x8FBFBF #x6264 -#x8FBFC0 #x626D -#x8FBFC1 #x626F -#x8FBFC2 #x6273 -#x8FBFC3 #x627A -#x8FBFC4 #x627D -#x8FBFC5 #x628D -#x8FBFC6 #x628E -#x8FBFC7 #x628F -#x8FBFC8 #x6290 -#x8FBFC9 #x62A6 -#x8FBFCA #x62A8 -#x8FBFCB #x62B3 -#x8FBFCC #x62B6 -#x8FBFCD #x62B7 -#x8FBFCE #x62BA -#x8FBFCF #x62BE -#x8FBFD0 #x62BF -#x8FBFD1 #x62C4 -#x8FBFD2 #x62CE -#x8FBFD3 #x62D5 -#x8FBFD4 #x62D6 -#x8FBFD5 #x62DA -#x8FBFD6 #x62EA -#x8FBFD7 #x62F2 -#x8FBFD8 #x62F4 -#x8FBFD9 #x62FC -#x8FBFDA #x62FD -#x8FBFDB #x6303 -#x8FBFDC #x6304 -#x8FBFDD #x630A -#x8FBFDE #x630B -#x8FBFDF #x630D -#x8FBFE0 #x6310 -#x8FBFE1 #x6313 -#x8FBFE2 #x6316 -#x8FBFE3 #x6318 -#x8FBFE4 #x6329 -#x8FBFE5 #x632A -#x8FBFE6 #x632D -#x8FBFE7 #x6335 -#x8FBFE8 #x6336 -#x8FBFE9 #x6339 -#x8FBFEA #x633C -#x8FBFEB #x6341 -#x8FBFEC #x6342 -#x8FBFED #x6343 -#x8FBFEE #x6344 -#x8FBFEF #x6346 -#x8FBFF0 #x634A -#x8FBFF1 #x634B -#x8FBFF2 #x634E -#x8FBFF3 #x6352 -#x8FBFF4 #x6353 -#x8FBFF5 #x6354 -#x8FBFF6 #x6358 -#x8FBFF7 #x635B -#x8FBFF8 #x6365 -#x8FBFF9 #x6366 -#x8FBFFA #x636C -#x8FBFFB #x636D -#x8FBFFC #x6371 -#x8FBFFD #x6374 -#x8FBFFE #x6375 -#x8FC0A1 #x6378 -#x8FC0A2 #x637C -#x8FC0A3 #x637D -#x8FC0A4 #x637F -#x8FC0A5 #x6382 -#x8FC0A6 #x6384 -#x8FC0A7 #x6387 -#x8FC0A8 #x638A -#x8FC0A9 #x6390 -#x8FC0AA #x6394 -#x8FC0AB #x6395 -#x8FC0AC #x6399 -#x8FC0AD #x639A -#x8FC0AE #x639E -#x8FC0AF #x63A4 -#x8FC0B0 #x63A6 -#x8FC0B1 #x63AD -#x8FC0B2 #x63AE -#x8FC0B3 #x63AF -#x8FC0B4 #x63BD -#x8FC0B5 #x63C1 -#x8FC0B6 #x63C5 -#x8FC0B7 #x63C8 -#x8FC0B8 #x63CE -#x8FC0B9 #x63D1 -#x8FC0BA #x63D3 -#x8FC0BB #x63D4 -#x8FC0BC #x63D5 -#x8FC0BD #x63DC -#x8FC0BE #x63E0 -#x8FC0BF #x63E5 -#x8FC0C0 #x63EA -#x8FC0C1 #x63EC -#x8FC0C2 #x63F2 -#x8FC0C3 #x63F3 -#x8FC0C4 #x63F5 -#x8FC0C5 #x63F8 -#x8FC0C6 #x63F9 -#x8FC0C7 #x6409 -#x8FC0C8 #x640A -#x8FC0C9 #x6410 -#x8FC0CA #x6412 -#x8FC0CB #x6414 -#x8FC0CC #x6418 -#x8FC0CD #x641E -#x8FC0CE #x6420 -#x8FC0CF #x6422 -#x8FC0D0 #x6424 -#x8FC0D1 #x6425 -#x8FC0D2 #x6429 -#x8FC0D3 #x642A -#x8FC0D4 #x642F -#x8FC0D5 #x6430 -#x8FC0D6 #x6435 -#x8FC0D7 #x643D -#x8FC0D8 #x643F -#x8FC0D9 #x644B -#x8FC0DA #x644F -#x8FC0DB #x6451 -#x8FC0DC #x6452 -#x8FC0DD #x6453 -#x8FC0DE #x6454 -#x8FC0DF #x645A -#x8FC0E0 #x645B -#x8FC0E1 #x645C -#x8FC0E2 #x645D -#x8FC0E3 #x645F -#x8FC0E4 #x6460 -#x8FC0E5 #x6461 -#x8FC0E6 #x6463 -#x8FC0E7 #x646D -#x8FC0E8 #x6473 -#x8FC0E9 #x6474 -#x8FC0EA #x647B -#x8FC0EB #x647D -#x8FC0EC #x6485 -#x8FC0ED #x6487 -#x8FC0EE #x648F -#x8FC0EF #x6490 -#x8FC0F0 #x6491 -#x8FC0F1 #x6498 -#x8FC0F2 #x6499 -#x8FC0F3 #x649B -#x8FC0F4 #x649D -#x8FC0F5 #x649F -#x8FC0F6 #x64A1 -#x8FC0F7 #x64A3 -#x8FC0F8 #x64A6 -#x8FC0F9 #x64A8 -#x8FC0FA #x64AC -#x8FC0FB #x64B3 -#x8FC0FC #x64BD -#x8FC0FD #x64BE -#x8FC0FE #x64BF -#x8FC1A1 #x64C4 -#x8FC1A2 #x64C9 -#x8FC1A3 #x64CA -#x8FC1A4 #x64CB -#x8FC1A5 #x64CC -#x8FC1A6 #x64CE -#x8FC1A7 #x64D0 -#x8FC1A8 #x64D1 -#x8FC1A9 #x64D5 -#x8FC1AA #x64D7 -#x8FC1AB #x64E4 -#x8FC1AC #x64E5 -#x8FC1AD #x64E9 -#x8FC1AE #x64EA -#x8FC1AF #x64ED -#x8FC1B0 #x64F0 -#x8FC1B1 #x64F5 -#x8FC1B2 #x64F7 -#x8FC1B3 #x64FB -#x8FC1B4 #x64FF -#x8FC1B5 #x6501 -#x8FC1B6 #x6504 -#x8FC1B7 #x6508 -#x8FC1B8 #x6509 -#x8FC1B9 #x650A -#x8FC1BA #x650F -#x8FC1BB #x6513 -#x8FC1BC #x6514 -#x8FC1BD #x6516 -#x8FC1BE #x6519 -#x8FC1BF #x651B -#x8FC1C0 #x651E -#x8FC1C1 #x651F -#x8FC1C2 #x6522 -#x8FC1C3 #x6526 -#x8FC1C4 #x6529 -#x8FC1C5 #x652E -#x8FC1C6 #x6531 -#x8FC1C7 #x653A -#x8FC1C8 #x653C -#x8FC1C9 #x653D -#x8FC1CA #x6543 -#x8FC1CB #x6547 -#x8FC1CC #x6549 -#x8FC1CD #x6550 -#x8FC1CE #x6552 -#x8FC1CF #x6554 -#x8FC1D0 #x655F -#x8FC1D1 #x6560 -#x8FC1D2 #x6567 -#x8FC1D3 #x656B -#x8FC1D4 #x657A -#x8FC1D5 #x657D -#x8FC1D6 #x6581 -#x8FC1D7 #x6585 -#x8FC1D8 #x658A -#x8FC1D9 #x6592 -#x8FC1DA #x6595 -#x8FC1DB #x6598 -#x8FC1DC #x659D -#x8FC1DD #x65A0 -#x8FC1DE #x65A3 -#x8FC1DF #x65A6 -#x8FC1E0 #x65AE -#x8FC1E1 #x65B2 -#x8FC1E2 #x65B3 -#x8FC1E3 #x65B4 -#x8FC1E4 #x65BF -#x8FC1E5 #x65C2 -#x8FC1E6 #x65C8 -#x8FC1E7 #x65C9 -#x8FC1E8 #x65CE -#x8FC1E9 #x65D0 -#x8FC1EA #x65D4 -#x8FC1EB #x65D6 -#x8FC1EC #x65D8 -#x8FC1ED #x65DF -#x8FC1EE #x65F0 -#x8FC1EF #x65F2 -#x8FC1F0 #x65F4 -#x8FC1F1 #x65F5 -#x8FC1F2 #x65F9 -#x8FC1F3 #x65FE -#x8FC1F4 #x65FF -#x8FC1F5 #x6600 -#x8FC1F6 #x6604 -#x8FC1F7 #x6608 -#x8FC1F8 #x6609 -#x8FC1F9 #x660D -#x8FC1FA #x6611 -#x8FC1FB #x6612 -#x8FC1FC #x6615 -#x8FC1FD #x6616 -#x8FC1FE #x661D -#x8FC2A1 #x661E -#x8FC2A2 #x6621 -#x8FC2A3 #x6622 -#x8FC2A4 #x6623 -#x8FC2A5 #x6624 -#x8FC2A6 #x6626 -#x8FC2A7 #x6629 -#x8FC2A8 #x662A -#x8FC2A9 #x662B -#x8FC2AA #x662C -#x8FC2AB #x662E -#x8FC2AC #x6630 -#x8FC2AD #x6631 -#x8FC2AE #x6633 -#x8FC2AF #x6639 -#x8FC2B0 #x6637 -#x8FC2B1 #x6640 -#x8FC2B2 #x6645 -#x8FC2B3 #x6646 -#x8FC2B4 #x664A -#x8FC2B5 #x664C -#x8FC2B6 #x6651 -#x8FC2B7 #x664E -#x8FC2B8 #x6657 -#x8FC2B9 #x6658 -#x8FC2BA #x6659 -#x8FC2BB #x665B -#x8FC2BC #x665C -#x8FC2BD #x6660 -#x8FC2BE #x6661 -#x8FC2BF #x66FB -#x8FC2C0 #x666A -#x8FC2C1 #x666B -#x8FC2C2 #x666C -#x8FC2C3 #x667E -#x8FC2C4 #x6673 -#x8FC2C5 #x6675 -#x8FC2C6 #x667F -#x8FC2C7 #x6677 -#x8FC2C8 #x6678 -#x8FC2C9 #x6679 -#x8FC2CA #x667B -#x8FC2CB #x6680 -#x8FC2CC #x667C -#x8FC2CD #x668B -#x8FC2CE #x668C -#x8FC2CF #x668D -#x8FC2D0 #x6690 -#x8FC2D1 #x6692 -#x8FC2D2 #x6699 -#x8FC2D3 #x669A -#x8FC2D4 #x669B -#x8FC2D5 #x669C -#x8FC2D6 #x669F -#x8FC2D7 #x66A0 -#x8FC2D8 #x66A4 -#x8FC2D9 #x66AD -#x8FC2DA #x66B1 -#x8FC2DB #x66B2 -#x8FC2DC #x66B5 -#x8FC2DD #x66BB -#x8FC2DE #x66BF -#x8FC2DF #x66C0 -#x8FC2E0 #x66C2 -#x8FC2E1 #x66C3 -#x8FC2E2 #x66C8 -#x8FC2E3 #x66CC -#x8FC2E4 #x66CE -#x8FC2E5 #x66CF -#x8FC2E6 #x66D4 -#x8FC2E7 #x66DB -#x8FC2E8 #x66DF -#x8FC2E9 #x66E8 -#x8FC2EA #x66EB -#x8FC2EB #x66EC -#x8FC2EC #x66EE -#x8FC2ED #x66FA -#x8FC2EE #x6705 -#x8FC2EF #x6707 -#x8FC2F0 #x670E -#x8FC2F1 #x6713 -#x8FC2F2 #x6719 -#x8FC2F3 #x671C -#x8FC2F4 #x6720 -#x8FC2F5 #x6722 -#x8FC2F6 #x6733 -#x8FC2F7 #x673E -#x8FC2F8 #x6745 -#x8FC2F9 #x6747 -#x8FC2FA #x6748 -#x8FC2FB #x674C -#x8FC2FC #x6754 -#x8FC2FD #x6755 -#x8FC2FE #x675D -#x8FC3A1 #x6766 -#x8FC3A2 #x676C -#x8FC3A3 #x676E -#x8FC3A4 #x6774 -#x8FC3A5 #x6776 -#x8FC3A6 #x677B -#x8FC3A7 #x6781 -#x8FC3A8 #x6784 -#x8FC3A9 #x678E -#x8FC3AA #x678F -#x8FC3AB #x6791 -#x8FC3AC #x6793 -#x8FC3AD #x6796 -#x8FC3AE #x6798 -#x8FC3AF #x6799 -#x8FC3B0 #x679B -#x8FC3B1 #x67B0 -#x8FC3B2 #x67B1 -#x8FC3B3 #x67B2 -#x8FC3B4 #x67B5 -#x8FC3B5 #x67BB -#x8FC3B6 #x67BC -#x8FC3B7 #x67BD -#x8FC3B8 #x67F9 -#x8FC3B9 #x67C0 -#x8FC3BA #x67C2 -#x8FC3BB #x67C3 -#x8FC3BC #x67C5 -#x8FC3BD #x67C8 -#x8FC3BE #x67C9 -#x8FC3BF #x67D2 -#x8FC3C0 #x67D7 -#x8FC3C1 #x67D9 -#x8FC3C2 #x67DC -#x8FC3C3 #x67E1 -#x8FC3C4 #x67E6 -#x8FC3C5 #x67F0 -#x8FC3C6 #x67F2 -#x8FC3C7 #x67F6 -#x8FC3C8 #x67F7 -#x8FC3C9 #x6852 -#x8FC3CA #x6814 -#x8FC3CB #x6819 -#x8FC3CC #x681D -#x8FC3CD #x681F -#x8FC3CE #x6828 -#x8FC3CF #x6827 -#x8FC3D0 #x682C -#x8FC3D1 #x682D -#x8FC3D2 #x682F -#x8FC3D3 #x6830 -#x8FC3D4 #x6831 -#x8FC3D5 #x6833 -#x8FC3D6 #x683B -#x8FC3D7 #x683F -#x8FC3D8 #x6844 -#x8FC3D9 #x6845 -#x8FC3DA #x684A -#x8FC3DB #x684C -#x8FC3DC #x6855 -#x8FC3DD #x6857 -#x8FC3DE #x6858 -#x8FC3DF #x685B -#x8FC3E0 #x686B -#x8FC3E1 #x686E -#x8FC3E2 #x686F -#x8FC3E3 #x6870 -#x8FC3E4 #x6871 -#x8FC3E5 #x6872 -#x8FC3E6 #x6875 -#x8FC3E7 #x6879 -#x8FC3E8 #x687A -#x8FC3E9 #x687B -#x8FC3EA #x687C -#x8FC3EB #x6882 -#x8FC3EC #x6884 -#x8FC3ED #x6886 -#x8FC3EE #x6888 -#x8FC3EF #x6896 -#x8FC3F0 #x6898 -#x8FC3F1 #x689A -#x8FC3F2 #x689C -#x8FC3F3 #x68A1 -#x8FC3F4 #x68A3 -#x8FC3F5 #x68A5 -#x8FC3F6 #x68A9 -#x8FC3F7 #x68AA -#x8FC3F8 #x68AE -#x8FC3F9 #x68B2 -#x8FC3FA #x68BB -#x8FC3FB #x68C5 -#x8FC3FC #x68C8 -#x8FC3FD #x68CC -#x8FC3FE #x68CF -#x8FC4A1 #x68D0 -#x8FC4A2 #x68D1 -#x8FC4A3 #x68D3 -#x8FC4A4 #x68D6 -#x8FC4A5 #x68D9 -#x8FC4A6 #x68DC -#x8FC4A7 #x68DD -#x8FC4A8 #x68E5 -#x8FC4A9 #x68E8 -#x8FC4AA #x68EA -#x8FC4AB #x68EB -#x8FC4AC #x68EC -#x8FC4AD #x68ED -#x8FC4AE #x68F0 -#x8FC4AF #x68F1 -#x8FC4B0 #x68F5 -#x8FC4B1 #x68F6 -#x8FC4B2 #x68FB -#x8FC4B3 #x68FC -#x8FC4B4 #x68FD -#x8FC4B5 #x6906 -#x8FC4B6 #x6909 -#x8FC4B7 #x690A -#x8FC4B8 #x6910 -#x8FC4B9 #x6911 -#x8FC4BA #x6913 -#x8FC4BB #x6916 -#x8FC4BC #x6917 -#x8FC4BD #x6931 -#x8FC4BE #x6933 -#x8FC4BF #x6935 -#x8FC4C0 #x6938 -#x8FC4C1 #x693B -#x8FC4C2 #x6942 -#x8FC4C3 #x6945 -#x8FC4C4 #x6949 -#x8FC4C5 #x694E -#x8FC4C6 #x6957 -#x8FC4C7 #x695B -#x8FC4C8 #x6963 -#x8FC4C9 #x6964 -#x8FC4CA #x6965 -#x8FC4CB #x6966 -#x8FC4CC #x6968 -#x8FC4CD #x6969 -#x8FC4CE #x696C -#x8FC4CF #x6970 -#x8FC4D0 #x6971 -#x8FC4D1 #x6972 -#x8FC4D2 #x697A -#x8FC4D3 #x697B -#x8FC4D4 #x697F -#x8FC4D5 #x6980 -#x8FC4D6 #x698D -#x8FC4D7 #x6992 -#x8FC4D8 #x6996 -#x8FC4D9 #x6998 -#x8FC4DA #x69A1 -#x8FC4DB #x69A5 -#x8FC4DC #x69A6 -#x8FC4DD #x69A8 -#x8FC4DE #x69AB -#x8FC4DF #x69AD -#x8FC4E0 #x69AF -#x8FC4E1 #x69B7 -#x8FC4E2 #x69B8 -#x8FC4E3 #x69BA -#x8FC4E4 #x69BC -#x8FC4E5 #x69C5 -#x8FC4E6 #x69C8 -#x8FC4E7 #x69D1 -#x8FC4E8 #x69D6 -#x8FC4E9 #x69D7 -#x8FC4EA #x69E2 -#x8FC4EB #x69E5 -#x8FC4EC #x69EE -#x8FC4ED #x69EF -#x8FC4EE #x69F1 -#x8FC4EF #x69F3 -#x8FC4F0 #x69F5 -#x8FC4F1 #x69FE -#x8FC4F2 #x6A00 -#x8FC4F3 #x6A01 -#x8FC4F4 #x6A03 -#x8FC4F5 #x6A0F -#x8FC4F6 #x6A11 -#x8FC4F7 #x6A15 -#x8FC4F8 #x6A1A -#x8FC4F9 #x6A1D -#x8FC4FA #x6A20 -#x8FC4FB #x6A24 -#x8FC4FC #x6A28 -#x8FC4FD #x6A30 -#x8FC4FE #x6A32 -#x8FC5A1 #x6A34 -#x8FC5A2 #x6A37 -#x8FC5A3 #x6A3B -#x8FC5A4 #x6A3E -#x8FC5A5 #x6A3F -#x8FC5A6 #x6A45 -#x8FC5A7 #x6A46 -#x8FC5A8 #x6A49 -#x8FC5A9 #x6A4A -#x8FC5AA #x6A4E -#x8FC5AB #x6A50 -#x8FC5AC #x6A51 -#x8FC5AD #x6A52 -#x8FC5AE #x6A55 -#x8FC5AF #x6A56 -#x8FC5B0 #x6A5B -#x8FC5B1 #x6A64 -#x8FC5B2 #x6A67 -#x8FC5B3 #x6A6A -#x8FC5B4 #x6A71 -#x8FC5B5 #x6A73 -#x8FC5B6 #x6A7E -#x8FC5B7 #x6A81 -#x8FC5B8 #x6A83 -#x8FC5B9 #x6A86 -#x8FC5BA #x6A87 -#x8FC5BB #x6A89 -#x8FC5BC #x6A8B -#x8FC5BD #x6A91 -#x8FC5BE #x6A9B -#x8FC5BF #x6A9D -#x8FC5C0 #x6A9E -#x8FC5C1 #x6A9F -#x8FC5C2 #x6AA5 -#x8FC5C3 #x6AAB -#x8FC5C4 #x6AAF -#x8FC5C5 #x6AB0 -#x8FC5C6 #x6AB1 -#x8FC5C7 #x6AB4 -#x8FC5C8 #x6ABD -#x8FC5C9 #x6ABE -#x8FC5CA #x6ABF -#x8FC5CB #x6AC6 -#x8FC5CC #x6AC9 -#x8FC5CD #x6AC8 -#x8FC5CE #x6ACC -#x8FC5CF #x6AD0 -#x8FC5D0 #x6AD4 -#x8FC5D1 #x6AD5 -#x8FC5D2 #x6AD6 -#x8FC5D3 #x6ADC -#x8FC5D4 #x6ADD -#x8FC5D5 #x6AE4 -#x8FC5D6 #x6AE7 -#x8FC5D7 #x6AEC -#x8FC5D8 #x6AF0 -#x8FC5D9 #x6AF1 -#x8FC5DA #x6AF2 -#x8FC5DB #x6AFC -#x8FC5DC #x6AFD -#x8FC5DD #x6B02 -#x8FC5DE #x6B03 -#x8FC5DF #x6B06 -#x8FC5E0 #x6B07 -#x8FC5E1 #x6B09 -#x8FC5E2 #x6B0F -#x8FC5E3 #x6B10 -#x8FC5E4 #x6B11 -#x8FC5E5 #x6B17 -#x8FC5E6 #x6B1B -#x8FC5E7 #x6B1E -#x8FC5E8 #x6B24 -#x8FC5E9 #x6B28 -#x8FC5EA #x6B2B -#x8FC5EB #x6B2C -#x8FC5EC #x6B2F -#x8FC5ED #x6B35 -#x8FC5EE #x6B36 -#x8FC5EF #x6B3B -#x8FC5F0 #x6B3F -#x8FC5F1 #x6B46 -#x8FC5F2 #x6B4A -#x8FC5F3 #x6B4D -#x8FC5F4 #x6B52 -#x8FC5F5 #x6B56 -#x8FC5F6 #x6B58 -#x8FC5F7 #x6B5D -#x8FC5F8 #x6B60 -#x8FC5F9 #x6B67 -#x8FC5FA #x6B6B -#x8FC5FB #x6B6E -#x8FC5FC #x6B70 -#x8FC5FD #x6B75 -#x8FC5FE #x6B7D -#x8FC6A1 #x6B7E -#x8FC6A2 #x6B82 -#x8FC6A3 #x6B85 -#x8FC6A4 #x6B97 -#x8FC6A5 #x6B9B -#x8FC6A6 #x6B9F -#x8FC6A7 #x6BA0 -#x8FC6A8 #x6BA2 -#x8FC6A9 #x6BA3 -#x8FC6AA #x6BA8 -#x8FC6AB #x6BA9 -#x8FC6AC #x6BAC -#x8FC6AD #x6BAD -#x8FC6AE #x6BAE -#x8FC6AF #x6BB0 -#x8FC6B0 #x6BB8 -#x8FC6B1 #x6BB9 -#x8FC6B2 #x6BBD -#x8FC6B3 #x6BBE -#x8FC6B4 #x6BC3 -#x8FC6B5 #x6BC4 -#x8FC6B6 #x6BC9 -#x8FC6B7 #x6BCC -#x8FC6B8 #x6BD6 -#x8FC6B9 #x6BDA -#x8FC6BA #x6BE1 -#x8FC6BB #x6BE3 -#x8FC6BC #x6BE6 -#x8FC6BD #x6BE7 -#x8FC6BE #x6BEE -#x8FC6BF #x6BF1 -#x8FC6C0 #x6BF7 -#x8FC6C1 #x6BF9 -#x8FC6C2 #x6BFF -#x8FC6C3 #x6C02 -#x8FC6C4 #x6C04 -#x8FC6C5 #x6C05 -#x8FC6C6 #x6C09 -#x8FC6C7 #x6C0D -#x8FC6C8 #x6C0E -#x8FC6C9 #x6C10 -#x8FC6CA #x6C12 -#x8FC6CB #x6C19 -#x8FC6CC #x6C1F -#x8FC6CD #x6C26 -#x8FC6CE #x6C27 -#x8FC6CF #x6C28 -#x8FC6D0 #x6C2C -#x8FC6D1 #x6C2E -#x8FC6D2 #x6C33 -#x8FC6D3 #x6C35 -#x8FC6D4 #x6C36 -#x8FC6D5 #x6C3A -#x8FC6D6 #x6C3B -#x8FC6D7 #x6C3F -#x8FC6D8 #x6C4A -#x8FC6D9 #x6C4B -#x8FC6DA #x6C4D -#x8FC6DB #x6C4F -#x8FC6DC #x6C52 -#x8FC6DD #x6C54 -#x8FC6DE #x6C59 -#x8FC6DF #x6C5B -#x8FC6E0 #x6C5C -#x8FC6E1 #x6C6B -#x8FC6E2 #x6C6D -#x8FC6E3 #x6C6F -#x8FC6E4 #x6C74 -#x8FC6E5 #x6C76 -#x8FC6E6 #x6C78 -#x8FC6E7 #x6C79 -#x8FC6E8 #x6C7B -#x8FC6E9 #x6C85 -#x8FC6EA #x6C86 -#x8FC6EB #x6C87 -#x8FC6EC #x6C89 -#x8FC6ED #x6C94 -#x8FC6EE #x6C95 -#x8FC6EF #x6C97 -#x8FC6F0 #x6C98 -#x8FC6F1 #x6C9C -#x8FC6F2 #x6C9F -#x8FC6F3 #x6CB0 -#x8FC6F4 #x6CB2 -#x8FC6F5 #x6CB4 -#x8FC6F6 #x6CC2 -#x8FC6F7 #x6CC6 -#x8FC6F8 #x6CCD -#x8FC6F9 #x6CCF -#x8FC6FA #x6CD0 -#x8FC6FB #x6CD1 -#x8FC6FC #x6CD2 -#x8FC6FD #x6CD4 -#x8FC6FE #x6CD6 -#x8FC7A1 #x6CDA -#x8FC7A2 #x6CDC -#x8FC7A3 #x6CE0 -#x8FC7A4 #x6CE7 -#x8FC7A5 #x6CE9 -#x8FC7A6 #x6CEB -#x8FC7A7 #x6CEC -#x8FC7A8 #x6CEE -#x8FC7A9 #x6CF2 -#x8FC7AA #x6CF4 -#x8FC7AB #x6D04 -#x8FC7AC #x6D07 -#x8FC7AD #x6D0A -#x8FC7AE #x6D0E -#x8FC7AF #x6D0F -#x8FC7B0 #x6D11 -#x8FC7B1 #x6D13 -#x8FC7B2 #x6D1A -#x8FC7B3 #x6D26 -#x8FC7B4 #x6D27 -#x8FC7B5 #x6D28 -#x8FC7B6 #x6C67 -#x8FC7B7 #x6D2E -#x8FC7B8 #x6D2F -#x8FC7B9 #x6D31 -#x8FC7BA #x6D39 -#x8FC7BB #x6D3C -#x8FC7BC #x6D3F -#x8FC7BD #x6D57 -#x8FC7BE #x6D5E -#x8FC7BF #x6D5F -#x8FC7C0 #x6D61 -#x8FC7C1 #x6D65 -#x8FC7C2 #x6D67 -#x8FC7C3 #x6D6F -#x8FC7C4 #x6D70 -#x8FC7C5 #x6D7C -#x8FC7C6 #x6D82 -#x8FC7C7 #x6D87 -#x8FC7C8 #x6D91 -#x8FC7C9 #x6D92 -#x8FC7CA #x6D94 -#x8FC7CB #x6D96 -#x8FC7CC #x6D97 -#x8FC7CD #x6D98 -#x8FC7CE #x6DAA -#x8FC7CF #x6DAC -#x8FC7D0 #x6DB4 -#x8FC7D1 #x6DB7 -#x8FC7D2 #x6DB9 -#x8FC7D3 #x6DBD -#x8FC7D4 #x6DBF -#x8FC7D5 #x6DC4 -#x8FC7D6 #x6DC8 -#x8FC7D7 #x6DCA -#x8FC7D8 #x6DCE -#x8FC7D9 #x6DCF -#x8FC7DA #x6DD6 -#x8FC7DB #x6DDB -#x8FC7DC #x6DDD -#x8FC7DD #x6DDF -#x8FC7DE #x6DE0 -#x8FC7DF #x6DE2 -#x8FC7E0 #x6DE5 -#x8FC7E1 #x6DE9 -#x8FC7E2 #x6DEF -#x8FC7E3 #x6DF0 -#x8FC7E4 #x6DF4 -#x8FC7E5 #x6DF6 -#x8FC7E6 #x6DFC -#x8FC7E7 #x6E00 -#x8FC7E8 #x6E04 -#x8FC7E9 #x6E1E -#x8FC7EA #x6E22 -#x8FC7EB #x6E27 -#x8FC7EC #x6E32 -#x8FC7ED #x6E36 -#x8FC7EE #x6E39 -#x8FC7EF #x6E3B -#x8FC7F0 #x6E3C -#x8FC7F1 #x6E44 -#x8FC7F2 #x6E45 -#x8FC7F3 #x6E48 -#x8FC7F4 #x6E49 -#x8FC7F5 #x6E4B -#x8FC7F6 #x6E4F -#x8FC7F7 #x6E51 -#x8FC7F8 #x6E52 -#x8FC7F9 #x6E53 -#x8FC7FA #x6E54 -#x8FC7FB #x6E57 -#x8FC7FC #x6E5C -#x8FC7FD #x6E5D -#x8FC7FE #x6E5E -#x8FC8A1 #x6E62 -#x8FC8A2 #x6E63 -#x8FC8A3 #x6E68 -#x8FC8A4 #x6E73 -#x8FC8A5 #x6E7B -#x8FC8A6 #x6E7D -#x8FC8A7 #x6E8D -#x8FC8A8 #x6E93 -#x8FC8A9 #x6E99 -#x8FC8AA #x6EA0 -#x8FC8AB #x6EA7 -#x8FC8AC #x6EAD -#x8FC8AD #x6EAE -#x8FC8AE #x6EB1 -#x8FC8AF #x6EB3 -#x8FC8B0 #x6EBB -#x8FC8B1 #x6EBF -#x8FC8B2 #x6EC0 -#x8FC8B3 #x6EC1 -#x8FC8B4 #x6EC3 -#x8FC8B5 #x6EC7 -#x8FC8B6 #x6EC8 -#x8FC8B7 #x6ECA -#x8FC8B8 #x6ECD -#x8FC8B9 #x6ECE -#x8FC8BA #x6ECF -#x8FC8BB #x6EEB -#x8FC8BC #x6EED -#x8FC8BD #x6EEE -#x8FC8BE #x6EF9 -#x8FC8BF #x6EFB -#x8FC8C0 #x6EFD -#x8FC8C1 #x6F04 -#x8FC8C2 #x6F08 -#x8FC8C3 #x6F0A -#x8FC8C4 #x6F0C -#x8FC8C5 #x6F0D -#x8FC8C6 #x6F16 -#x8FC8C7 #x6F18 -#x8FC8C8 #x6F1A -#x8FC8C9 #x6F1B -#x8FC8CA #x6F26 -#x8FC8CB #x6F29 -#x8FC8CC #x6F2A -#x8FC8CD #x6F2F -#x8FC8CE #x6F30 -#x8FC8CF #x6F33 -#x8FC8D0 #x6F36 -#x8FC8D1 #x6F3B -#x8FC8D2 #x6F3C -#x8FC8D3 #x6F2D -#x8FC8D4 #x6F4F -#x8FC8D5 #x6F51 -#x8FC8D6 #x6F52 -#x8FC8D7 #x6F53 -#x8FC8D8 #x6F57 -#x8FC8D9 #x6F59 -#x8FC8DA #x6F5A -#x8FC8DB #x6F5D -#x8FC8DC #x6F5E -#x8FC8DD #x6F61 -#x8FC8DE #x6F62 -#x8FC8DF #x6F68 -#x8FC8E0 #x6F6C -#x8FC8E1 #x6F7D -#x8FC8E2 #x6F7E -#x8FC8E3 #x6F83 -#x8FC8E4 #x6F87 -#x8FC8E5 #x6F88 -#x8FC8E6 #x6F8B -#x8FC8E7 #x6F8C -#x8FC8E8 #x6F8D -#x8FC8E9 #x6F90 -#x8FC8EA #x6F92 -#x8FC8EB #x6F93 -#x8FC8EC #x6F94 -#x8FC8ED #x6F96 -#x8FC8EE #x6F9A -#x8FC8EF #x6F9F -#x8FC8F0 #x6FA0 -#x8FC8F1 #x6FA5 -#x8FC8F2 #x6FA6 -#x8FC8F3 #x6FA7 -#x8FC8F4 #x6FA8 -#x8FC8F5 #x6FAE -#x8FC8F6 #x6FAF -#x8FC8F7 #x6FB0 -#x8FC8F8 #x6FB5 -#x8FC8F9 #x6FB6 -#x8FC8FA #x6FBC -#x8FC8FB #x6FC5 -#x8FC8FC #x6FC7 -#x8FC8FD #x6FC8 -#x8FC8FE #x6FCA -#x8FC9A1 #x6FDA -#x8FC9A2 #x6FDE -#x8FC9A3 #x6FE8 -#x8FC9A4 #x6FE9 -#x8FC9A5 #x6FF0 -#x8FC9A6 #x6FF5 -#x8FC9A7 #x6FF9 -#x8FC9A8 #x6FFC -#x8FC9A9 #x6FFD -#x8FC9AA #x7000 -#x8FC9AB #x7005 -#x8FC9AC #x7006 -#x8FC9AD #x7007 -#x8FC9AE #x700D -#x8FC9AF #x7017 -#x8FC9B0 #x7020 -#x8FC9B1 #x7023 -#x8FC9B2 #x702F -#x8FC9B3 #x7034 -#x8FC9B4 #x7037 -#x8FC9B5 #x7039 -#x8FC9B6 #x703C -#x8FC9B7 #x7043 -#x8FC9B8 #x7044 -#x8FC9B9 #x7048 -#x8FC9BA #x7049 -#x8FC9BB #x704A -#x8FC9BC #x704B -#x8FC9BD #x7054 -#x8FC9BE #x7055 -#x8FC9BF #x705D -#x8FC9C0 #x705E -#x8FC9C1 #x704E -#x8FC9C2 #x7064 -#x8FC9C3 #x7065 -#x8FC9C4 #x706C -#x8FC9C5 #x706E -#x8FC9C6 #x7075 -#x8FC9C7 #x7076 -#x8FC9C8 #x707E -#x8FC9C9 #x7081 -#x8FC9CA #x7085 -#x8FC9CB #x7086 -#x8FC9CC #x7094 -#x8FC9CD #x7095 -#x8FC9CE #x7096 -#x8FC9CF #x7097 -#x8FC9D0 #x7098 -#x8FC9D1 #x709B -#x8FC9D2 #x70A4 -#x8FC9D3 #x70AB -#x8FC9D4 #x70B0 -#x8FC9D5 #x70B1 -#x8FC9D6 #x70B4 -#x8FC9D7 #x70B7 -#x8FC9D8 #x70CA -#x8FC9D9 #x70D1 -#x8FC9DA #x70D3 -#x8FC9DB #x70D4 -#x8FC9DC #x70D5 -#x8FC9DD #x70D6 -#x8FC9DE #x70D8 -#x8FC9DF #x70DC -#x8FC9E0 #x70E4 -#x8FC9E1 #x70FA -#x8FC9E2 #x7103 -#x8FC9E3 #x7104 -#x8FC9E4 #x7105 -#x8FC9E5 #x7106 -#x8FC9E6 #x7107 -#x8FC9E7 #x710B -#x8FC9E8 #x710C -#x8FC9E9 #x710F -#x8FC9EA #x711E -#x8FC9EB #x7120 -#x8FC9EC #x712B -#x8FC9ED #x712D -#x8FC9EE #x712F -#x8FC9EF #x7130 -#x8FC9F0 #x7131 -#x8FC9F1 #x7138 -#x8FC9F2 #x7141 -#x8FC9F3 #x7145 -#x8FC9F4 #x7146 -#x8FC9F5 #x7147 -#x8FC9F6 #x714A -#x8FC9F7 #x714B -#x8FC9F8 #x7150 -#x8FC9F9 #x7152 -#x8FC9FA #x7157 -#x8FC9FB #x715A -#x8FC9FC #x715C -#x8FC9FD #x715E -#x8FC9FE #x7160 -#x8FCAA1 #x7168 -#x8FCAA2 #x7179 -#x8FCAA3 #x7180 -#x8FCAA4 #x7185 -#x8FCAA5 #x7187 -#x8FCAA6 #x718C -#x8FCAA7 #x7192 -#x8FCAA8 #x719A -#x8FCAA9 #x719B -#x8FCAAA #x71A0 -#x8FCAAB #x71A2 -#x8FCAAC #x71AF -#x8FCAAD #x71B0 -#x8FCAAE #x71B2 -#x8FCAAF #x71B3 -#x8FCAB0 #x71BA -#x8FCAB1 #x71BF -#x8FCAB2 #x71C0 -#x8FCAB3 #x71C1 -#x8FCAB4 #x71C4 -#x8FCAB5 #x71CB -#x8FCAB6 #x71CC -#x8FCAB7 #x71D3 -#x8FCAB8 #x71D6 -#x8FCAB9 #x71D9 -#x8FCABA #x71DA -#x8FCABB #x71DC -#x8FCABC #x71F8 -#x8FCABD #x71FE -#x8FCABE #x7200 -#x8FCABF #x7207 -#x8FCAC0 #x7208 -#x8FCAC1 #x7209 -#x8FCAC2 #x7213 -#x8FCAC3 #x7217 -#x8FCAC4 #x721A -#x8FCAC5 #x721D -#x8FCAC6 #x721F -#x8FCAC7 #x7224 -#x8FCAC8 #x722B -#x8FCAC9 #x722F -#x8FCACA #x7234 -#x8FCACB #x7238 -#x8FCACC #x7239 -#x8FCACD #x7241 -#x8FCACE #x7242 -#x8FCACF #x7243 -#x8FCAD0 #x7245 -#x8FCAD1 #x724E -#x8FCAD2 #x724F -#x8FCAD3 #x7250 -#x8FCAD4 #x7253 -#x8FCAD5 #x7255 -#x8FCAD6 #x7256 -#x8FCAD7 #x725A -#x8FCAD8 #x725C -#x8FCAD9 #x725E -#x8FCADA #x7260 -#x8FCADB #x7263 -#x8FCADC #x7268 -#x8FCADD #x726B -#x8FCADE #x726E -#x8FCADF #x726F -#x8FCAE0 #x7271 -#x8FCAE1 #x7277 -#x8FCAE2 #x7278 -#x8FCAE3 #x727B -#x8FCAE4 #x727C -#x8FCAE5 #x727F -#x8FCAE6 #x7284 -#x8FCAE7 #x7289 -#x8FCAE8 #x728D -#x8FCAE9 #x728E -#x8FCAEA #x7293 -#x8FCAEB #x729B -#x8FCAEC #x72A8 -#x8FCAED #x72AD -#x8FCAEE #x72AE -#x8FCAEF #x72B1 -#x8FCAF0 #x72B4 -#x8FCAF1 #x72BE -#x8FCAF2 #x72C1 -#x8FCAF3 #x72C7 -#x8FCAF4 #x72C9 -#x8FCAF5 #x72CC -#x8FCAF6 #x72D5 -#x8FCAF7 #x72D6 -#x8FCAF8 #x72D8 -#x8FCAF9 #x72DF -#x8FCAFA #x72E5 -#x8FCAFB #x72F3 -#x8FCAFC #x72F4 -#x8FCAFD #x72FA -#x8FCAFE #x72FB -#x8FCBA1 #x72FE -#x8FCBA2 #x7302 -#x8FCBA3 #x7304 -#x8FCBA4 #x7305 -#x8FCBA5 #x7307 -#x8FCBA6 #x730B -#x8FCBA7 #x730D -#x8FCBA8 #x7312 -#x8FCBA9 #x7313 -#x8FCBAA #x7318 -#x8FCBAB #x7319 -#x8FCBAC #x731E -#x8FCBAD #x7322 -#x8FCBAE #x7324 -#x8FCBAF #x7327 -#x8FCBB0 #x7328 -#x8FCBB1 #x732C -#x8FCBB2 #x7331 -#x8FCBB3 #x7332 -#x8FCBB4 #x7335 -#x8FCBB5 #x733A -#x8FCBB6 #x733B -#x8FCBB7 #x733D -#x8FCBB8 #x7343 -#x8FCBB9 #x734D -#x8FCBBA #x7350 -#x8FCBBB #x7352 -#x8FCBBC #x7356 -#x8FCBBD #x7358 -#x8FCBBE #x735D -#x8FCBBF #x735E -#x8FCBC0 #x735F -#x8FCBC1 #x7360 -#x8FCBC2 #x7366 -#x8FCBC3 #x7367 -#x8FCBC4 #x7369 -#x8FCBC5 #x736B -#x8FCBC6 #x736C -#x8FCBC7 #x736E -#x8FCBC8 #x736F -#x8FCBC9 #x7371 -#x8FCBCA #x7377 -#x8FCBCB #x7379 -#x8FCBCC #x737C -#x8FCBCD #x7380 -#x8FCBCE #x7381 -#x8FCBCF #x7383 -#x8FCBD0 #x7385 -#x8FCBD1 #x7386 -#x8FCBD2 #x738E -#x8FCBD3 #x7390 -#x8FCBD4 #x7393 -#x8FCBD5 #x7395 -#x8FCBD6 #x7397 -#x8FCBD7 #x7398 -#x8FCBD8 #x739C -#x8FCBD9 #x739E -#x8FCBDA #x739F -#x8FCBDB #x73A0 -#x8FCBDC #x73A2 -#x8FCBDD #x73A5 -#x8FCBDE #x73A6 -#x8FCBDF #x73AA -#x8FCBE0 #x73AB -#x8FCBE1 #x73AD -#x8FCBE2 #x73B5 -#x8FCBE3 #x73B7 -#x8FCBE4 #x73B9 -#x8FCBE5 #x73BC -#x8FCBE6 #x73BD -#x8FCBE7 #x73BF -#x8FCBE8 #x73C5 -#x8FCBE9 #x73C6 -#x8FCBEA #x73C9 -#x8FCBEB #x73CB -#x8FCBEC #x73CC -#x8FCBED #x73CF -#x8FCBEE #x73D2 -#x8FCBEF #x73D3 -#x8FCBF0 #x73D6 -#x8FCBF1 #x73D9 -#x8FCBF2 #x73DD -#x8FCBF3 #x73E1 -#x8FCBF4 #x73E3 -#x8FCBF5 #x73E6 -#x8FCBF6 #x73E7 -#x8FCBF7 #x73E9 -#x8FCBF8 #x73F4 -#x8FCBF9 #x73F5 -#x8FCBFA #x73F7 -#x8FCBFB #x73F9 -#x8FCBFC #x73FA -#x8FCBFD #x73FB -#x8FCBFE #x73FD -#x8FCCA1 #x73FF -#x8FCCA2 #x7400 -#x8FCCA3 #x7401 -#x8FCCA4 #x7404 -#x8FCCA5 #x7407 -#x8FCCA6 #x740A -#x8FCCA7 #x7411 -#x8FCCA8 #x741A -#x8FCCA9 #x741B -#x8FCCAA #x7424 -#x8FCCAB #x7426 -#x8FCCAC #x7428 -#x8FCCAD #x7429 -#x8FCCAE #x742A -#x8FCCAF #x742B -#x8FCCB0 #x742C -#x8FCCB1 #x742D -#x8FCCB2 #x742E -#x8FCCB3 #x742F -#x8FCCB4 #x7430 -#x8FCCB5 #x7431 -#x8FCCB6 #x7439 -#x8FCCB7 #x7440 -#x8FCCB8 #x7443 -#x8FCCB9 #x7444 -#x8FCCBA #x7446 -#x8FCCBB #x7447 -#x8FCCBC #x744B -#x8FCCBD #x744D -#x8FCCBE #x7451 -#x8FCCBF #x7452 -#x8FCCC0 #x7457 -#x8FCCC1 #x745D -#x8FCCC2 #x7462 -#x8FCCC3 #x7466 -#x8FCCC4 #x7467 -#x8FCCC5 #x7468 -#x8FCCC6 #x746B -#x8FCCC7 #x746D -#x8FCCC8 #x746E -#x8FCCC9 #x7471 -#x8FCCCA #x7472 -#x8FCCCB #x7480 -#x8FCCCC #x7481 -#x8FCCCD #x7485 -#x8FCCCE #x7486 -#x8FCCCF #x7487 -#x8FCCD0 #x7489 -#x8FCCD1 #x748F -#x8FCCD2 #x7490 -#x8FCCD3 #x7491 -#x8FCCD4 #x7492 -#x8FCCD5 #x7498 -#x8FCCD6 #x7499 -#x8FCCD7 #x749A -#x8FCCD8 #x749C -#x8FCCD9 #x749F -#x8FCCDA #x74A0 -#x8FCCDB #x74A1 -#x8FCCDC #x74A3 -#x8FCCDD #x74A6 -#x8FCCDE #x74A8 -#x8FCCDF #x74A9 -#x8FCCE0 #x74AA -#x8FCCE1 #x74AB -#x8FCCE2 #x74AE -#x8FCCE3 #x74AF -#x8FCCE4 #x74B1 -#x8FCCE5 #x74B2 -#x8FCCE6 #x74B5 -#x8FCCE7 #x74B9 -#x8FCCE8 #x74BB -#x8FCCE9 #x74BF -#x8FCCEA #x74C8 -#x8FCCEB #x74C9 -#x8FCCEC #x74CC -#x8FCCED #x74D0 -#x8FCCEE #x74D3 -#x8FCCEF #x74D8 -#x8FCCF0 #x74DA -#x8FCCF1 #x74DB -#x8FCCF2 #x74DE -#x8FCCF3 #x74DF -#x8FCCF4 #x74E4 -#x8FCCF5 #x74E8 -#x8FCCF6 #x74EA -#x8FCCF7 #x74EB -#x8FCCF8 #x74EF -#x8FCCF9 #x74F4 -#x8FCCFA #x74FA -#x8FCCFB #x74FB -#x8FCCFC #x74FC -#x8FCCFD #x74FF -#x8FCCFE #x7506 -#x8FCDA1 #x7512 -#x8FCDA2 #x7516 -#x8FCDA3 #x7517 -#x8FCDA4 #x7520 -#x8FCDA5 #x7521 -#x8FCDA6 #x7524 -#x8FCDA7 #x7527 -#x8FCDA8 #x7529 -#x8FCDA9 #x752A -#x8FCDAA #x752F -#x8FCDAB #x7536 -#x8FCDAC #x7539 -#x8FCDAD #x753D -#x8FCDAE #x753E -#x8FCDAF #x753F -#x8FCDB0 #x7540 -#x8FCDB1 #x7543 -#x8FCDB2 #x7547 -#x8FCDB3 #x7548 -#x8FCDB4 #x754E -#x8FCDB5 #x7550 -#x8FCDB6 #x7552 -#x8FCDB7 #x7557 -#x8FCDB8 #x755E -#x8FCDB9 #x755F -#x8FCDBA #x7561 -#x8FCDBB #x756F -#x8FCDBC #x7571 -#x8FCDBD #x7579 -#x8FCDBE #x757A -#x8FCDBF #x757B -#x8FCDC0 #x757C -#x8FCDC1 #x757D -#x8FCDC2 #x757E -#x8FCDC3 #x7581 -#x8FCDC4 #x7585 -#x8FCDC5 #x7590 -#x8FCDC6 #x7592 -#x8FCDC7 #x7593 -#x8FCDC8 #x7595 -#x8FCDC9 #x7599 -#x8FCDCA #x759C -#x8FCDCB #x75A2 -#x8FCDCC #x75A4 -#x8FCDCD #x75B4 -#x8FCDCE #x75BA -#x8FCDCF #x75BF -#x8FCDD0 #x75C0 -#x8FCDD1 #x75C1 -#x8FCDD2 #x75C4 -#x8FCDD3 #x75C6 -#x8FCDD4 #x75CC -#x8FCDD5 #x75CE -#x8FCDD6 #x75CF -#x8FCDD7 #x75D7 -#x8FCDD8 #x75DC -#x8FCDD9 #x75DF -#x8FCDDA #x75E0 -#x8FCDDB #x75E1 -#x8FCDDC #x75E4 -#x8FCDDD #x75E7 -#x8FCDDE #x75EC -#x8FCDDF #x75EE -#x8FCDE0 #x75EF -#x8FCDE1 #x75F1 -#x8FCDE2 #x75F9 -#x8FCDE3 #x7600 -#x8FCDE4 #x7602 -#x8FCDE5 #x7603 -#x8FCDE6 #x7604 -#x8FCDE7 #x7607 -#x8FCDE8 #x7608 -#x8FCDE9 #x760A -#x8FCDEA #x760C -#x8FCDEB #x760F -#x8FCDEC #x7612 -#x8FCDED #x7613 -#x8FCDEE #x7615 -#x8FCDEF #x7616 -#x8FCDF0 #x7619 -#x8FCDF1 #x761B -#x8FCDF2 #x761C -#x8FCDF3 #x761D -#x8FCDF4 #x761E -#x8FCDF5 #x7623 -#x8FCDF6 #x7625 -#x8FCDF7 #x7626 -#x8FCDF8 #x7629 -#x8FCDF9 #x762D -#x8FCDFA #x7632 -#x8FCDFB #x7633 -#x8FCDFC #x7635 -#x8FCDFD #x7638 -#x8FCDFE #x7639 -#x8FCEA1 #x763A -#x8FCEA2 #x763C -#x8FCEA3 #x764A -#x8FCEA4 #x7640 -#x8FCEA5 #x7641 -#x8FCEA6 #x7643 -#x8FCEA7 #x7644 -#x8FCEA8 #x7645 -#x8FCEA9 #x7649 -#x8FCEAA #x764B -#x8FCEAB #x7655 -#x8FCEAC #x7659 -#x8FCEAD #x765F -#x8FCEAE #x7664 -#x8FCEAF #x7665 -#x8FCEB0 #x766D -#x8FCEB1 #x766E -#x8FCEB2 #x766F -#x8FCEB3 #x7671 -#x8FCEB4 #x7674 -#x8FCEB5 #x7681 -#x8FCEB6 #x7685 -#x8FCEB7 #x768C -#x8FCEB8 #x768D -#x8FCEB9 #x7695 -#x8FCEBA #x769B -#x8FCEBB #x769C -#x8FCEBC #x769D -#x8FCEBD #x769F -#x8FCEBE #x76A0 -#x8FCEBF #x76A2 -#x8FCEC0 #x76A3 -#x8FCEC1 #x76A4 -#x8FCEC2 #x76A5 -#x8FCEC3 #x76A6 -#x8FCEC4 #x76A7 -#x8FCEC5 #x76A8 -#x8FCEC6 #x76AA -#x8FCEC7 #x76AD -#x8FCEC8 #x76BD -#x8FCEC9 #x76C1 -#x8FCECA #x76C5 -#x8FCECB #x76C9 -#x8FCECC #x76CB -#x8FCECD #x76CC -#x8FCECE #x76CE -#x8FCECF #x76D4 -#x8FCED0 #x76D9 -#x8FCED1 #x76E0 -#x8FCED2 #x76E6 -#x8FCED3 #x76E8 -#x8FCED4 #x76EC -#x8FCED5 #x76F0 -#x8FCED6 #x76F1 -#x8FCED7 #x76F6 -#x8FCED8 #x76F9 -#x8FCED9 #x76FC -#x8FCEDA #x7700 -#x8FCEDB #x7706 -#x8FCEDC #x770A -#x8FCEDD #x770E -#x8FCEDE #x7712 -#x8FCEDF #x7714 -#x8FCEE0 #x7715 -#x8FCEE1 #x7717 -#x8FCEE2 #x7719 -#x8FCEE3 #x771A -#x8FCEE4 #x771C -#x8FCEE5 #x7722 -#x8FCEE6 #x7728 -#x8FCEE7 #x772D -#x8FCEE8 #x772E -#x8FCEE9 #x772F -#x8FCEEA #x7734 -#x8FCEEB #x7735 -#x8FCEEC #x7736 -#x8FCEED #x7739 -#x8FCEEE #x773D -#x8FCEEF #x773E -#x8FCEF0 #x7742 -#x8FCEF1 #x7745 -#x8FCEF2 #x7746 -#x8FCEF3 #x774A -#x8FCEF4 #x774D -#x8FCEF5 #x774E -#x8FCEF6 #x774F -#x8FCEF7 #x7752 -#x8FCEF8 #x7756 -#x8FCEF9 #x7757 -#x8FCEFA #x775C -#x8FCEFB #x775E -#x8FCEFC #x775F -#x8FCEFD #x7760 -#x8FCEFE #x7762 -#x8FCFA1 #x7764 -#x8FCFA2 #x7767 -#x8FCFA3 #x776A -#x8FCFA4 #x776C -#x8FCFA5 #x7770 -#x8FCFA6 #x7772 -#x8FCFA7 #x7773 -#x8FCFA8 #x7774 -#x8FCFA9 #x777A -#x8FCFAA #x777D -#x8FCFAB #x7780 -#x8FCFAC #x7784 -#x8FCFAD #x778C -#x8FCFAE #x778D -#x8FCFAF #x7794 -#x8FCFB0 #x7795 -#x8FCFB1 #x7796 -#x8FCFB2 #x779A -#x8FCFB3 #x779F -#x8FCFB4 #x77A2 -#x8FCFB5 #x77A7 -#x8FCFB6 #x77AA -#x8FCFB7 #x77AE -#x8FCFB8 #x77AF -#x8FCFB9 #x77B1 -#x8FCFBA #x77B5 -#x8FCFBB #x77BE -#x8FCFBC #x77C3 -#x8FCFBD #x77C9 -#x8FCFBE #x77D1 -#x8FCFBF #x77D2 -#x8FCFC0 #x77D5 -#x8FCFC1 #x77D9 -#x8FCFC2 #x77DE -#x8FCFC3 #x77DF -#x8FCFC4 #x77E0 -#x8FCFC5 #x77E4 -#x8FCFC6 #x77E6 -#x8FCFC7 #x77EA -#x8FCFC8 #x77EC -#x8FCFC9 #x77F0 -#x8FCFCA #x77F1 -#x8FCFCB #x77F4 -#x8FCFCC #x77F8 -#x8FCFCD #x77FB -#x8FCFCE #x7805 -#x8FCFCF #x7806 -#x8FCFD0 #x7809 -#x8FCFD1 #x780D -#x8FCFD2 #x780E -#x8FCFD3 #x7811 -#x8FCFD4 #x781D -#x8FCFD5 #x7821 -#x8FCFD6 #x7822 -#x8FCFD7 #x7823 -#x8FCFD8 #x782D -#x8FCFD9 #x782E -#x8FCFDA #x7830 -#x8FCFDB #x7835 -#x8FCFDC #x7837 -#x8FCFDD #x7843 -#x8FCFDE #x7844 -#x8FCFDF #x7847 -#x8FCFE0 #x7848 -#x8FCFE1 #x784C -#x8FCFE2 #x784E -#x8FCFE3 #x7852 -#x8FCFE4 #x785C -#x8FCFE5 #x785E -#x8FCFE6 #x7860 -#x8FCFE7 #x7861 -#x8FCFE8 #x7863 -#x8FCFE9 #x7864 -#x8FCFEA #x7868 -#x8FCFEB #x786A -#x8FCFEC #x786E -#x8FCFED #x787A -#x8FCFEE #x787E -#x8FCFEF #x788A -#x8FCFF0 #x788F -#x8FCFF1 #x7894 -#x8FCFF2 #x7898 -#x8FCFF3 #x78A1 -#x8FCFF4 #x789D -#x8FCFF5 #x789E -#x8FCFF6 #x789F -#x8FCFF7 #x78A4 -#x8FCFF8 #x78A8 -#x8FCFF9 #x78AC -#x8FCFFA #x78AD -#x8FCFFB #x78B0 -#x8FCFFC #x78B1 -#x8FCFFD #x78B2 -#x8FCFFE #x78B3 -#x8FD0A1 #x78BB -#x8FD0A2 #x78BD -#x8FD0A3 #x78BF -#x8FD0A4 #x78C7 -#x8FD0A5 #x78C8 -#x8FD0A6 #x78C9 -#x8FD0A7 #x78CC -#x8FD0A8 #x78CE -#x8FD0A9 #x78D2 -#x8FD0AA #x78D3 -#x8FD0AB #x78D5 -#x8FD0AC #x78D6 -#x8FD0AD #x78E4 -#x8FD0AE #x78DB -#x8FD0AF #x78DF -#x8FD0B0 #x78E0 -#x8FD0B1 #x78E1 -#x8FD0B2 #x78E6 -#x8FD0B3 #x78EA -#x8FD0B4 #x78F2 -#x8FD0B5 #x78F3 -#x8FD0B6 #x7900 -#x8FD0B7 #x78F6 -#x8FD0B8 #x78F7 -#x8FD0B9 #x78FA -#x8FD0BA #x78FB -#x8FD0BB #x78FF -#x8FD0BC #x7906 -#x8FD0BD #x790C -#x8FD0BE #x7910 -#x8FD0BF #x791A -#x8FD0C0 #x791C -#x8FD0C1 #x791E -#x8FD0C2 #x791F -#x8FD0C3 #x7920 -#x8FD0C4 #x7925 -#x8FD0C5 #x7927 -#x8FD0C6 #x7929 -#x8FD0C7 #x792D -#x8FD0C8 #x7931 -#x8FD0C9 #x7934 -#x8FD0CA #x7935 -#x8FD0CB #x793B -#x8FD0CC #x793D -#x8FD0CD #x793F -#x8FD0CE #x7944 -#x8FD0CF #x7945 -#x8FD0D0 #x7946 -#x8FD0D1 #x794A -#x8FD0D2 #x794B -#x8FD0D3 #x794F -#x8FD0D4 #x7951 -#x8FD0D5 #x7954 -#x8FD0D6 #x7958 -#x8FD0D7 #x795B -#x8FD0D8 #x795C -#x8FD0D9 #x7967 -#x8FD0DA #x7969 -#x8FD0DB #x796B -#x8FD0DC #x7972 -#x8FD0DD #x7979 -#x8FD0DE #x797B -#x8FD0DF #x797C -#x8FD0E0 #x797E -#x8FD0E1 #x798B -#x8FD0E2 #x798C -#x8FD0E3 #x7991 -#x8FD0E4 #x7993 -#x8FD0E5 #x7994 -#x8FD0E6 #x7995 -#x8FD0E7 #x7996 -#x8FD0E8 #x7998 -#x8FD0E9 #x799B -#x8FD0EA #x799C -#x8FD0EB #x79A1 -#x8FD0EC #x79A8 -#x8FD0ED #x79A9 -#x8FD0EE #x79AB -#x8FD0EF #x79AF -#x8FD0F0 #x79B1 -#x8FD0F1 #x79B4 -#x8FD0F2 #x79B8 -#x8FD0F3 #x79BB -#x8FD0F4 #x79C2 -#x8FD0F5 #x79C4 -#x8FD0F6 #x79C7 -#x8FD0F7 #x79C8 -#x8FD0F8 #x79CA -#x8FD0F9 #x79CF -#x8FD0FA #x79D4 -#x8FD0FB #x79D6 -#x8FD0FC #x79DA -#x8FD0FD #x79DD -#x8FD0FE #x79DE -#x8FD1A1 #x79E0 -#x8FD1A2 #x79E2 -#x8FD1A3 #x79E5 -#x8FD1A4 #x79EA -#x8FD1A5 #x79EB -#x8FD1A6 #x79ED -#x8FD1A7 #x79F1 -#x8FD1A8 #x79F8 -#x8FD1A9 #x79FC -#x8FD1AA #x7A02 -#x8FD1AB #x7A03 -#x8FD1AC #x7A07 -#x8FD1AD #x7A09 -#x8FD1AE #x7A0A -#x8FD1AF #x7A0C -#x8FD1B0 #x7A11 -#x8FD1B1 #x7A15 -#x8FD1B2 #x7A1B -#x8FD1B3 #x7A1E -#x8FD1B4 #x7A21 -#x8FD1B5 #x7A27 -#x8FD1B6 #x7A2B -#x8FD1B7 #x7A2D -#x8FD1B8 #x7A2F -#x8FD1B9 #x7A30 -#x8FD1BA #x7A34 -#x8FD1BB #x7A35 -#x8FD1BC #x7A38 -#x8FD1BD #x7A39 -#x8FD1BE #x7A3A -#x8FD1BF #x7A44 -#x8FD1C0 #x7A45 -#x8FD1C1 #x7A47 -#x8FD1C2 #x7A48 -#x8FD1C3 #x7A4C -#x8FD1C4 #x7A55 -#x8FD1C5 #x7A56 -#x8FD1C6 #x7A59 -#x8FD1C7 #x7A5C -#x8FD1C8 #x7A5D -#x8FD1C9 #x7A5F -#x8FD1CA #x7A60 -#x8FD1CB #x7A65 -#x8FD1CC #x7A67 -#x8FD1CD #x7A6A -#x8FD1CE #x7A6D -#x8FD1CF #x7A75 -#x8FD1D0 #x7A78 -#x8FD1D1 #x7A7E -#x8FD1D2 #x7A80 -#x8FD1D3 #x7A82 -#x8FD1D4 #x7A85 -#x8FD1D5 #x7A86 -#x8FD1D6 #x7A8A -#x8FD1D7 #x7A8B -#x8FD1D8 #x7A90 -#x8FD1D9 #x7A91 -#x8FD1DA #x7A94 -#x8FD1DB #x7A9E -#x8FD1DC #x7AA0 -#x8FD1DD #x7AA3 -#x8FD1DE #x7AAC -#x8FD1DF #x7AB3 -#x8FD1E0 #x7AB5 -#x8FD1E1 #x7AB9 -#x8FD1E2 #x7ABB -#x8FD1E3 #x7ABC -#x8FD1E4 #x7AC6 -#x8FD1E5 #x7AC9 -#x8FD1E6 #x7ACC -#x8FD1E7 #x7ACE -#x8FD1E8 #x7AD1 -#x8FD1E9 #x7ADB -#x8FD1EA #x7AE8 -#x8FD1EB #x7AE9 -#x8FD1EC #x7AEB -#x8FD1ED #x7AEC -#x8FD1EE #x7AF1 -#x8FD1EF #x7AF4 -#x8FD1F0 #x7AFB -#x8FD1F1 #x7AFD -#x8FD1F2 #x7AFE -#x8FD1F3 #x7B07 -#x8FD1F4 #x7B14 -#x8FD1F5 #x7B1F -#x8FD1F6 #x7B23 -#x8FD1F7 #x7B27 -#x8FD1F8 #x7B29 -#x8FD1F9 #x7B2A -#x8FD1FA #x7B2B -#x8FD1FB #x7B2D -#x8FD1FC #x7B2E -#x8FD1FD #x7B2F -#x8FD1FE #x7B30 -#x8FD2A1 #x7B31 -#x8FD2A2 #x7B34 -#x8FD2A3 #x7B3D -#x8FD2A4 #x7B3F -#x8FD2A5 #x7B40 -#x8FD2A6 #x7B41 -#x8FD2A7 #x7B47 -#x8FD2A8 #x7B4E -#x8FD2A9 #x7B55 -#x8FD2AA #x7B60 -#x8FD2AB #x7B64 -#x8FD2AC #x7B66 -#x8FD2AD #x7B69 -#x8FD2AE #x7B6A -#x8FD2AF #x7B6D -#x8FD2B0 #x7B6F -#x8FD2B1 #x7B72 -#x8FD2B2 #x7B73 -#x8FD2B3 #x7B77 -#x8FD2B4 #x7B84 -#x8FD2B5 #x7B89 -#x8FD2B6 #x7B8E -#x8FD2B7 #x7B90 -#x8FD2B8 #x7B91 -#x8FD2B9 #x7B96 -#x8FD2BA #x7B9B -#x8FD2BB #x7B9E -#x8FD2BC #x7BA0 -#x8FD2BD #x7BA5 -#x8FD2BE #x7BAC -#x8FD2BF #x7BAF -#x8FD2C0 #x7BB0 -#x8FD2C1 #x7BB2 -#x8FD2C2 #x7BB5 -#x8FD2C3 #x7BB6 -#x8FD2C4 #x7BBA -#x8FD2C5 #x7BBB -#x8FD2C6 #x7BBC -#x8FD2C7 #x7BBD -#x8FD2C8 #x7BC2 -#x8FD2C9 #x7BC5 -#x8FD2CA #x7BC8 -#x8FD2CB #x7BCA -#x8FD2CC #x7BD4 -#x8FD2CD #x7BD6 -#x8FD2CE #x7BD7 -#x8FD2CF #x7BD9 -#x8FD2D0 #x7BDA -#x8FD2D1 #x7BDB -#x8FD2D2 #x7BE8 -#x8FD2D3 #x7BEA -#x8FD2D4 #x7BF2 -#x8FD2D5 #x7BF4 -#x8FD2D6 #x7BF5 -#x8FD2D7 #x7BF8 -#x8FD2D8 #x7BF9 -#x8FD2D9 #x7BFA -#x8FD2DA #x7BFC -#x8FD2DB #x7BFE -#x8FD2DC #x7C01 -#x8FD2DD #x7C02 -#x8FD2DE #x7C03 -#x8FD2DF #x7C04 -#x8FD2E0 #x7C06 -#x8FD2E1 #x7C09 -#x8FD2E2 #x7C0B -#x8FD2E3 #x7C0C -#x8FD2E4 #x7C0E -#x8FD2E5 #x7C0F -#x8FD2E6 #x7C19 -#x8FD2E7 #x7C1B -#x8FD2E8 #x7C20 -#x8FD2E9 #x7C25 -#x8FD2EA #x7C26 -#x8FD2EB #x7C28 -#x8FD2EC #x7C2C -#x8FD2ED #x7C31 -#x8FD2EE #x7C33 -#x8FD2EF #x7C34 -#x8FD2F0 #x7C36 -#x8FD2F1 #x7C39 -#x8FD2F2 #x7C3A -#x8FD2F3 #x7C46 -#x8FD2F4 #x7C4A -#x8FD2F5 #x7C55 -#x8FD2F6 #x7C51 -#x8FD2F7 #x7C52 -#x8FD2F8 #x7C53 -#x8FD2F9 #x7C59 -#x8FD2FA #x7C5A -#x8FD2FB #x7C5B -#x8FD2FC #x7C5C -#x8FD2FD #x7C5D -#x8FD2FE #x7C5E -#x8FD3A1 #x7C61 -#x8FD3A2 #x7C63 -#x8FD3A3 #x7C67 -#x8FD3A4 #x7C69 -#x8FD3A5 #x7C6D -#x8FD3A6 #x7C6E -#x8FD3A7 #x7C70 -#x8FD3A8 #x7C72 -#x8FD3A9 #x7C79 -#x8FD3AA #x7C7C -#x8FD3AB #x7C7D -#x8FD3AC #x7C86 -#x8FD3AD #x7C87 -#x8FD3AE #x7C8F -#x8FD3AF #x7C94 -#x8FD3B0 #x7C9E -#x8FD3B1 #x7CA0 -#x8FD3B2 #x7CA6 -#x8FD3B3 #x7CB0 -#x8FD3B4 #x7CB6 -#x8FD3B5 #x7CB7 -#x8FD3B6 #x7CBA -#x8FD3B7 #x7CBB -#x8FD3B8 #x7CBC -#x8FD3B9 #x7CBF -#x8FD3BA #x7CC4 -#x8FD3BB #x7CC7 -#x8FD3BC #x7CC8 -#x8FD3BD #x7CC9 -#x8FD3BE #x7CCD -#x8FD3BF #x7CCF -#x8FD3C0 #x7CD3 -#x8FD3C1 #x7CD4 -#x8FD3C2 #x7CD5 -#x8FD3C3 #x7CD7 -#x8FD3C4 #x7CD9 -#x8FD3C5 #x7CDA -#x8FD3C6 #x7CDD -#x8FD3C7 #x7CE6 -#x8FD3C8 #x7CE9 -#x8FD3C9 #x7CEB -#x8FD3CA #x7CF5 -#x8FD3CB #x7D03 -#x8FD3CC #x7D07 -#x8FD3CD #x7D08 -#x8FD3CE #x7D09 -#x8FD3CF #x7D0F -#x8FD3D0 #x7D11 -#x8FD3D1 #x7D12 -#x8FD3D2 #x7D13 -#x8FD3D3 #x7D16 -#x8FD3D4 #x7D1D -#x8FD3D5 #x7D1E -#x8FD3D6 #x7D23 -#x8FD3D7 #x7D26 -#x8FD3D8 #x7D2A -#x8FD3D9 #x7D2D -#x8FD3DA #x7D31 -#x8FD3DB #x7D3C -#x8FD3DC #x7D3D -#x8FD3DD #x7D3E -#x8FD3DE #x7D40 -#x8FD3DF #x7D41 -#x8FD3E0 #x7D47 -#x8FD3E1 #x7D48 -#x8FD3E2 #x7D4D -#x8FD3E3 #x7D51 -#x8FD3E4 #x7D53 -#x8FD3E5 #x7D57 -#x8FD3E6 #x7D59 -#x8FD3E7 #x7D5A -#x8FD3E8 #x7D5C -#x8FD3E9 #x7D5D -#x8FD3EA #x7D65 -#x8FD3EB #x7D67 -#x8FD3EC #x7D6A -#x8FD3ED #x7D70 -#x8FD3EE #x7D78 -#x8FD3EF #x7D7A -#x8FD3F0 #x7D7B -#x8FD3F1 #x7D7F -#x8FD3F2 #x7D81 -#x8FD3F3 #x7D82 -#x8FD3F4 #x7D83 -#x8FD3F5 #x7D85 -#x8FD3F6 #x7D86 -#x8FD3F7 #x7D88 -#x8FD3F8 #x7D8B -#x8FD3F9 #x7D8C -#x8FD3FA #x7D8D -#x8FD3FB #x7D91 -#x8FD3FC #x7D96 -#x8FD3FD #x7D97 -#x8FD3FE #x7D9D -#x8FD4A1 #x7D9E -#x8FD4A2 #x7DA6 -#x8FD4A3 #x7DA7 -#x8FD4A4 #x7DAA -#x8FD4A5 #x7DB3 -#x8FD4A6 #x7DB6 -#x8FD4A7 #x7DB7 -#x8FD4A8 #x7DB9 -#x8FD4A9 #x7DC2 -#x8FD4AA #x7DC3 -#x8FD4AB #x7DC4 -#x8FD4AC #x7DC5 -#x8FD4AD #x7DC6 -#x8FD4AE #x7DCC -#x8FD4AF #x7DCD -#x8FD4B0 #x7DCE -#x8FD4B1 #x7DD7 -#x8FD4B2 #x7DD9 -#x8FD4B3 #x7E00 -#x8FD4B4 #x7DE2 -#x8FD4B5 #x7DE5 -#x8FD4B6 #x7DE6 -#x8FD4B7 #x7DEA -#x8FD4B8 #x7DEB -#x8FD4B9 #x7DED -#x8FD4BA #x7DF1 -#x8FD4BB #x7DF5 -#x8FD4BC #x7DF6 -#x8FD4BD #x7DF9 -#x8FD4BE #x7DFA -#x8FD4BF #x7E08 -#x8FD4C0 #x7E10 -#x8FD4C1 #x7E11 -#x8FD4C2 #x7E15 -#x8FD4C3 #x7E17 -#x8FD4C4 #x7E1C -#x8FD4C5 #x7E1D -#x8FD4C6 #x7E20 -#x8FD4C7 #x7E27 -#x8FD4C8 #x7E28 -#x8FD4C9 #x7E2C -#x8FD4CA #x7E2D -#x8FD4CB #x7E2F -#x8FD4CC #x7E33 -#x8FD4CD #x7E36 -#x8FD4CE #x7E3F -#x8FD4CF #x7E44 -#x8FD4D0 #x7E45 -#x8FD4D1 #x7E47 -#x8FD4D2 #x7E4E -#x8FD4D3 #x7E50 -#x8FD4D4 #x7E52 -#x8FD4D5 #x7E58 -#x8FD4D6 #x7E5F -#x8FD4D7 #x7E61 -#x8FD4D8 #x7E62 -#x8FD4D9 #x7E65 -#x8FD4DA #x7E6B -#x8FD4DB #x7E6E -#x8FD4DC #x7E6F -#x8FD4DD #x7E73 -#x8FD4DE #x7E78 -#x8FD4DF #x7E7E -#x8FD4E0 #x7E81 -#x8FD4E1 #x7E86 -#x8FD4E2 #x7E87 -#x8FD4E3 #x7E8A -#x8FD4E4 #x7E8D -#x8FD4E5 #x7E91 -#x8FD4E6 #x7E95 -#x8FD4E7 #x7E98 -#x8FD4E8 #x7E9A -#x8FD4E9 #x7E9D -#x8FD4EA #x7E9E -#x8FD4EB #x7F3C -#x8FD4EC #x7F3B -#x8FD4ED #x7F3D -#x8FD4EE #x7F3E -#x8FD4EF #x7F3F -#x8FD4F0 #x7F43 -#x8FD4F1 #x7F44 -#x8FD4F2 #x7F47 -#x8FD4F3 #x7F4F -#x8FD4F4 #x7F52 -#x8FD4F5 #x7F53 -#x8FD4F6 #x7F5B -#x8FD4F7 #x7F5C -#x8FD4F8 #x7F5D -#x8FD4F9 #x7F61 -#x8FD4FA #x7F63 -#x8FD4FB #x7F64 -#x8FD4FC #x7F65 -#x8FD4FD #x7F66 -#x8FD4FE #x7F6D -#x8FD5A1 #x7F71 -#x8FD5A2 #x7F7D -#x8FD5A3 #x7F7E -#x8FD5A4 #x7F7F -#x8FD5A5 #x7F80 -#x8FD5A6 #x7F8B -#x8FD5A7 #x7F8D -#x8FD5A8 #x7F8F -#x8FD5A9 #x7F90 -#x8FD5AA #x7F91 -#x8FD5AB #x7F96 -#x8FD5AC #x7F97 -#x8FD5AD #x7F9C -#x8FD5AE #x7FA1 -#x8FD5AF #x7FA2 -#x8FD5B0 #x7FA6 -#x8FD5B1 #x7FAA -#x8FD5B2 #x7FAD -#x8FD5B3 #x7FB4 -#x8FD5B4 #x7FBC -#x8FD5B5 #x7FBF -#x8FD5B6 #x7FC0 -#x8FD5B7 #x7FC3 -#x8FD5B8 #x7FC8 -#x8FD5B9 #x7FCE -#x8FD5BA #x7FCF -#x8FD5BB #x7FDB -#x8FD5BC #x7FDF -#x8FD5BD #x7FE3 -#x8FD5BE #x7FE5 -#x8FD5BF #x7FE8 -#x8FD5C0 #x7FEC -#x8FD5C1 #x7FEE -#x8FD5C2 #x7FEF -#x8FD5C3 #x7FF2 -#x8FD5C4 #x7FFA -#x8FD5C5 #x7FFD -#x8FD5C6 #x7FFE -#x8FD5C7 #x7FFF -#x8FD5C8 #x8007 -#x8FD5C9 #x8008 -#x8FD5CA #x800A -#x8FD5CB #x800D -#x8FD5CC #x800E -#x8FD5CD #x800F -#x8FD5CE #x8011 -#x8FD5CF #x8013 -#x8FD5D0 #x8014 -#x8FD5D1 #x8016 -#x8FD5D2 #x801D -#x8FD5D3 #x801E -#x8FD5D4 #x801F -#x8FD5D5 #x8020 -#x8FD5D6 #x8024 -#x8FD5D7 #x8026 -#x8FD5D8 #x802C -#x8FD5D9 #x802E -#x8FD5DA #x8030 -#x8FD5DB #x8034 -#x8FD5DC #x8035 -#x8FD5DD #x8037 -#x8FD5DE #x8039 -#x8FD5DF #x803A -#x8FD5E0 #x803C -#x8FD5E1 #x803E -#x8FD5E2 #x8040 -#x8FD5E3 #x8044 -#x8FD5E4 #x8060 -#x8FD5E5 #x8064 -#x8FD5E6 #x8066 -#x8FD5E7 #x806D -#x8FD5E8 #x8071 -#x8FD5E9 #x8075 -#x8FD5EA #x8081 -#x8FD5EB #x8088 -#x8FD5EC #x808E -#x8FD5ED #x809C -#x8FD5EE #x809E -#x8FD5EF #x80A6 -#x8FD5F0 #x80A7 -#x8FD5F1 #x80AB -#x8FD5F2 #x80B8 -#x8FD5F3 #x80B9 -#x8FD5F4 #x80C8 -#x8FD5F5 #x80CD -#x8FD5F6 #x80CF -#x8FD5F7 #x80D2 -#x8FD5F8 #x80D4 -#x8FD5F9 #x80D5 -#x8FD5FA #x80D7 -#x8FD5FB #x80D8 -#x8FD5FC #x80E0 -#x8FD5FD #x80ED -#x8FD5FE #x80EE -#x8FD6A1 #x80F0 -#x8FD6A2 #x80F2 -#x8FD6A3 #x80F3 -#x8FD6A4 #x80F6 -#x8FD6A5 #x80F9 -#x8FD6A6 #x80FA -#x8FD6A7 #x80FE -#x8FD6A8 #x8103 -#x8FD6A9 #x810B -#x8FD6AA #x8116 -#x8FD6AB #x8117 -#x8FD6AC #x8118 -#x8FD6AD #x811C -#x8FD6AE #x811E -#x8FD6AF #x8120 -#x8FD6B0 #x8124 -#x8FD6B1 #x8127 -#x8FD6B2 #x812C -#x8FD6B3 #x8130 -#x8FD6B4 #x8135 -#x8FD6B5 #x813A -#x8FD6B6 #x813C -#x8FD6B7 #x8145 -#x8FD6B8 #x8147 -#x8FD6B9 #x814A -#x8FD6BA #x814C -#x8FD6BB #x8152 -#x8FD6BC #x8157 -#x8FD6BD #x8160 -#x8FD6BE #x8161 -#x8FD6BF #x8167 -#x8FD6C0 #x8168 -#x8FD6C1 #x8169 -#x8FD6C2 #x816D -#x8FD6C3 #x816F -#x8FD6C4 #x8177 -#x8FD6C5 #x8181 -#x8FD6C6 #x8190 -#x8FD6C7 #x8184 -#x8FD6C8 #x8185 -#x8FD6C9 #x8186 -#x8FD6CA #x818B -#x8FD6CB #x818E -#x8FD6CC #x8196 -#x8FD6CD #x8198 -#x8FD6CE #x819B -#x8FD6CF #x819E -#x8FD6D0 #x81A2 -#x8FD6D1 #x81AE -#x8FD6D2 #x81B2 -#x8FD6D3 #x81B4 -#x8FD6D4 #x81BB -#x8FD6D5 #x81CB -#x8FD6D6 #x81C3 -#x8FD6D7 #x81C5 -#x8FD6D8 #x81CA -#x8FD6D9 #x81CE -#x8FD6DA #x81CF -#x8FD6DB #x81D5 -#x8FD6DC #x81D7 -#x8FD6DD #x81DB -#x8FD6DE #x81DD -#x8FD6DF #x81DE -#x8FD6E0 #x81E1 -#x8FD6E1 #x81E4 -#x8FD6E2 #x81EB -#x8FD6E3 #x81EC -#x8FD6E4 #x81F0 -#x8FD6E5 #x81F1 -#x8FD6E6 #x81F2 -#x8FD6E7 #x81F5 -#x8FD6E8 #x81F6 -#x8FD6E9 #x81F8 -#x8FD6EA #x81F9 -#x8FD6EB #x81FD -#x8FD6EC #x81FF -#x8FD6ED #x8200 -#x8FD6EE #x8203 -#x8FD6EF #x820F -#x8FD6F0 #x8213 -#x8FD6F1 #x8214 -#x8FD6F2 #x8219 -#x8FD6F3 #x821A -#x8FD6F4 #x821D -#x8FD6F5 #x8221 -#x8FD6F6 #x8222 -#x8FD6F7 #x8228 -#x8FD6F8 #x8232 -#x8FD6F9 #x8234 -#x8FD6FA #x823A -#x8FD6FB #x8243 -#x8FD6FC #x8244 -#x8FD6FD #x8245 -#x8FD6FE #x8246 -#x8FD7A1 #x824B -#x8FD7A2 #x824E -#x8FD7A3 #x824F -#x8FD7A4 #x8251 -#x8FD7A5 #x8256 -#x8FD7A6 #x825C -#x8FD7A7 #x8260 -#x8FD7A8 #x8263 -#x8FD7A9 #x8267 -#x8FD7AA #x826D -#x8FD7AB #x8274 -#x8FD7AC #x827B -#x8FD7AD #x827D -#x8FD7AE #x827F -#x8FD7AF #x8280 -#x8FD7B0 #x8281 -#x8FD7B1 #x8283 -#x8FD7B2 #x8284 -#x8FD7B3 #x8287 -#x8FD7B4 #x8289 -#x8FD7B5 #x828A -#x8FD7B6 #x828E -#x8FD7B7 #x8291 -#x8FD7B8 #x8294 -#x8FD7B9 #x8296 -#x8FD7BA #x8298 -#x8FD7BB #x829A -#x8FD7BC #x829B -#x8FD7BD #x82A0 -#x8FD7BE #x82A1 -#x8FD7BF #x82A3 -#x8FD7C0 #x82A4 -#x8FD7C1 #x82A7 -#x8FD7C2 #x82A8 -#x8FD7C3 #x82A9 -#x8FD7C4 #x82AA -#x8FD7C5 #x82AE -#x8FD7C6 #x82B0 -#x8FD7C7 #x82B2 -#x8FD7C8 #x82B4 -#x8FD7C9 #x82B7 -#x8FD7CA #x82BA -#x8FD7CB #x82BC -#x8FD7CC #x82BE -#x8FD7CD #x82BF -#x8FD7CE #x82C6 -#x8FD7CF #x82D0 -#x8FD7D0 #x82D5 -#x8FD7D1 #x82DA -#x8FD7D2 #x82E0 -#x8FD7D3 #x82E2 -#x8FD7D4 #x82E4 -#x8FD7D5 #x82E8 -#x8FD7D6 #x82EA -#x8FD7D7 #x82ED -#x8FD7D8 #x82EF -#x8FD7D9 #x82F6 -#x8FD7DA #x82F7 -#x8FD7DB #x82FD -#x8FD7DC #x82FE -#x8FD7DD #x8300 -#x8FD7DE #x8301 -#x8FD7DF #x8307 -#x8FD7E0 #x8308 -#x8FD7E1 #x830A -#x8FD7E2 #x830B -#x8FD7E3 #x8354 -#x8FD7E4 #x831B -#x8FD7E5 #x831D -#x8FD7E6 #x831E -#x8FD7E7 #x831F -#x8FD7E8 #x8321 -#x8FD7E9 #x8322 -#x8FD7EA #x832C -#x8FD7EB #x832D -#x8FD7EC #x832E -#x8FD7ED #x8330 -#x8FD7EE #x8333 -#x8FD7EF #x8337 -#x8FD7F0 #x833A -#x8FD7F1 #x833C -#x8FD7F2 #x833D -#x8FD7F3 #x8342 -#x8FD7F4 #x8343 -#x8FD7F5 #x8344 -#x8FD7F6 #x8347 -#x8FD7F7 #x834D -#x8FD7F8 #x834E -#x8FD7F9 #x8351 -#x8FD7FA #x8355 -#x8FD7FB #x8356 -#x8FD7FC #x8357 -#x8FD7FD #x8370 -#x8FD7FE #x8378 -#x8FD8A1 #x837D -#x8FD8A2 #x837F -#x8FD8A3 #x8380 -#x8FD8A4 #x8382 -#x8FD8A5 #x8384 -#x8FD8A6 #x8386 -#x8FD8A7 #x838D -#x8FD8A8 #x8392 -#x8FD8A9 #x8394 -#x8FD8AA #x8395 -#x8FD8AB #x8398 -#x8FD8AC #x8399 -#x8FD8AD #x839B -#x8FD8AE #x839C -#x8FD8AF #x839D -#x8FD8B0 #x83A6 -#x8FD8B1 #x83A7 -#x8FD8B2 #x83A9 -#x8FD8B3 #x83AC -#x8FD8B4 #x83BE -#x8FD8B5 #x83BF -#x8FD8B6 #x83C0 -#x8FD8B7 #x83C7 -#x8FD8B8 #x83C9 -#x8FD8B9 #x83CF -#x8FD8BA #x83D0 -#x8FD8BB #x83D1 -#x8FD8BC #x83D4 -#x8FD8BD #x83DD -#x8FD8BE #x8353 -#x8FD8BF #x83E8 -#x8FD8C0 #x83EA -#x8FD8C1 #x83F6 -#x8FD8C2 #x83F8 -#x8FD8C3 #x83F9 -#x8FD8C4 #x83FC -#x8FD8C5 #x8401 -#x8FD8C6 #x8406 -#x8FD8C7 #x840A -#x8FD8C8 #x840F -#x8FD8C9 #x8411 -#x8FD8CA #x8415 -#x8FD8CB #x8419 -#x8FD8CC #x83AD -#x8FD8CD #x842F -#x8FD8CE #x8439 -#x8FD8CF #x8445 -#x8FD8D0 #x8447 -#x8FD8D1 #x8448 -#x8FD8D2 #x844A -#x8FD8D3 #x844D -#x8FD8D4 #x844F -#x8FD8D5 #x8451 -#x8FD8D6 #x8452 -#x8FD8D7 #x8456 -#x8FD8D8 #x8458 -#x8FD8D9 #x8459 -#x8FD8DA #x845A -#x8FD8DB #x845C -#x8FD8DC #x8460 -#x8FD8DD #x8464 -#x8FD8DE #x8465 -#x8FD8DF #x8467 -#x8FD8E0 #x846A -#x8FD8E1 #x8470 -#x8FD8E2 #x8473 -#x8FD8E3 #x8474 -#x8FD8E4 #x8476 -#x8FD8E5 #x8478 -#x8FD8E6 #x847C -#x8FD8E7 #x847D -#x8FD8E8 #x8481 -#x8FD8E9 #x8485 -#x8FD8EA #x8492 -#x8FD8EB #x8493 -#x8FD8EC #x8495 -#x8FD8ED #x849E -#x8FD8EE #x84A6 -#x8FD8EF #x84A8 -#x8FD8F0 #x84A9 -#x8FD8F1 #x84AA -#x8FD8F2 #x84AF -#x8FD8F3 #x84B1 -#x8FD8F4 #x84B4 -#x8FD8F5 #x84BA -#x8FD8F6 #x84BD -#x8FD8F7 #x84BE -#x8FD8F8 #x84C0 -#x8FD8F9 #x84C2 -#x8FD8FA #x84C7 -#x8FD8FB #x84C8 -#x8FD8FC #x84CC -#x8FD8FD #x84CF -#x8FD8FE #x84D3 -#x8FD9A1 #x84DC -#x8FD9A2 #x84E7 -#x8FD9A3 #x84EA -#x8FD9A4 #x84EF -#x8FD9A5 #x84F0 -#x8FD9A6 #x84F1 -#x8FD9A7 #x84F2 -#x8FD9A8 #x84F7 -#x8FD9A9 #x8532 -#x8FD9AA #x84FA -#x8FD9AB #x84FB -#x8FD9AC #x84FD -#x8FD9AD #x8502 -#x8FD9AE #x8503 -#x8FD9AF #x8507 -#x8FD9B0 #x850C -#x8FD9B1 #x850E -#x8FD9B2 #x8510 -#x8FD9B3 #x851C -#x8FD9B4 #x851E -#x8FD9B5 #x8522 -#x8FD9B6 #x8523 -#x8FD9B7 #x8524 -#x8FD9B8 #x8525 -#x8FD9B9 #x8527 -#x8FD9BA #x852A -#x8FD9BB #x852B -#x8FD9BC #x852F -#x8FD9BD #x8533 -#x8FD9BE #x8534 -#x8FD9BF #x8536 -#x8FD9C0 #x853F -#x8FD9C1 #x8546 -#x8FD9C2 #x854F -#x8FD9C3 #x8550 -#x8FD9C4 #x8551 -#x8FD9C5 #x8552 -#x8FD9C6 #x8553 -#x8FD9C7 #x8556 -#x8FD9C8 #x8559 -#x8FD9C9 #x855C -#x8FD9CA #x855D -#x8FD9CB #x855E -#x8FD9CC #x855F -#x8FD9CD #x8560 -#x8FD9CE #x8561 -#x8FD9CF #x8562 -#x8FD9D0 #x8564 -#x8FD9D1 #x856B -#x8FD9D2 #x856F -#x8FD9D3 #x8579 -#x8FD9D4 #x857A -#x8FD9D5 #x857B -#x8FD9D6 #x857D -#x8FD9D7 #x857F -#x8FD9D8 #x8581 -#x8FD9D9 #x8585 -#x8FD9DA #x8586 -#x8FD9DB #x8589 -#x8FD9DC #x858B -#x8FD9DD #x858C -#x8FD9DE #x858F -#x8FD9DF #x8593 -#x8FD9E0 #x8598 -#x8FD9E1 #x859D -#x8FD9E2 #x859F -#x8FD9E3 #x85A0 -#x8FD9E4 #x85A2 -#x8FD9E5 #x85A5 -#x8FD9E6 #x85A7 -#x8FD9E7 #x85B4 -#x8FD9E8 #x85B6 -#x8FD9E9 #x85B7 -#x8FD9EA #x85B8 -#x8FD9EB #x85BC -#x8FD9EC #x85BD -#x8FD9ED #x85BE -#x8FD9EE #x85BF -#x8FD9EF #x85C2 -#x8FD9F0 #x85C7 -#x8FD9F1 #x85CA -#x8FD9F2 #x85CB -#x8FD9F3 #x85CE -#x8FD9F4 #x85AD -#x8FD9F5 #x85D8 -#x8FD9F6 #x85DA -#x8FD9F7 #x85DF -#x8FD9F8 #x85E0 -#x8FD9F9 #x85E6 -#x8FD9FA #x85E8 -#x8FD9FB #x85ED -#x8FD9FC #x85F3 -#x8FD9FD #x85F6 -#x8FD9FE #x85FC -#x8FDAA1 #x85FF -#x8FDAA2 #x8600 -#x8FDAA3 #x8604 -#x8FDAA4 #x8605 -#x8FDAA5 #x860D -#x8FDAA6 #x860E -#x8FDAA7 #x8610 -#x8FDAA8 #x8611 -#x8FDAA9 #x8612 -#x8FDAAA #x8618 -#x8FDAAB #x8619 -#x8FDAAC #x861B -#x8FDAAD #x861E -#x8FDAAE #x8621 -#x8FDAAF #x8627 -#x8FDAB0 #x8629 -#x8FDAB1 #x8636 -#x8FDAB2 #x8638 -#x8FDAB3 #x863A -#x8FDAB4 #x863C -#x8FDAB5 #x863D -#x8FDAB6 #x8640 -#x8FDAB7 #x8642 -#x8FDAB8 #x8646 -#x8FDAB9 #x8652 -#x8FDABA #x8653 -#x8FDABB #x8656 -#x8FDABC #x8657 -#x8FDABD #x8658 -#x8FDABE #x8659 -#x8FDABF #x865D -#x8FDAC0 #x8660 -#x8FDAC1 #x8661 -#x8FDAC2 #x8662 -#x8FDAC3 #x8663 -#x8FDAC4 #x8664 -#x8FDAC5 #x8669 -#x8FDAC6 #x866C -#x8FDAC7 #x866F -#x8FDAC8 #x8675 -#x8FDAC9 #x8676 -#x8FDACA #x8677 -#x8FDACB #x867A -#x8FDACC #x868D -#x8FDACD #x8691 -#x8FDACE #x8696 -#x8FDACF #x8698 -#x8FDAD0 #x869A -#x8FDAD1 #x869C -#x8FDAD2 #x86A1 -#x8FDAD3 #x86A6 -#x8FDAD4 #x86A7 -#x8FDAD5 #x86A8 -#x8FDAD6 #x86AD -#x8FDAD7 #x86B1 -#x8FDAD8 #x86B3 -#x8FDAD9 #x86B4 -#x8FDADA #x86B5 -#x8FDADB #x86B7 -#x8FDADC #x86B8 -#x8FDADD #x86B9 -#x8FDADE #x86BF -#x8FDADF #x86C0 -#x8FDAE0 #x86C1 -#x8FDAE1 #x86C3 -#x8FDAE2 #x86C5 -#x8FDAE3 #x86D1 -#x8FDAE4 #x86D2 -#x8FDAE5 #x86D5 -#x8FDAE6 #x86D7 -#x8FDAE7 #x86DA -#x8FDAE8 #x86DC -#x8FDAE9 #x86E0 -#x8FDAEA #x86E3 -#x8FDAEB #x86E5 -#x8FDAEC #x86E7 -#x8FDAED #x8688 -#x8FDAEE #x86FA -#x8FDAEF #x86FC -#x8FDAF0 #x86FD -#x8FDAF1 #x8704 -#x8FDAF2 #x8705 -#x8FDAF3 #x8707 -#x8FDAF4 #x870B -#x8FDAF5 #x870E -#x8FDAF6 #x870F -#x8FDAF7 #x8710 -#x8FDAF8 #x8713 -#x8FDAF9 #x8714 -#x8FDAFA #x8719 -#x8FDAFB #x871E -#x8FDAFC #x871F -#x8FDAFD #x8721 -#x8FDAFE #x8723 -#x8FDBA1 #x8728 -#x8FDBA2 #x872E -#x8FDBA3 #x872F -#x8FDBA4 #x8731 -#x8FDBA5 #x8732 -#x8FDBA6 #x8739 -#x8FDBA7 #x873A -#x8FDBA8 #x873C -#x8FDBA9 #x873D -#x8FDBAA #x873E -#x8FDBAB #x8740 -#x8FDBAC #x8743 -#x8FDBAD #x8745 -#x8FDBAE #x874D -#x8FDBAF #x8758 -#x8FDBB0 #x875D -#x8FDBB1 #x8761 -#x8FDBB2 #x8764 -#x8FDBB3 #x8765 -#x8FDBB4 #x876F -#x8FDBB5 #x8771 -#x8FDBB6 #x8772 -#x8FDBB7 #x877B -#x8FDBB8 #x8783 -#x8FDBB9 #x8784 -#x8FDBBA #x8785 -#x8FDBBB #x8786 -#x8FDBBC #x8787 -#x8FDBBD #x8788 -#x8FDBBE #x8789 -#x8FDBBF #x878B -#x8FDBC0 #x878C -#x8FDBC1 #x8790 -#x8FDBC2 #x8793 -#x8FDBC3 #x8795 -#x8FDBC4 #x8797 -#x8FDBC5 #x8798 -#x8FDBC6 #x8799 -#x8FDBC7 #x879E -#x8FDBC8 #x87A0 -#x8FDBC9 #x87A3 -#x8FDBCA #x87A7 -#x8FDBCB #x87AC -#x8FDBCC #x87AD -#x8FDBCD #x87AE -#x8FDBCE #x87B1 -#x8FDBCF #x87B5 -#x8FDBD0 #x87BE -#x8FDBD1 #x87BF -#x8FDBD2 #x87C1 -#x8FDBD3 #x87C8 -#x8FDBD4 #x87C9 -#x8FDBD5 #x87CA -#x8FDBD6 #x87CE -#x8FDBD7 #x87D5 -#x8FDBD8 #x87D6 -#x8FDBD9 #x87D9 -#x8FDBDA #x87DA -#x8FDBDB #x87DC -#x8FDBDC #x87DF -#x8FDBDD #x87E2 -#x8FDBDE #x87E3 -#x8FDBDF #x87E4 -#x8FDBE0 #x87EA -#x8FDBE1 #x87EB -#x8FDBE2 #x87ED -#x8FDBE3 #x87F1 -#x8FDBE4 #x87F3 -#x8FDBE5 #x87F8 -#x8FDBE6 #x87FA -#x8FDBE7 #x87FF -#x8FDBE8 #x8801 -#x8FDBE9 #x8803 -#x8FDBEA #x8806 -#x8FDBEB #x8809 -#x8FDBEC #x880A -#x8FDBED #x880B -#x8FDBEE #x8810 -#x8FDBEF #x8819 -#x8FDBF0 #x8812 -#x8FDBF1 #x8813 -#x8FDBF2 #x8814 -#x8FDBF3 #x8818 -#x8FDBF4 #x881A -#x8FDBF5 #x881B -#x8FDBF6 #x881C -#x8FDBF7 #x881E -#x8FDBF8 #x881F -#x8FDBF9 #x8828 -#x8FDBFA #x882D -#x8FDBFB #x882E -#x8FDBFC #x8830 -#x8FDBFD #x8832 -#x8FDBFE #x8835 -#x8FDCA1 #x883A -#x8FDCA2 #x883C -#x8FDCA3 #x8841 -#x8FDCA4 #x8843 -#x8FDCA5 #x8845 -#x8FDCA6 #x8848 -#x8FDCA7 #x8849 -#x8FDCA8 #x884A -#x8FDCA9 #x884B -#x8FDCAA #x884E -#x8FDCAB #x8851 -#x8FDCAC #x8855 -#x8FDCAD #x8856 -#x8FDCAE #x8858 -#x8FDCAF #x885A -#x8FDCB0 #x885C -#x8FDCB1 #x885F -#x8FDCB2 #x8860 -#x8FDCB3 #x8864 -#x8FDCB4 #x8869 -#x8FDCB5 #x8871 -#x8FDCB6 #x8879 -#x8FDCB7 #x887B -#x8FDCB8 #x8880 -#x8FDCB9 #x8898 -#x8FDCBA #x889A -#x8FDCBB #x889B -#x8FDCBC #x889C -#x8FDCBD #x889F -#x8FDCBE #x88A0 -#x8FDCBF #x88A8 -#x8FDCC0 #x88AA -#x8FDCC1 #x88BA -#x8FDCC2 #x88BD -#x8FDCC3 #x88BE -#x8FDCC4 #x88C0 -#x8FDCC5 #x88CA -#x8FDCC6 #x88CB -#x8FDCC7 #x88CC -#x8FDCC8 #x88CD -#x8FDCC9 #x88CE -#x8FDCCA #x88D1 -#x8FDCCB #x88D2 -#x8FDCCC #x88D3 -#x8FDCCD #x88DB -#x8FDCCE #x88DE -#x8FDCCF #x88E7 -#x8FDCD0 #x88EF -#x8FDCD1 #x88F0 -#x8FDCD2 #x88F1 -#x8FDCD3 #x88F5 -#x8FDCD4 #x88F7 -#x8FDCD5 #x8901 -#x8FDCD6 #x8906 -#x8FDCD7 #x890D -#x8FDCD8 #x890E -#x8FDCD9 #x890F -#x8FDCDA #x8915 -#x8FDCDB #x8916 -#x8FDCDC #x8918 -#x8FDCDD #x8919 -#x8FDCDE #x891A -#x8FDCDF #x891C -#x8FDCE0 #x8920 -#x8FDCE1 #x8926 -#x8FDCE2 #x8927 -#x8FDCE3 #x8928 -#x8FDCE4 #x8930 -#x8FDCE5 #x8931 -#x8FDCE6 #x8932 -#x8FDCE7 #x8935 -#x8FDCE8 #x8939 -#x8FDCE9 #x893A -#x8FDCEA #x893E -#x8FDCEB #x8940 -#x8FDCEC #x8942 -#x8FDCED #x8945 -#x8FDCEE #x8946 -#x8FDCEF #x8949 -#x8FDCF0 #x894F -#x8FDCF1 #x8952 -#x8FDCF2 #x8957 -#x8FDCF3 #x895A -#x8FDCF4 #x895B -#x8FDCF5 #x895C -#x8FDCF6 #x8961 -#x8FDCF7 #x8962 -#x8FDCF8 #x8963 -#x8FDCF9 #x896B -#x8FDCFA #x896E -#x8FDCFB #x8970 -#x8FDCFC #x8973 -#x8FDCFD #x8975 -#x8FDCFE #x897A -#x8FDDA1 #x897B -#x8FDDA2 #x897C -#x8FDDA3 #x897D -#x8FDDA4 #x8989 -#x8FDDA5 #x898D -#x8FDDA6 #x8990 -#x8FDDA7 #x8994 -#x8FDDA8 #x8995 -#x8FDDA9 #x899B -#x8FDDAA #x899C -#x8FDDAB #x899F -#x8FDDAC #x89A0 -#x8FDDAD #x89A5 -#x8FDDAE #x89B0 -#x8FDDAF #x89B4 -#x8FDDB0 #x89B5 -#x8FDDB1 #x89B6 -#x8FDDB2 #x89B7 -#x8FDDB3 #x89BC -#x8FDDB4 #x89D4 -#x8FDDB5 #x89D5 -#x8FDDB6 #x89D6 -#x8FDDB7 #x89D7 -#x8FDDB8 #x89D8 -#x8FDDB9 #x89E5 -#x8FDDBA #x89E9 -#x8FDDBB #x89EB -#x8FDDBC #x89ED -#x8FDDBD #x89F1 -#x8FDDBE #x89F3 -#x8FDDBF #x89F6 -#x8FDDC0 #x89F9 -#x8FDDC1 #x89FD -#x8FDDC2 #x89FF -#x8FDDC3 #x8A04 -#x8FDDC4 #x8A05 -#x8FDDC5 #x8A07 -#x8FDDC6 #x8A0F -#x8FDDC7 #x8A11 -#x8FDDC8 #x8A12 -#x8FDDC9 #x8A14 -#x8FDDCA #x8A15 -#x8FDDCB #x8A1E -#x8FDDCC #x8A20 -#x8FDDCD #x8A22 -#x8FDDCE #x8A24 -#x8FDDCF #x8A26 -#x8FDDD0 #x8A2B -#x8FDDD1 #x8A2C -#x8FDDD2 #x8A2F -#x8FDDD3 #x8A35 -#x8FDDD4 #x8A37 -#x8FDDD5 #x8A3D -#x8FDDD6 #x8A3E -#x8FDDD7 #x8A40 -#x8FDDD8 #x8A43 -#x8FDDD9 #x8A45 -#x8FDDDA #x8A47 -#x8FDDDB #x8A49 -#x8FDDDC #x8A4D -#x8FDDDD #x8A4E -#x8FDDDE #x8A53 -#x8FDDDF #x8A56 -#x8FDDE0 #x8A57 -#x8FDDE1 #x8A58 -#x8FDDE2 #x8A5C -#x8FDDE3 #x8A5D -#x8FDDE4 #x8A61 -#x8FDDE5 #x8A65 -#x8FDDE6 #x8A67 -#x8FDDE7 #x8A75 -#x8FDDE8 #x8A76 -#x8FDDE9 #x8A77 -#x8FDDEA #x8A79 -#x8FDDEB #x8A7A -#x8FDDEC #x8A7B -#x8FDDED #x8A7E -#x8FDDEE #x8A7F -#x8FDDEF #x8A80 -#x8FDDF0 #x8A83 -#x8FDDF1 #x8A86 -#x8FDDF2 #x8A8B -#x8FDDF3 #x8A8F -#x8FDDF4 #x8A90 -#x8FDDF5 #x8A92 -#x8FDDF6 #x8A96 -#x8FDDF7 #x8A97 -#x8FDDF8 #x8A99 -#x8FDDF9 #x8A9F -#x8FDDFA #x8AA7 -#x8FDDFB #x8AA9 -#x8FDDFC #x8AAE -#x8FDDFD #x8AAF -#x8FDDFE #x8AB3 -#x8FDEA1 #x8AB6 -#x8FDEA2 #x8AB7 -#x8FDEA3 #x8ABB -#x8FDEA4 #x8ABE -#x8FDEA5 #x8AC3 -#x8FDEA6 #x8AC6 -#x8FDEA7 #x8AC8 -#x8FDEA8 #x8AC9 -#x8FDEA9 #x8ACA -#x8FDEAA #x8AD1 -#x8FDEAB #x8AD3 -#x8FDEAC #x8AD4 -#x8FDEAD #x8AD5 -#x8FDEAE #x8AD7 -#x8FDEAF #x8ADD -#x8FDEB0 #x8ADF -#x8FDEB1 #x8AEC -#x8FDEB2 #x8AF0 -#x8FDEB3 #x8AF4 -#x8FDEB4 #x8AF5 -#x8FDEB5 #x8AF6 -#x8FDEB6 #x8AFC -#x8FDEB7 #x8AFF -#x8FDEB8 #x8B05 -#x8FDEB9 #x8B06 -#x8FDEBA #x8B0B -#x8FDEBB #x8B11 -#x8FDEBC #x8B1C -#x8FDEBD #x8B1E -#x8FDEBE #x8B1F -#x8FDEBF #x8B0A -#x8FDEC0 #x8B2D -#x8FDEC1 #x8B30 -#x8FDEC2 #x8B37 -#x8FDEC3 #x8B3C -#x8FDEC4 #x8B42 -#x8FDEC5 #x8B43 -#x8FDEC6 #x8B44 -#x8FDEC7 #x8B45 -#x8FDEC8 #x8B46 -#x8FDEC9 #x8B48 -#x8FDECA #x8B52 -#x8FDECB #x8B53 -#x8FDECC #x8B54 -#x8FDECD #x8B59 -#x8FDECE #x8B4D -#x8FDECF #x8B5E -#x8FDED0 #x8B63 -#x8FDED1 #x8B6D -#x8FDED2 #x8B76 -#x8FDED3 #x8B78 -#x8FDED4 #x8B79 -#x8FDED5 #x8B7C -#x8FDED6 #x8B7E -#x8FDED7 #x8B81 -#x8FDED8 #x8B84 -#x8FDED9 #x8B85 -#x8FDEDA #x8B8B -#x8FDEDB #x8B8D -#x8FDEDC #x8B8F -#x8FDEDD #x8B94 -#x8FDEDE #x8B95 -#x8FDEDF #x8B9C -#x8FDEE0 #x8B9E -#x8FDEE1 #x8B9F -#x8FDEE2 #x8C38 -#x8FDEE3 #x8C39 -#x8FDEE4 #x8C3D -#x8FDEE5 #x8C3E -#x8FDEE6 #x8C45 -#x8FDEE7 #x8C47 -#x8FDEE8 #x8C49 -#x8FDEE9 #x8C4B -#x8FDEEA #x8C4F -#x8FDEEB #x8C51 -#x8FDEEC #x8C53 -#x8FDEED #x8C54 -#x8FDEEE #x8C57 -#x8FDEEF #x8C58 -#x8FDEF0 #x8C5B -#x8FDEF1 #x8C5D -#x8FDEF2 #x8C59 -#x8FDEF3 #x8C63 -#x8FDEF4 #x8C64 -#x8FDEF5 #x8C66 -#x8FDEF6 #x8C68 -#x8FDEF7 #x8C69 -#x8FDEF8 #x8C6D -#x8FDEF9 #x8C73 -#x8FDEFA #x8C75 -#x8FDEFB #x8C76 -#x8FDEFC #x8C7B -#x8FDEFD #x8C7E -#x8FDEFE #x8C86 -#x8FDFA1 #x8C87 -#x8FDFA2 #x8C8B -#x8FDFA3 #x8C90 -#x8FDFA4 #x8C92 -#x8FDFA5 #x8C93 -#x8FDFA6 #x8C99 -#x8FDFA7 #x8C9B -#x8FDFA8 #x8C9C -#x8FDFA9 #x8CA4 -#x8FDFAA #x8CB9 -#x8FDFAB #x8CBA -#x8FDFAC #x8CC5 -#x8FDFAD #x8CC6 -#x8FDFAE #x8CC9 -#x8FDFAF #x8CCB -#x8FDFB0 #x8CCF -#x8FDFB1 #x8CD6 -#x8FDFB2 #x8CD5 -#x8FDFB3 #x8CD9 -#x8FDFB4 #x8CDD -#x8FDFB5 #x8CE1 -#x8FDFB6 #x8CE8 -#x8FDFB7 #x8CEC -#x8FDFB8 #x8CEF -#x8FDFB9 #x8CF0 -#x8FDFBA #x8CF2 -#x8FDFBB #x8CF5 -#x8FDFBC #x8CF7 -#x8FDFBD #x8CF8 -#x8FDFBE #x8CFE -#x8FDFBF #x8CFF -#x8FDFC0 #x8D01 -#x8FDFC1 #x8D03 -#x8FDFC2 #x8D09 -#x8FDFC3 #x8D12 -#x8FDFC4 #x8D17 -#x8FDFC5 #x8D1B -#x8FDFC6 #x8D65 -#x8FDFC7 #x8D69 -#x8FDFC8 #x8D6C -#x8FDFC9 #x8D6E -#x8FDFCA #x8D7F -#x8FDFCB #x8D82 -#x8FDFCC #x8D84 -#x8FDFCD #x8D88 -#x8FDFCE #x8D8D -#x8FDFCF #x8D90 -#x8FDFD0 #x8D91 -#x8FDFD1 #x8D95 -#x8FDFD2 #x8D9E -#x8FDFD3 #x8D9F -#x8FDFD4 #x8DA0 -#x8FDFD5 #x8DA6 -#x8FDFD6 #x8DAB -#x8FDFD7 #x8DAC -#x8FDFD8 #x8DAF -#x8FDFD9 #x8DB2 -#x8FDFDA #x8DB5 -#x8FDFDB #x8DB7 -#x8FDFDC #x8DB9 -#x8FDFDD #x8DBB -#x8FDFDE #x8DC0 -#x8FDFDF #x8DC5 -#x8FDFE0 #x8DC6 -#x8FDFE1 #x8DC7 -#x8FDFE2 #x8DC8 -#x8FDFE3 #x8DCA -#x8FDFE4 #x8DCE -#x8FDFE5 #x8DD1 -#x8FDFE6 #x8DD4 -#x8FDFE7 #x8DD5 -#x8FDFE8 #x8DD7 -#x8FDFE9 #x8DD9 -#x8FDFEA #x8DE4 -#x8FDFEB #x8DE5 -#x8FDFEC #x8DE7 -#x8FDFED #x8DEC -#x8FDFEE #x8DF0 -#x8FDFEF #x8DBC -#x8FDFF0 #x8DF1 -#x8FDFF1 #x8DF2 -#x8FDFF2 #x8DF4 -#x8FDFF3 #x8DFD -#x8FDFF4 #x8E01 -#x8FDFF5 #x8E04 -#x8FDFF6 #x8E05 -#x8FDFF7 #x8E06 -#x8FDFF8 #x8E0B -#x8FDFF9 #x8E11 -#x8FDFFA #x8E14 -#x8FDFFB #x8E16 -#x8FDFFC #x8E20 -#x8FDFFD #x8E21 -#x8FDFFE #x8E22 -#x8FE0A1 #x8E23 -#x8FE0A2 #x8E26 -#x8FE0A3 #x8E27 -#x8FE0A4 #x8E31 -#x8FE0A5 #x8E33 -#x8FE0A6 #x8E36 -#x8FE0A7 #x8E37 -#x8FE0A8 #x8E38 -#x8FE0A9 #x8E39 -#x8FE0AA #x8E3D -#x8FE0AB #x8E40 -#x8FE0AC #x8E41 -#x8FE0AD #x8E4B -#x8FE0AE #x8E4D -#x8FE0AF #x8E4E -#x8FE0B0 #x8E4F -#x8FE0B1 #x8E54 -#x8FE0B2 #x8E5B -#x8FE0B3 #x8E5C -#x8FE0B4 #x8E5D -#x8FE0B5 #x8E5E -#x8FE0B6 #x8E61 -#x8FE0B7 #x8E62 -#x8FE0B8 #x8E69 -#x8FE0B9 #x8E6C -#x8FE0BA #x8E6D -#x8FE0BB #x8E6F -#x8FE0BC #x8E70 -#x8FE0BD #x8E71 -#x8FE0BE #x8E79 -#x8FE0BF #x8E7A -#x8FE0C0 #x8E7B -#x8FE0C1 #x8E82 -#x8FE0C2 #x8E83 -#x8FE0C3 #x8E89 -#x8FE0C4 #x8E90 -#x8FE0C5 #x8E92 -#x8FE0C6 #x8E95 -#x8FE0C7 #x8E9A -#x8FE0C8 #x8E9B -#x8FE0C9 #x8E9D -#x8FE0CA #x8E9E -#x8FE0CB #x8EA2 -#x8FE0CC #x8EA7 -#x8FE0CD #x8EA9 -#x8FE0CE #x8EAD -#x8FE0CF #x8EAE -#x8FE0D0 #x8EB3 -#x8FE0D1 #x8EB5 -#x8FE0D2 #x8EBA -#x8FE0D3 #x8EBB -#x8FE0D4 #x8EC0 -#x8FE0D5 #x8EC1 -#x8FE0D6 #x8EC3 -#x8FE0D7 #x8EC4 -#x8FE0D8 #x8EC7 -#x8FE0D9 #x8ECF -#x8FE0DA #x8ED1 -#x8FE0DB #x8ED4 -#x8FE0DC #x8EDC -#x8FE0DD #x8EE8 -#x8FE0DE #x8EEE -#x8FE0DF #x8EF0 -#x8FE0E0 #x8EF1 -#x8FE0E1 #x8EF7 -#x8FE0E2 #x8EF9 -#x8FE0E3 #x8EFA -#x8FE0E4 #x8EED -#x8FE0E5 #x8F00 -#x8FE0E6 #x8F02 -#x8FE0E7 #x8F07 -#x8FE0E8 #x8F08 -#x8FE0E9 #x8F0F -#x8FE0EA #x8F10 -#x8FE0EB #x8F16 -#x8FE0EC #x8F17 -#x8FE0ED #x8F18 -#x8FE0EE #x8F1E -#x8FE0EF #x8F20 -#x8FE0F0 #x8F21 -#x8FE0F1 #x8F23 -#x8FE0F2 #x8F25 -#x8FE0F3 #x8F27 -#x8FE0F4 #x8F28 -#x8FE0F5 #x8F2C -#x8FE0F6 #x8F2D -#x8FE0F7 #x8F2E -#x8FE0F8 #x8F34 -#x8FE0F9 #x8F35 -#x8FE0FA #x8F36 -#x8FE0FB #x8F37 -#x8FE0FC #x8F3A -#x8FE0FD #x8F40 -#x8FE0FE #x8F41 -#x8FE1A1 #x8F43 -#x8FE1A2 #x8F47 -#x8FE1A3 #x8F4F -#x8FE1A4 #x8F51 -#x8FE1A5 #x8F52 -#x8FE1A6 #x8F53 -#x8FE1A7 #x8F54 -#x8FE1A8 #x8F55 -#x8FE1A9 #x8F58 -#x8FE1AA #x8F5D -#x8FE1AB #x8F5E -#x8FE1AC #x8F65 -#x8FE1AD #x8F9D -#x8FE1AE #x8FA0 -#x8FE1AF #x8FA1 -#x8FE1B0 #x8FA4 -#x8FE1B1 #x8FA5 -#x8FE1B2 #x8FA6 -#x8FE1B3 #x8FB5 -#x8FE1B4 #x8FB6 -#x8FE1B5 #x8FB8 -#x8FE1B6 #x8FBE -#x8FE1B7 #x8FC0 -#x8FE1B8 #x8FC1 -#x8FE1B9 #x8FC6 -#x8FE1BA #x8FCA -#x8FE1BB #x8FCB -#x8FE1BC #x8FCD -#x8FE1BD #x8FD0 -#x8FE1BE #x8FD2 -#x8FE1BF #x8FD3 -#x8FE1C0 #x8FD5 -#x8FE1C1 #x8FE0 -#x8FE1C2 #x8FE3 -#x8FE1C3 #x8FE4 -#x8FE1C4 #x8FE8 -#x8FE1C5 #x8FEE -#x8FE1C6 #x8FF1 -#x8FE1C7 #x8FF5 -#x8FE1C8 #x8FF6 -#x8FE1C9 #x8FFB -#x8FE1CA #x8FFE -#x8FE1CB #x9002 -#x8FE1CC #x9004 -#x8FE1CD #x9008 -#x8FE1CE #x900C -#x8FE1CF #x9018 -#x8FE1D0 #x901B -#x8FE1D1 #x9028 -#x8FE1D2 #x9029 -#x8FE1D3 #x902F -#x8FE1D4 #x902A -#x8FE1D5 #x902C -#x8FE1D6 #x902D -#x8FE1D7 #x9033 -#x8FE1D8 #x9034 -#x8FE1D9 #x9037 -#x8FE1DA #x903F -#x8FE1DB #x9043 -#x8FE1DC #x9044 -#x8FE1DD #x904C -#x8FE1DE #x905B -#x8FE1DF #x905D -#x8FE1E0 #x9062 -#x8FE1E1 #x9066 -#x8FE1E2 #x9067 -#x8FE1E3 #x906C -#x8FE1E4 #x9070 -#x8FE1E5 #x9074 -#x8FE1E6 #x9079 -#x8FE1E7 #x9085 -#x8FE1E8 #x9088 -#x8FE1E9 #x908B -#x8FE1EA #x908C -#x8FE1EB #x908E -#x8FE1EC #x9090 -#x8FE1ED #x9095 -#x8FE1EE #x9097 -#x8FE1EF #x9098 -#x8FE1F0 #x9099 -#x8FE1F1 #x909B -#x8FE1F2 #x90A0 -#x8FE1F3 #x90A1 -#x8FE1F4 #x90A2 -#x8FE1F5 #x90A5 -#x8FE1F6 #x90B0 -#x8FE1F7 #x90B2 -#x8FE1F8 #x90B3 -#x8FE1F9 #x90B4 -#x8FE1FA #x90B6 -#x8FE1FB #x90BD -#x8FE1FC #x90CC -#x8FE1FD #x90BE -#x8FE1FE #x90C3 -#x8FE2A1 #x90C4 -#x8FE2A2 #x90C5 -#x8FE2A3 #x90C7 -#x8FE2A4 #x90C8 -#x8FE2A5 #x90D5 -#x8FE2A6 #x90D7 -#x8FE2A7 #x90D8 -#x8FE2A8 #x90D9 -#x8FE2A9 #x90DC -#x8FE2AA #x90DD -#x8FE2AB #x90DF -#x8FE2AC #x90E5 -#x8FE2AD #x90D2 -#x8FE2AE #x90F6 -#x8FE2AF #x90EB -#x8FE2B0 #x90EF -#x8FE2B1 #x90F0 -#x8FE2B2 #x90F4 -#x8FE2B3 #x90FE -#x8FE2B4 #x90FF -#x8FE2B5 #x9100 -#x8FE2B6 #x9104 -#x8FE2B7 #x9105 -#x8FE2B8 #x9106 -#x8FE2B9 #x9108 -#x8FE2BA #x910D -#x8FE2BB #x9110 -#x8FE2BC #x9114 -#x8FE2BD #x9116 -#x8FE2BE #x9117 -#x8FE2BF #x9118 -#x8FE2C0 #x911A -#x8FE2C1 #x911C -#x8FE2C2 #x911E -#x8FE2C3 #x9120 -#x8FE2C4 #x9125 -#x8FE2C5 #x9122 -#x8FE2C6 #x9123 -#x8FE2C7 #x9127 -#x8FE2C8 #x9129 -#x8FE2C9 #x912E -#x8FE2CA #x912F -#x8FE2CB #x9131 -#x8FE2CC #x9134 -#x8FE2CD #x9136 -#x8FE2CE #x9137 -#x8FE2CF #x9139 -#x8FE2D0 #x913A -#x8FE2D1 #x913C -#x8FE2D2 #x913D -#x8FE2D3 #x9143 -#x8FE2D4 #x9147 -#x8FE2D5 #x9148 -#x8FE2D6 #x914F -#x8FE2D7 #x9153 -#x8FE2D8 #x9157 -#x8FE2D9 #x9159 -#x8FE2DA #x915A -#x8FE2DB #x915B -#x8FE2DC #x9161 -#x8FE2DD #x9164 -#x8FE2DE #x9167 -#x8FE2DF #x916D -#x8FE2E0 #x9174 -#x8FE2E1 #x9179 -#x8FE2E2 #x917A -#x8FE2E3 #x917B -#x8FE2E4 #x9181 -#x8FE2E5 #x9183 -#x8FE2E6 #x9185 -#x8FE2E7 #x9186 -#x8FE2E8 #x918A -#x8FE2E9 #x918E -#x8FE2EA #x9191 -#x8FE2EB #x9193 -#x8FE2EC #x9194 -#x8FE2ED #x9195 -#x8FE2EE #x9198 -#x8FE2EF #x919E -#x8FE2F0 #x91A1 -#x8FE2F1 #x91A6 -#x8FE2F2 #x91A8 -#x8FE2F3 #x91AC -#x8FE2F4 #x91AD -#x8FE2F5 #x91AE -#x8FE2F6 #x91B0 -#x8FE2F7 #x91B1 -#x8FE2F8 #x91B2 -#x8FE2F9 #x91B3 -#x8FE2FA #x91B6 -#x8FE2FB #x91BB -#x8FE2FC #x91BC -#x8FE2FD #x91BD -#x8FE2FE #x91BF -#x8FE3A1 #x91C2 -#x8FE3A2 #x91C3 -#x8FE3A3 #x91C5 -#x8FE3A4 #x91D3 -#x8FE3A5 #x91D4 -#x8FE3A6 #x91D7 -#x8FE3A7 #x91D9 -#x8FE3A8 #x91DA -#x8FE3A9 #x91DE -#x8FE3AA #x91E4 -#x8FE3AB #x91E5 -#x8FE3AC #x91E9 -#x8FE3AD #x91EA -#x8FE3AE #x91EC -#x8FE3AF #x91ED -#x8FE3B0 #x91EE -#x8FE3B1 #x91EF -#x8FE3B2 #x91F0 -#x8FE3B3 #x91F1 -#x8FE3B4 #x91F7 -#x8FE3B5 #x91F9 -#x8FE3B6 #x91FB -#x8FE3B7 #x91FD -#x8FE3B8 #x9200 -#x8FE3B9 #x9201 -#x8FE3BA #x9204 -#x8FE3BB #x9205 -#x8FE3BC #x9206 -#x8FE3BD #x9207 -#x8FE3BE #x9209 -#x8FE3BF #x920A -#x8FE3C0 #x920C -#x8FE3C1 #x9210 -#x8FE3C2 #x9212 -#x8FE3C3 #x9213 -#x8FE3C4 #x9216 -#x8FE3C5 #x9218 -#x8FE3C6 #x921C -#x8FE3C7 #x921D -#x8FE3C8 #x9223 -#x8FE3C9 #x9224 -#x8FE3CA #x9225 -#x8FE3CB #x9226 -#x8FE3CC #x9228 -#x8FE3CD #x922E -#x8FE3CE #x922F -#x8FE3CF #x9230 -#x8FE3D0 #x9233 -#x8FE3D1 #x9235 -#x8FE3D2 #x9236 -#x8FE3D3 #x9238 -#x8FE3D4 #x9239 -#x8FE3D5 #x923A -#x8FE3D6 #x923C -#x8FE3D7 #x923E -#x8FE3D8 #x9240 -#x8FE3D9 #x9242 -#x8FE3DA #x9243 -#x8FE3DB #x9246 -#x8FE3DC #x9247 -#x8FE3DD #x924A -#x8FE3DE #x924D -#x8FE3DF #x924E -#x8FE3E0 #x924F -#x8FE3E1 #x9251 -#x8FE3E2 #x9258 -#x8FE3E3 #x9259 -#x8FE3E4 #x925C -#x8FE3E5 #x925D -#x8FE3E6 #x9260 -#x8FE3E7 #x9261 -#x8FE3E8 #x9265 -#x8FE3E9 #x9267 -#x8FE3EA #x9268 -#x8FE3EB #x9269 -#x8FE3EC #x926E -#x8FE3ED #x926F -#x8FE3EE #x9270 -#x8FE3EF #x9275 -#x8FE3F0 #x9276 -#x8FE3F1 #x9277 -#x8FE3F2 #x9278 -#x8FE3F3 #x9279 -#x8FE3F4 #x927B -#x8FE3F5 #x927C -#x8FE3F6 #x927D -#x8FE3F7 #x927F -#x8FE3F8 #x9288 -#x8FE3F9 #x9289 -#x8FE3FA #x928A -#x8FE3FB #x928D -#x8FE3FC #x928E -#x8FE3FD #x9292 -#x8FE3FE #x9297 -#x8FE4A1 #x9299 -#x8FE4A2 #x929F -#x8FE4A3 #x92A0 -#x8FE4A4 #x92A4 -#x8FE4A5 #x92A5 -#x8FE4A6 #x92A7 -#x8FE4A7 #x92A8 -#x8FE4A8 #x92AB -#x8FE4A9 #x92AF -#x8FE4AA #x92B2 -#x8FE4AB #x92B6 -#x8FE4AC #x92B8 -#x8FE4AD #x92BA -#x8FE4AE #x92BB -#x8FE4AF #x92BC -#x8FE4B0 #x92BD -#x8FE4B1 #x92BF -#x8FE4B2 #x92C0 -#x8FE4B3 #x92C1 -#x8FE4B4 #x92C2 -#x8FE4B5 #x92C3 -#x8FE4B6 #x92C5 -#x8FE4B7 #x92C6 -#x8FE4B8 #x92C7 -#x8FE4B9 #x92C8 -#x8FE4BA #x92CB -#x8FE4BB #x92CC -#x8FE4BC #x92CD -#x8FE4BD #x92CE -#x8FE4BE #x92D0 -#x8FE4BF #x92D3 -#x8FE4C0 #x92D5 -#x8FE4C1 #x92D7 -#x8FE4C2 #x92D8 -#x8FE4C3 #x92D9 -#x8FE4C4 #x92DC -#x8FE4C5 #x92DD -#x8FE4C6 #x92DF -#x8FE4C7 #x92E0 -#x8FE4C8 #x92E1 -#x8FE4C9 #x92E3 -#x8FE4CA #x92E5 -#x8FE4CB #x92E7 -#x8FE4CC #x92E8 -#x8FE4CD #x92EC -#x8FE4CE #x92EE -#x8FE4CF #x92F0 -#x8FE4D0 #x92F9 -#x8FE4D1 #x92FB -#x8FE4D2 #x92FF -#x8FE4D3 #x9300 -#x8FE4D4 #x9302 -#x8FE4D5 #x9308 -#x8FE4D6 #x930D -#x8FE4D7 #x9311 -#x8FE4D8 #x9314 -#x8FE4D9 #x9315 -#x8FE4DA #x931C -#x8FE4DB #x931D -#x8FE4DC #x931E -#x8FE4DD #x931F -#x8FE4DE #x9321 -#x8FE4DF #x9324 -#x8FE4E0 #x9325 -#x8FE4E1 #x9327 -#x8FE4E2 #x9329 -#x8FE4E3 #x932A -#x8FE4E4 #x9333 -#x8FE4E5 #x9334 -#x8FE4E6 #x9336 -#x8FE4E7 #x9337 -#x8FE4E8 #x9347 -#x8FE4E9 #x9348 -#x8FE4EA #x9349 -#x8FE4EB #x9350 -#x8FE4EC #x9351 -#x8FE4ED #x9352 -#x8FE4EE #x9355 -#x8FE4EF #x9357 -#x8FE4F0 #x9358 -#x8FE4F1 #x935A -#x8FE4F2 #x935E -#x8FE4F3 #x9364 -#x8FE4F4 #x9365 -#x8FE4F5 #x9367 -#x8FE4F6 #x9369 -#x8FE4F7 #x936A -#x8FE4F8 #x936D -#x8FE4F9 #x936F -#x8FE4FA #x9370 -#x8FE4FB #x9371 -#x8FE4FC #x9373 -#x8FE4FD #x9374 -#x8FE4FE #x9376 -#x8FE5A1 #x937A -#x8FE5A2 #x937D -#x8FE5A3 #x937F -#x8FE5A4 #x9380 -#x8FE5A5 #x9381 -#x8FE5A6 #x9382 -#x8FE5A7 #x9388 -#x8FE5A8 #x938A -#x8FE5A9 #x938B -#x8FE5AA #x938D -#x8FE5AB #x938F -#x8FE5AC #x9392 -#x8FE5AD #x9395 -#x8FE5AE #x9398 -#x8FE5AF #x939B -#x8FE5B0 #x939E -#x8FE5B1 #x93A1 -#x8FE5B2 #x93A3 -#x8FE5B3 #x93A4 -#x8FE5B4 #x93A6 -#x8FE5B5 #x93A8 -#x8FE5B6 #x93AB -#x8FE5B7 #x93B4 -#x8FE5B8 #x93B5 -#x8FE5B9 #x93B6 -#x8FE5BA #x93BA -#x8FE5BB #x93A9 -#x8FE5BC #x93C1 -#x8FE5BD #x93C4 -#x8FE5BE #x93C5 -#x8FE5BF #x93C6 -#x8FE5C0 #x93C7 -#x8FE5C1 #x93C9 -#x8FE5C2 #x93CA -#x8FE5C3 #x93CB -#x8FE5C4 #x93CC -#x8FE5C5 #x93CD -#x8FE5C6 #x93D3 -#x8FE5C7 #x93D9 -#x8FE5C8 #x93DC -#x8FE5C9 #x93DE -#x8FE5CA #x93DF -#x8FE5CB #x93E2 -#x8FE5CC #x93E6 -#x8FE5CD #x93E7 -#x8FE5CE #x93F9 -#x8FE5CF #x93F7 -#x8FE5D0 #x93F8 -#x8FE5D1 #x93FA -#x8FE5D2 #x93FB -#x8FE5D3 #x93FD -#x8FE5D4 #x9401 -#x8FE5D5 #x9402 -#x8FE5D6 #x9404 -#x8FE5D7 #x9408 -#x8FE5D8 #x9409 -#x8FE5D9 #x940D -#x8FE5DA #x940E -#x8FE5DB #x940F -#x8FE5DC #x9415 -#x8FE5DD #x9416 -#x8FE5DE #x9417 -#x8FE5DF #x941F -#x8FE5E0 #x942E -#x8FE5E1 #x942F -#x8FE5E2 #x9431 -#x8FE5E3 #x9432 -#x8FE5E4 #x9433 -#x8FE5E5 #x9434 -#x8FE5E6 #x943B -#x8FE5E7 #x943F -#x8FE5E8 #x943D -#x8FE5E9 #x9443 -#x8FE5EA #x9445 -#x8FE5EB #x9448 -#x8FE5EC #x944A -#x8FE5ED #x944C -#x8FE5EE #x9455 -#x8FE5EF #x9459 -#x8FE5F0 #x945C -#x8FE5F1 #x945F -#x8FE5F2 #x9461 -#x8FE5F3 #x9463 -#x8FE5F4 #x9468 -#x8FE5F5 #x946B -#x8FE5F6 #x946D -#x8FE5F7 #x946E -#x8FE5F8 #x946F -#x8FE5F9 #x9471 -#x8FE5FA #x9472 -#x8FE5FB #x9484 -#x8FE5FC #x9483 -#x8FE5FD #x9578 -#x8FE5FE #x9579 -#x8FE6A1 #x957E -#x8FE6A2 #x9584 -#x8FE6A3 #x9588 -#x8FE6A4 #x958C -#x8FE6A5 #x958D -#x8FE6A6 #x958E -#x8FE6A7 #x959D -#x8FE6A8 #x959E -#x8FE6A9 #x959F -#x8FE6AA #x95A1 -#x8FE6AB #x95A6 -#x8FE6AC #x95A9 -#x8FE6AD #x95AB -#x8FE6AE #x95AC -#x8FE6AF #x95B4 -#x8FE6B0 #x95B6 -#x8FE6B1 #x95BA -#x8FE6B2 #x95BD -#x8FE6B3 #x95BF -#x8FE6B4 #x95C6 -#x8FE6B5 #x95C8 -#x8FE6B6 #x95C9 -#x8FE6B7 #x95CB -#x8FE6B8 #x95D0 -#x8FE6B9 #x95D1 -#x8FE6BA #x95D2 -#x8FE6BB #x95D3 -#x8FE6BC #x95D9 -#x8FE6BD #x95DA -#x8FE6BE #x95DD -#x8FE6BF #x95DE -#x8FE6C0 #x95DF -#x8FE6C1 #x95E0 -#x8FE6C2 #x95E4 -#x8FE6C3 #x95E6 -#x8FE6C4 #x961D -#x8FE6C5 #x961E -#x8FE6C6 #x9622 -#x8FE6C7 #x9624 -#x8FE6C8 #x9625 -#x8FE6C9 #x9626 -#x8FE6CA #x962C -#x8FE6CB #x9631 -#x8FE6CC #x9633 -#x8FE6CD #x9637 -#x8FE6CE #x9638 -#x8FE6CF #x9639 -#x8FE6D0 #x963A -#x8FE6D1 #x963C -#x8FE6D2 #x963D -#x8FE6D3 #x9641 -#x8FE6D4 #x9652 -#x8FE6D5 #x9654 -#x8FE6D6 #x9656 -#x8FE6D7 #x9657 -#x8FE6D8 #x9658 -#x8FE6D9 #x9661 -#x8FE6DA #x966E -#x8FE6DB #x9674 -#x8FE6DC #x967B -#x8FE6DD #x967C -#x8FE6DE #x967E -#x8FE6DF #x967F -#x8FE6E0 #x9681 -#x8FE6E1 #x9682 -#x8FE6E2 #x9683 -#x8FE6E3 #x9684 -#x8FE6E4 #x9689 -#x8FE6E5 #x9691 -#x8FE6E6 #x9696 -#x8FE6E7 #x969A -#x8FE6E8 #x969D -#x8FE6E9 #x969F -#x8FE6EA #x96A4 -#x8FE6EB #x96A5 -#x8FE6EC #x96A6 -#x8FE6ED #x96A9 -#x8FE6EE #x96AE -#x8FE6EF #x96AF -#x8FE6F0 #x96B3 -#x8FE6F1 #x96BA -#x8FE6F2 #x96CA -#x8FE6F3 #x96D2 -#x8FE6F4 #x5DB2 -#x8FE6F5 #x96D8 -#x8FE6F6 #x96DA -#x8FE6F7 #x96DD -#x8FE6F8 #x96DE -#x8FE6F9 #x96DF -#x8FE6FA #x96E9 -#x8FE6FB #x96EF -#x8FE6FC #x96F1 -#x8FE6FD #x96FA -#x8FE6FE #x9702 -#x8FE7A1 #x9703 -#x8FE7A2 #x9705 -#x8FE7A3 #x9709 -#x8FE7A4 #x971A -#x8FE7A5 #x971B -#x8FE7A6 #x971D -#x8FE7A7 #x9721 -#x8FE7A8 #x9722 -#x8FE7A9 #x9723 -#x8FE7AA #x9728 -#x8FE7AB #x9731 -#x8FE7AC #x9733 -#x8FE7AD #x9741 -#x8FE7AE #x9743 -#x8FE7AF #x974A -#x8FE7B0 #x974E -#x8FE7B1 #x974F -#x8FE7B2 #x9755 -#x8FE7B3 #x9757 -#x8FE7B4 #x9758 -#x8FE7B5 #x975A -#x8FE7B6 #x975B -#x8FE7B7 #x9763 -#x8FE7B8 #x9767 -#x8FE7B9 #x976A -#x8FE7BA #x976E -#x8FE7BB #x9773 -#x8FE7BC #x9776 -#x8FE7BD #x9777 -#x8FE7BE #x9778 -#x8FE7BF #x977B -#x8FE7C0 #x977D -#x8FE7C1 #x977F -#x8FE7C2 #x9780 -#x8FE7C3 #x9789 -#x8FE7C4 #x9795 -#x8FE7C5 #x9796 -#x8FE7C6 #x9797 -#x8FE7C7 #x9799 -#x8FE7C8 #x979A -#x8FE7C9 #x979E -#x8FE7CA #x979F -#x8FE7CB #x97A2 -#x8FE7CC #x97AC -#x8FE7CD #x97AE -#x8FE7CE #x97B1 -#x8FE7CF #x97B2 -#x8FE7D0 #x97B5 -#x8FE7D1 #x97B6 -#x8FE7D2 #x97B8 -#x8FE7D3 #x97B9 -#x8FE7D4 #x97BA -#x8FE7D5 #x97BC -#x8FE7D6 #x97BE -#x8FE7D7 #x97BF -#x8FE7D8 #x97C1 -#x8FE7D9 #x97C4 -#x8FE7DA #x97C5 -#x8FE7DB #x97C7 -#x8FE7DC #x97C9 -#x8FE7DD #x97CA -#x8FE7DE #x97CC -#x8FE7DF #x97CD -#x8FE7E0 #x97CE -#x8FE7E1 #x97D0 -#x8FE7E2 #x97D1 -#x8FE7E3 #x97D4 -#x8FE7E4 #x97D7 -#x8FE7E5 #x97D8 -#x8FE7E6 #x97D9 -#x8FE7E7 #x97DD -#x8FE7E8 #x97DE -#x8FE7E9 #x97E0 -#x8FE7EA #x97DB -#x8FE7EB #x97E1 -#x8FE7EC #x97E4 -#x8FE7ED #x97EF -#x8FE7EE #x97F1 -#x8FE7EF #x97F4 -#x8FE7F0 #x97F7 -#x8FE7F1 #x97F8 -#x8FE7F2 #x97FA -#x8FE7F3 #x9807 -#x8FE7F4 #x980A -#x8FE7F5 #x9819 -#x8FE7F6 #x980D -#x8FE7F7 #x980E -#x8FE7F8 #x9814 -#x8FE7F9 #x9816 -#x8FE7FA #x981C -#x8FE7FB #x981E -#x8FE7FC #x9820 -#x8FE7FD #x9823 -#x8FE7FE #x9826 -#x8FE8A1 #x982B -#x8FE8A2 #x982E -#x8FE8A3 #x982F -#x8FE8A4 #x9830 -#x8FE8A5 #x9832 -#x8FE8A6 #x9833 -#x8FE8A7 #x9835 -#x8FE8A8 #x9825 -#x8FE8A9 #x983E -#x8FE8AA #x9844 -#x8FE8AB #x9847 -#x8FE8AC #x984A -#x8FE8AD #x9851 -#x8FE8AE #x9852 -#x8FE8AF #x9853 -#x8FE8B0 #x9856 -#x8FE8B1 #x9857 -#x8FE8B2 #x9859 -#x8FE8B3 #x985A -#x8FE8B4 #x9862 -#x8FE8B5 #x9863 -#x8FE8B6 #x9865 -#x8FE8B7 #x9866 -#x8FE8B8 #x986A -#x8FE8B9 #x986C -#x8FE8BA #x98AB -#x8FE8BB #x98AD -#x8FE8BC #x98AE -#x8FE8BD #x98B0 -#x8FE8BE #x98B4 -#x8FE8BF #x98B7 -#x8FE8C0 #x98B8 -#x8FE8C1 #x98BA -#x8FE8C2 #x98BB -#x8FE8C3 #x98BF -#x8FE8C4 #x98C2 -#x8FE8C5 #x98C5 -#x8FE8C6 #x98C8 -#x8FE8C7 #x98CC -#x8FE8C8 #x98E1 -#x8FE8C9 #x98E3 -#x8FE8CA #x98E5 -#x8FE8CB #x98E6 -#x8FE8CC #x98E7 -#x8FE8CD #x98EA -#x8FE8CE #x98F3 -#x8FE8CF #x98F6 -#x8FE8D0 #x9902 -#x8FE8D1 #x9907 -#x8FE8D2 #x9908 -#x8FE8D3 #x9911 -#x8FE8D4 #x9915 -#x8FE8D5 #x9916 -#x8FE8D6 #x9917 -#x8FE8D7 #x991A -#x8FE8D8 #x991B -#x8FE8D9 #x991C -#x8FE8DA #x991F -#x8FE8DB #x9922 -#x8FE8DC #x9926 -#x8FE8DD #x9927 -#x8FE8DE #x992B -#x8FE8DF #x9931 -#x8FE8E0 #x9932 -#x8FE8E1 #x9933 -#x8FE8E2 #x9934 -#x8FE8E3 #x9935 -#x8FE8E4 #x9939 -#x8FE8E5 #x993A -#x8FE8E6 #x993B -#x8FE8E7 #x993C -#x8FE8E8 #x9940 -#x8FE8E9 #x9941 -#x8FE8EA #x9946 -#x8FE8EB #x9947 -#x8FE8EC #x9948 -#x8FE8ED #x994D -#x8FE8EE #x994E -#x8FE8EF #x9954 -#x8FE8F0 #x9958 -#x8FE8F1 #x9959 -#x8FE8F2 #x995B -#x8FE8F3 #x995C -#x8FE8F4 #x995E -#x8FE8F5 #x995F -#x8FE8F6 #x9960 -#x8FE8F7 #x999B -#x8FE8F8 #x999D -#x8FE8F9 #x999F -#x8FE8FA #x99A6 -#x8FE8FB #x99B0 -#x8FE8FC #x99B1 -#x8FE8FD #x99B2 -#x8FE8FE #x99B5 -#x8FE9A1 #x99B9 -#x8FE9A2 #x99BA -#x8FE9A3 #x99BD -#x8FE9A4 #x99BF -#x8FE9A5 #x99C3 -#x8FE9A6 #x99C9 -#x8FE9A7 #x99D3 -#x8FE9A8 #x99D4 -#x8FE9A9 #x99D9 -#x8FE9AA #x99DA -#x8FE9AB #x99DC -#x8FE9AC #x99DE -#x8FE9AD #x99E7 -#x8FE9AE #x99EA -#x8FE9AF #x99EB -#x8FE9B0 #x99EC -#x8FE9B1 #x99F0 -#x8FE9B2 #x99F4 -#x8FE9B3 #x99F5 -#x8FE9B4 #x99F9 -#x8FE9B5 #x99FD -#x8FE9B6 #x99FE -#x8FE9B7 #x9A02 -#x8FE9B8 #x9A03 -#x8FE9B9 #x9A04 -#x8FE9BA #x9A0B -#x8FE9BB #x9A0C -#x8FE9BC #x9A10 -#x8FE9BD #x9A11 -#x8FE9BE #x9A16 -#x8FE9BF #x9A1E -#x8FE9C0 #x9A20 -#x8FE9C1 #x9A22 -#x8FE9C2 #x9A23 -#x8FE9C3 #x9A24 -#x8FE9C4 #x9A27 -#x8FE9C5 #x9A2D -#x8FE9C6 #x9A2E -#x8FE9C7 #x9A33 -#x8FE9C8 #x9A35 -#x8FE9C9 #x9A36 -#x8FE9CA #x9A38 -#x8FE9CB #x9A47 -#x8FE9CC #x9A41 -#x8FE9CD #x9A44 -#x8FE9CE #x9A4A -#x8FE9CF #x9A4B -#x8FE9D0 #x9A4C -#x8FE9D1 #x9A4E -#x8FE9D2 #x9A51 -#x8FE9D3 #x9A54 -#x8FE9D4 #x9A56 -#x8FE9D5 #x9A5D -#x8FE9D6 #x9AAA -#x8FE9D7 #x9AAC -#x8FE9D8 #x9AAE -#x8FE9D9 #x9AAF -#x8FE9DA #x9AB2 -#x8FE9DB #x9AB4 -#x8FE9DC #x9AB5 -#x8FE9DD #x9AB6 -#x8FE9DE #x9AB9 -#x8FE9DF #x9ABB -#x8FE9E0 #x9ABE -#x8FE9E1 #x9ABF -#x8FE9E2 #x9AC1 -#x8FE9E3 #x9AC3 -#x8FE9E4 #x9AC6 -#x8FE9E5 #x9AC8 -#x8FE9E6 #x9ACE -#x8FE9E7 #x9AD0 -#x8FE9E8 #x9AD2 -#x8FE9E9 #x9AD5 -#x8FE9EA #x9AD6 -#x8FE9EB #x9AD7 -#x8FE9EC #x9ADB -#x8FE9ED #x9ADC -#x8FE9EE #x9AE0 -#x8FE9EF #x9AE4 -#x8FE9F0 #x9AE5 -#x8FE9F1 #x9AE7 -#x8FE9F2 #x9AE9 -#x8FE9F3 #x9AEC -#x8FE9F4 #x9AF2 -#x8FE9F5 #x9AF3 -#x8FE9F6 #x9AF5 -#x8FE9F7 #x9AF9 -#x8FE9F8 #x9AFA -#x8FE9F9 #x9AFD -#x8FE9FA #x9AFF -#x8FE9FB #x9B00 -#x8FE9FC #x9B01 -#x8FE9FD #x9B02 -#x8FE9FE #x9B03 -#x8FEAA1 #x9B04 -#x8FEAA2 #x9B05 -#x8FEAA3 #x9B08 -#x8FEAA4 #x9B09 -#x8FEAA5 #x9B0B -#x8FEAA6 #x9B0C -#x8FEAA7 #x9B0D -#x8FEAA8 #x9B0E -#x8FEAA9 #x9B10 -#x8FEAAA #x9B12 -#x8FEAAB #x9B16 -#x8FEAAC #x9B19 -#x8FEAAD #x9B1B -#x8FEAAE #x9B1C -#x8FEAAF #x9B20 -#x8FEAB0 #x9B26 -#x8FEAB1 #x9B2B -#x8FEAB2 #x9B2D -#x8FEAB3 #x9B33 -#x8FEAB4 #x9B34 -#x8FEAB5 #x9B35 -#x8FEAB6 #x9B37 -#x8FEAB7 #x9B39 -#x8FEAB8 #x9B3A -#x8FEAB9 #x9B3D -#x8FEABA #x9B48 -#x8FEABB #x9B4B -#x8FEABC #x9B4C -#x8FEABD #x9B55 -#x8FEABE #x9B56 -#x8FEABF #x9B57 -#x8FEAC0 #x9B5B -#x8FEAC1 #x9B5E -#x8FEAC2 #x9B61 -#x8FEAC3 #x9B63 -#x8FEAC4 #x9B65 -#x8FEAC5 #x9B66 -#x8FEAC6 #x9B68 -#x8FEAC7 #x9B6A -#x8FEAC8 #x9B6B -#x8FEAC9 #x9B6C -#x8FEACA #x9B6D -#x8FEACB #x9B6E -#x8FEACC #x9B73 -#x8FEACD #x9B75 -#x8FEACE #x9B77 -#x8FEACF #x9B78 -#x8FEAD0 #x9B79 -#x8FEAD1 #x9B7F -#x8FEAD2 #x9B80 -#x8FEAD3 #x9B84 -#x8FEAD4 #x9B85 -#x8FEAD5 #x9B86 -#x8FEAD6 #x9B87 -#x8FEAD7 #x9B89 -#x8FEAD8 #x9B8A -#x8FEAD9 #x9B8B -#x8FEADA #x9B8D -#x8FEADB #x9B8F -#x8FEADC #x9B90 -#x8FEADD #x9B94 -#x8FEADE #x9B9A -#x8FEADF #x9B9D -#x8FEAE0 #x9B9E -#x8FEAE1 #x9BA6 -#x8FEAE2 #x9BA7 -#x8FEAE3 #x9BA9 -#x8FEAE4 #x9BAC -#x8FEAE5 #x9BB0 -#x8FEAE6 #x9BB1 -#x8FEAE7 #x9BB2 -#x8FEAE8 #x9BB7 -#x8FEAE9 #x9BB8 -#x8FEAEA #x9BBB -#x8FEAEB #x9BBC -#x8FEAEC #x9BBE -#x8FEAED #x9BBF -#x8FEAEE #x9BC1 -#x8FEAEF #x9BC7 -#x8FEAF0 #x9BC8 -#x8FEAF1 #x9BCE -#x8FEAF2 #x9BD0 -#x8FEAF3 #x9BD7 -#x8FEAF4 #x9BD8 -#x8FEAF5 #x9BDD -#x8FEAF6 #x9BDF -#x8FEAF7 #x9BE5 -#x8FEAF8 #x9BE7 -#x8FEAF9 #x9BEA -#x8FEAFA #x9BEB -#x8FEAFB #x9BEF -#x8FEAFC #x9BF3 -#x8FEAFD #x9BF7 -#x8FEAFE #x9BF8 -#x8FEBA1 #x9BF9 -#x8FEBA2 #x9BFA -#x8FEBA3 #x9BFD -#x8FEBA4 #x9BFF -#x8FEBA5 #x9C00 -#x8FEBA6 #x9C02 -#x8FEBA7 #x9C0B -#x8FEBA8 #x9C0F -#x8FEBA9 #x9C11 -#x8FEBAA #x9C16 -#x8FEBAB #x9C18 -#x8FEBAC #x9C19 -#x8FEBAD #x9C1A -#x8FEBAE #x9C1C -#x8FEBAF #x9C1E -#x8FEBB0 #x9C22 -#x8FEBB1 #x9C23 -#x8FEBB2 #x9C26 -#x8FEBB3 #x9C27 -#x8FEBB4 #x9C28 -#x8FEBB5 #x9C29 -#x8FEBB6 #x9C2A -#x8FEBB7 #x9C31 -#x8FEBB8 #x9C35 -#x8FEBB9 #x9C36 -#x8FEBBA #x9C37 -#x8FEBBB #x9C3D -#x8FEBBC #x9C41 -#x8FEBBD #x9C43 -#x8FEBBE #x9C44 -#x8FEBBF #x9C45 -#x8FEBC0 #x9C49 -#x8FEBC1 #x9C4A -#x8FEBC2 #x9C4E -#x8FEBC3 #x9C4F -#x8FEBC4 #x9C50 -#x8FEBC5 #x9C53 -#x8FEBC6 #x9C54 -#x8FEBC7 #x9C56 -#x8FEBC8 #x9C58 -#x8FEBC9 #x9C5B -#x8FEBCA #x9C5D -#x8FEBCB #x9C5E -#x8FEBCC #x9C5F -#x8FEBCD #x9C63 -#x8FEBCE #x9C69 -#x8FEBCF #x9C6A -#x8FEBD0 #x9C5C -#x8FEBD1 #x9C6B -#x8FEBD2 #x9C68 -#x8FEBD3 #x9C6E -#x8FEBD4 #x9C70 -#x8FEBD5 #x9C72 -#x8FEBD6 #x9C75 -#x8FEBD7 #x9C77 -#x8FEBD8 #x9C7B -#x8FEBD9 #x9CE6 -#x8FEBDA #x9CF2 -#x8FEBDB #x9CF7 -#x8FEBDC #x9CF9 -#x8FEBDD #x9D0B -#x8FEBDE #x9D02 -#x8FEBDF #x9D11 -#x8FEBE0 #x9D17 -#x8FEBE1 #x9D18 -#x8FEBE2 #x9D1C -#x8FEBE3 #x9D1D -#x8FEBE4 #x9D1E -#x8FEBE5 #x9D2F -#x8FEBE6 #x9D30 -#x8FEBE7 #x9D32 -#x8FEBE8 #x9D33 -#x8FEBE9 #x9D34 -#x8FEBEA #x9D3A -#x8FEBEB #x9D3C -#x8FEBEC #x9D45 -#x8FEBED #x9D3D -#x8FEBEE #x9D42 -#x8FEBEF #x9D43 -#x8FEBF0 #x9D47 -#x8FEBF1 #x9D4A -#x8FEBF2 #x9D53 -#x8FEBF3 #x9D54 -#x8FEBF4 #x9D5F -#x8FEBF5 #x9D63 -#x8FEBF6 #x9D62 -#x8FEBF7 #x9D65 -#x8FEBF8 #x9D69 -#x8FEBF9 #x9D6A -#x8FEBFA #x9D6B -#x8FEBFB #x9D70 -#x8FEBFC #x9D76 -#x8FEBFD #x9D77 -#x8FEBFE #x9D7B -#x8FECA1 #x9D7C -#x8FECA2 #x9D7E -#x8FECA3 #x9D83 -#x8FECA4 #x9D84 -#x8FECA5 #x9D86 -#x8FECA6 #x9D8A -#x8FECA7 #x9D8D -#x8FECA8 #x9D8E -#x8FECA9 #x9D92 -#x8FECAA #x9D93 -#x8FECAB #x9D95 -#x8FECAC #x9D96 -#x8FECAD #x9D97 -#x8FECAE #x9D98 -#x8FECAF #x9DA1 -#x8FECB0 #x9DAA -#x8FECB1 #x9DAC -#x8FECB2 #x9DAE -#x8FECB3 #x9DB1 -#x8FECB4 #x9DB5 -#x8FECB5 #x9DB9 -#x8FECB6 #x9DBC -#x8FECB7 #x9DBF -#x8FECB8 #x9DC3 -#x8FECB9 #x9DC7 -#x8FECBA #x9DC9 -#x8FECBB #x9DCA -#x8FECBC #x9DD4 -#x8FECBD #x9DD5 -#x8FECBE #x9DD6 -#x8FECBF #x9DD7 -#x8FECC0 #x9DDA -#x8FECC1 #x9DDE -#x8FECC2 #x9DDF -#x8FECC3 #x9DE0 -#x8FECC4 #x9DE5 -#x8FECC5 #x9DE7 -#x8FECC6 #x9DE9 -#x8FECC7 #x9DEB -#x8FECC8 #x9DEE -#x8FECC9 #x9DF0 -#x8FECCA #x9DF3 -#x8FECCB #x9DF4 -#x8FECCC #x9DFE -#x8FECCD #x9E0A -#x8FECCE #x9E02 -#x8FECCF #x9E07 -#x8FECD0 #x9E0E -#x8FECD1 #x9E10 -#x8FECD2 #x9E11 -#x8FECD3 #x9E12 -#x8FECD4 #x9E15 -#x8FECD5 #x9E16 -#x8FECD6 #x9E19 -#x8FECD7 #x9E1C -#x8FECD8 #x9E1D -#x8FECD9 #x9E7A -#x8FECDA #x9E7B -#x8FECDB #x9E7C -#x8FECDC #x9E80 -#x8FECDD #x9E82 -#x8FECDE #x9E83 -#x8FECDF #x9E84 -#x8FECE0 #x9E85 -#x8FECE1 #x9E87 -#x8FECE2 #x9E8E -#x8FECE3 #x9E8F -#x8FECE4 #x9E96 -#x8FECE5 #x9E98 -#x8FECE6 #x9E9B -#x8FECE7 #x9E9E -#x8FECE8 #x9EA4 -#x8FECE9 #x9EA8 -#x8FECEA #x9EAC -#x8FECEB #x9EAE -#x8FECEC #x9EAF -#x8FECED #x9EB0 -#x8FECEE #x9EB3 -#x8FECEF #x9EB4 -#x8FECF0 #x9EB5 -#x8FECF1 #x9EC6 -#x8FECF2 #x9EC8 -#x8FECF3 #x9ECB -#x8FECF4 #x9ED5 -#x8FECF5 #x9EDF -#x8FECF6 #x9EE4 -#x8FECF7 #x9EE7 -#x8FECF8 #x9EEC -#x8FECF9 #x9EED -#x8FECFA #x9EEE -#x8FECFB #x9EF0 -#x8FECFC #x9EF1 -#x8FECFD #x9EF2 -#x8FECFE #x9EF5 -#x8FEDA1 #x9EF8 -#x8FEDA2 #x9EFF -#x8FEDA3 #x9F02 -#x8FEDA4 #x9F03 -#x8FEDA5 #x9F09 -#x8FEDA6 #x9F0F -#x8FEDA7 #x9F10 -#x8FEDA8 #x9F11 -#x8FEDA9 #x9F12 -#x8FEDAA #x9F14 -#x8FEDAB #x9F16 -#x8FEDAC #x9F17 -#x8FEDAD #x9F19 -#x8FEDAE #x9F1A -#x8FEDAF #x9F1B -#x8FEDB0 #x9F1F -#x8FEDB1 #x9F22 -#x8FEDB2 #x9F26 -#x8FEDB3 #x9F2A -#x8FEDB4 #x9F2B -#x8FEDB5 #x9F2F -#x8FEDB6 #x9F31 -#x8FEDB7 #x9F32 -#x8FEDB8 #x9F34 -#x8FEDB9 #x9F37 -#x8FEDBA #x9F39 -#x8FEDBB #x9F3A -#x8FEDBC #x9F3C -#x8FEDBD #x9F3D -#x8FEDBE #x9F3F -#x8FEDBF #x9F41 -#x8FEDC0 #x9F43 -#x8FEDC1 #x9F44 -#x8FEDC2 #x9F45 -#x8FEDC3 #x9F46 -#x8FEDC4 #x9F47 -#x8FEDC5 #x9F53 -#x8FEDC6 #x9F55 -#x8FEDC7 #x9F56 -#x8FEDC8 #x9F57 -#x8FEDC9 #x9F58 -#x8FEDCA #x9F5A -#x8FEDCB #x9F5D -#x8FEDCC #x9F5E -#x8FEDCD #x9F68 -#x8FEDCE #x9F69 -#x8FEDCF #x9F6D -#x8FEDD0 #x9F6E -#x8FEDD1 #x9F6F -#x8FEDD2 #x9F70 -#x8FEDD3 #x9F71 -#x8FEDD4 #x9F73 -#x8FEDD5 #x9F75 -#x8FEDD6 #x9F7A -#x8FEDD7 #x9F7D -#x8FEDD8 #x9F8F -#x8FEDD9 #x9F90 -#x8FEDDA #x9F91 -#x8FEDDB #x9F92 -#x8FEDDC #x9F94 -#x8FEDDD #x9F96 -#x8FEDDE #x9F97 -#x8FEDDF #x9F9E -#x8FEDE0 #x9FA1 -#x8FEDE1 #x9FA2 -#x8FEDE2 #x9FA3 -#x8FEDE3 #x9FA5 +#x20 #x0020 +#x21 #x0021 +#x22 #x0022 +#x23 #x0023 +#x24 #x0024 +#x25 #x0025 +#x26 #x0026 +#x27 #x0027 +#x28 #x0028 +#x29 #x0029 +#x2A #x002A +#x2B #x002B +#x2C #x002C +#x2D #x002D +#x2E #x002E +#x2F #x002F +#x30 #x0030 +#x31 #x0031 +#x32 #x0032 +#x33 #x0033 +#x34 #x0034 +#x35 #x0035 +#x36 #x0036 +#x37 #x0037 +#x38 #x0038 +#x39 #x0039 +#x3A #x003A +#x3B #x003B +#x3C #x003C +#x3D #x003D +#x3E #x003E +#x3F #x003F +#x40 #x0040 +#x41 #x0041 +#x42 #x0042 +#x43 #x0043 +#x44 #x0044 +#x45 #x0045 +#x46 #x0046 +#x47 #x0047 +#x48 #x0048 +#x49 #x0049 +#x4A #x004A +#x4B #x004B +#x4C #x004C +#x4D #x004D +#x4E #x004E +#x4F #x004F +#x50 #x0050 +#x51 #x0051 +#x52 #x0052 +#x53 #x0053 +#x54 #x0054 +#x55 #x0055 +#x56 #x0056 +#x57 #x0057 +#x58 #x0058 +#x59 #x0059 +#x5A #x005A +#x5B #x005B +#x5C #x005C +#x5D #x005D +#x5E #x005E +#x5F #x005F +#x60 #x0060 +#x61 #x0061 +#x62 #x0062 +#x63 #x0063 +#x64 #x0064 +#x65 #x0065 +#x66 #x0066 +#x67 #x0067 +#x68 #x0068 +#x69 #x0069 +#x6A #x006A +#x6B #x006B +#x6C #x006C +#x6D #x006D +#x6E #x006E +#x6F #x006F +#x70 #x0070 +#x71 #x0071 +#x72 #x0072 +#x73 #x0073 +#x74 #x0074 +#x75 #x0075 +#x76 #x0076 +#x77 #x0077 +#x78 #x0078 +#x79 #x0079 +#x7A #x007A +#x7B #x007B +#x7C #x007C +#x7D #x007D +#x7E #x007E +#x8EA1 #xFF61 +#x8EA2 #xFF62 +#x8EA3 #xFF63 +#x8EA4 #xFF64 +#x8EA5 #xFF65 +#x8EA6 #xFF66 +#x8EA7 #xFF67 +#x8EA8 #xFF68 +#x8EA9 #xFF69 +#x8EAA #xFF6A +#x8EAB #xFF6B +#x8EAC #xFF6C +#x8EAD #xFF6D +#x8EAE #xFF6E +#x8EAF #xFF6F +#x8EB0 #xFF70 +#x8EB1 #xFF71 +#x8EB2 #xFF72 +#x8EB3 #xFF73 +#x8EB4 #xFF74 +#x8EB5 #xFF75 +#x8EB6 #xFF76 +#x8EB7 #xFF77 +#x8EB8 #xFF78 +#x8EB9 #xFF79 +#x8EBA #xFF7A +#x8EBB #xFF7B +#x8EBC #xFF7C +#x8EBD #xFF7D +#x8EBE #xFF7E +#x8EBF #xFF7F +#x8EC0 #xFF80 +#x8EC1 #xFF81 +#x8EC2 #xFF82 +#x8EC3 #xFF83 +#x8EC4 #xFF84 +#x8EC5 #xFF85 +#x8EC6 #xFF86 +#x8EC7 #xFF87 +#x8EC8 #xFF88 +#x8EC9 #xFF89 +#x8ECA #xFF8A +#x8ECB #xFF8B +#x8ECC #xFF8C +#x8ECD #xFF8D +#x8ECE #xFF8E +#x8ECF #xFF8F +#x8ED0 #xFF90 +#x8ED1 #xFF91 +#x8ED2 #xFF92 +#x8ED3 #xFF93 +#x8ED4 #xFF94 +#x8ED5 #xFF95 +#x8ED6 #xFF96 +#x8ED7 #xFF97 +#x8ED8 #xFF98 +#x8ED9 #xFF99 +#x8EDA #xFF9A +#x8EDB #xFF9B +#x8EDC #xFF9C +#x8EDD #xFF9D +#x8EDE #xFF9E +#x8EDF #xFF9F +#xA1A1 #x3000 +#xA1A2 #x3001 +#xA1A3 #x3002 +#xA1A4 #xFF0C +#xA1A5 #xFF0E +#xA1A6 #x30FB +#xA1A7 #xFF1A +#xA1A8 #xFF1B +#xA1A9 #xFF1F +#xA1AA #xFF01 +#xA1AB #x309B +#xA1AC #x309C +#xA1AD #x00B4 +#xA1AE #xFF40 +#xA1AF #x00A8 +#xA1B0 #xFF3E +#xA1B1 #x203E +#xA1B2 #xFF3F +#xA1B3 #x30FD +#xA1B4 #x30FE +#xA1B5 #x309D +#xA1B6 #x309E +#xA1B7 #x3003 +#xA1B8 #x4EDD +#xA1B9 #x3005 +#xA1BA #x3006 +#xA1BB #x3007 +#xA1BC #x30FC +#xA1BD #x2014 +#xA1BE #x2010 +#xA1BF #xFF0F +#xA1C0 #xFF3C +#xA1C1 #x301C +#xA1C2 #x2016 +#xA1C3 #xFF5C +#xA1C4 #x2026 +#xA1C5 #x2025 +#xA1C6 #x2018 +#xA1C7 #x2019 +#xA1C8 #x201C +#xA1C9 #x201D +#xA1CA #xFF08 +#xA1CB #xFF09 +#xA1CC #x3014 +#xA1CD #x3015 +#xA1CE #xFF3B +#xA1CF #xFF3D +#xA1D0 #xFF5B +#xA1D1 #xFF5D +#xA1D2 #x3008 +#xA1D3 #x3009 +#xA1D4 #x300A +#xA1D5 #x300B +#xA1D6 #x300C +#xA1D7 #x300D +#xA1D8 #x300E +#xA1D9 #x300F +#xA1DA #x3010 +#xA1DB #x3011 +#xA1DC #xFF0B +#xA1DD #x2212 +#xA1DE #x00B1 +#xA1DF #x00D7 +#xA1E0 #x00F7 +#xA1E1 #xFF1D +#xA1E2 #x2260 +#xA1E3 #xFF1C +#xA1E4 #xFF1E +#xA1E5 #x2266 +#xA1E6 #x2267 +#xA1E7 #x221E +#xA1E8 #x2234 +#xA1E9 #x2642 +#xA1EA #x2640 +#xA1EB #x00B0 +#xA1EC #x2032 +#xA1ED #x2033 +#xA1EE #x2103 +#xA1EF #x00A5 +#xA1F0 #xFF04 +#xA1F1 #x00A2 +#xA1F2 #x00A3 +#xA1F3 #xFF05 +#xA1F4 #xFF03 +#xA1F5 #xFF06 +#xA1F6 #xFF0A +#xA1F7 #xFF20 +#xA1F8 #x00A7 +#xA1F9 #x2606 +#xA1FA #x2605 +#xA1FB #x25CB +#xA1FC #x25CF +#xA1FD #x25CE +#xA1FE #x25C7 +#xA2A1 #x25C6 +#xA2A2 #x25A1 +#xA2A3 #x25A0 +#xA2A4 #x25B3 +#xA2A5 #x25B2 +#xA2A6 #x25BD +#xA2A7 #x25BC +#xA2A8 #x203B +#xA2A9 #x3012 +#xA2AA #x2192 +#xA2AB #x2190 +#xA2AC #x2191 +#xA2AD #x2193 +#xA2AE #x3013 +#xA2BA #x2208 +#xA2BB #x220B +#xA2BC #x2286 +#xA2BD #x2287 +#xA2BE #x2282 +#xA2BF #x2283 +#xA2C0 #x222A +#xA2C1 #x2229 +#xA2CA #x2227 +#xA2CB #x2228 +#xA2CC #x00AC +#xA2CD #x21D2 +#xA2CE #x21D4 +#xA2CF #x2200 +#xA2D0 #x2203 +#xA2DC #x2220 +#xA2DD #x22A5 +#xA2DE #x2312 +#xA2DF #x2202 +#xA2E0 #x2207 +#xA2E1 #x2261 +#xA2E2 #x2252 +#xA2E3 #x226A +#xA2E4 #x226B +#xA2E5 #x221A +#xA2E6 #x223D +#xA2E7 #x221D +#xA2E8 #x2235 +#xA2E9 #x222B +#xA2EA #x222C +#xA2F2 #x212B +#xA2F3 #x2030 +#xA2F4 #x266F +#xA2F5 #x266D +#xA2F6 #x266A +#xA2F7 #x2020 +#xA2F8 #x2021 +#xA2F9 #x00B6 +#xA2FE #x25EF +#xA3B0 #xFF10 +#xA3B1 #xFF11 +#xA3B2 #xFF12 +#xA3B3 #xFF13 +#xA3B4 #xFF14 +#xA3B5 #xFF15 +#xA3B6 #xFF16 +#xA3B7 #xFF17 +#xA3B8 #xFF18 +#xA3B9 #xFF19 +#xA3C1 #xFF21 +#xA3C2 #xFF22 +#xA3C3 #xFF23 +#xA3C4 #xFF24 +#xA3C5 #xFF25 +#xA3C6 #xFF26 +#xA3C7 #xFF27 +#xA3C8 #xFF28 +#xA3C9 #xFF29 +#xA3CA #xFF2A +#xA3CB #xFF2B +#xA3CC #xFF2C +#xA3CD #xFF2D +#xA3CE #xFF2E +#xA3CF #xFF2F +#xA3D0 #xFF30 +#xA3D1 #xFF31 +#xA3D2 #xFF32 +#xA3D3 #xFF33 +#xA3D4 #xFF34 +#xA3D5 #xFF35 +#xA3D6 #xFF36 +#xA3D7 #xFF37 +#xA3D8 #xFF38 +#xA3D9 #xFF39 +#xA3DA #xFF3A +#xA3E1 #xFF41 +#xA3E2 #xFF42 +#xA3E3 #xFF43 +#xA3E4 #xFF44 +#xA3E5 #xFF45 +#xA3E6 #xFF46 +#xA3E7 #xFF47 +#xA3E8 #xFF48 +#xA3E9 #xFF49 +#xA3EA #xFF4A +#xA3EB #xFF4B +#xA3EC #xFF4C +#xA3ED #xFF4D +#xA3EE #xFF4E +#xA3EF #xFF4F +#xA3F0 #xFF50 +#xA3F1 #xFF51 +#xA3F2 #xFF52 +#xA3F3 #xFF53 +#xA3F4 #xFF54 +#xA3F5 #xFF55 +#xA3F6 #xFF56 +#xA3F7 #xFF57 +#xA3F8 #xFF58 +#xA3F9 #xFF59 +#xA3FA #xFF5A +#xA4A1 #x3041 +#xA4A2 #x3042 +#xA4A3 #x3043 +#xA4A4 #x3044 +#xA4A5 #x3045 +#xA4A6 #x3046 +#xA4A7 #x3047 +#xA4A8 #x3048 +#xA4A9 #x3049 +#xA4AA #x304A +#xA4AB #x304B +#xA4AC #x304C +#xA4AD #x304D +#xA4AE #x304E +#xA4AF #x304F +#xA4B0 #x3050 +#xA4B1 #x3051 +#xA4B2 #x3052 +#xA4B3 #x3053 +#xA4B4 #x3054 +#xA4B5 #x3055 +#xA4B6 #x3056 +#xA4B7 #x3057 +#xA4B8 #x3058 +#xA4B9 #x3059 +#xA4BA #x305A +#xA4BB #x305B +#xA4BC #x305C +#xA4BD #x305D +#xA4BE #x305E +#xA4BF #x305F +#xA4C0 #x3060 +#xA4C1 #x3061 +#xA4C2 #x3062 +#xA4C3 #x3063 +#xA4C4 #x3064 +#xA4C5 #x3065 +#xA4C6 #x3066 +#xA4C7 #x3067 +#xA4C8 #x3068 +#xA4C9 #x3069 +#xA4CA #x306A +#xA4CB #x306B +#xA4CC #x306C +#xA4CD #x306D +#xA4CE #x306E +#xA4CF #x306F +#xA4D0 #x3070 +#xA4D1 #x3071 +#xA4D2 #x3072 +#xA4D3 #x3073 +#xA4D4 #x3074 +#xA4D5 #x3075 +#xA4D6 #x3076 +#xA4D7 #x3077 +#xA4D8 #x3078 +#xA4D9 #x3079 +#xA4DA #x307A +#xA4DB #x307B +#xA4DC #x307C +#xA4DD #x307D +#xA4DE #x307E +#xA4DF #x307F +#xA4E0 #x3080 +#xA4E1 #x3081 +#xA4E2 #x3082 +#xA4E3 #x3083 +#xA4E4 #x3084 +#xA4E5 #x3085 +#xA4E6 #x3086 +#xA4E7 #x3087 +#xA4E8 #x3088 +#xA4E9 #x3089 +#xA4EA #x308A +#xA4EB #x308B +#xA4EC #x308C +#xA4ED #x308D +#xA4EE #x308E +#xA4EF #x308F +#xA4F0 #x3090 +#xA4F1 #x3091 +#xA4F2 #x3092 +#xA4F3 #x3093 +#xA5A1 #x30A1 +#xA5A2 #x30A2 +#xA5A3 #x30A3 +#xA5A4 #x30A4 +#xA5A5 #x30A5 +#xA5A6 #x30A6 +#xA5A7 #x30A7 +#xA5A8 #x30A8 +#xA5A9 #x30A9 +#xA5AA #x30AA +#xA5AB #x30AB +#xA5AC #x30AC +#xA5AD #x30AD +#xA5AE #x30AE +#xA5AF #x30AF +#xA5B0 #x30B0 +#xA5B1 #x30B1 +#xA5B2 #x30B2 +#xA5B3 #x30B3 +#xA5B4 #x30B4 +#xA5B5 #x30B5 +#xA5B6 #x30B6 +#xA5B7 #x30B7 +#xA5B8 #x30B8 +#xA5B9 #x30B9 +#xA5BA #x30BA +#xA5BB #x30BB +#xA5BC #x30BC +#xA5BD #x30BD +#xA5BE #x30BE +#xA5BF #x30BF +#xA5C0 #x30C0 +#xA5C1 #x30C1 +#xA5C2 #x30C2 +#xA5C3 #x30C3 +#xA5C4 #x30C4 +#xA5C5 #x30C5 +#xA5C6 #x30C6 +#xA5C7 #x30C7 +#xA5C8 #x30C8 +#xA5C9 #x30C9 +#xA5CA #x30CA +#xA5CB #x30CB +#xA5CC #x30CC +#xA5CD #x30CD +#xA5CE #x30CE +#xA5CF #x30CF +#xA5D0 #x30D0 +#xA5D1 #x30D1 +#xA5D2 #x30D2 +#xA5D3 #x30D3 +#xA5D4 #x30D4 +#xA5D5 #x30D5 +#xA5D6 #x30D6 +#xA5D7 #x30D7 +#xA5D8 #x30D8 +#xA5D9 #x30D9 +#xA5DA #x30DA +#xA5DB #x30DB +#xA5DC #x30DC +#xA5DD #x30DD +#xA5DE #x30DE +#xA5DF #x30DF +#xA5E0 #x30E0 +#xA5E1 #x30E1 +#xA5E2 #x30E2 +#xA5E3 #x30E3 +#xA5E4 #x30E4 +#xA5E5 #x30E5 +#xA5E6 #x30E6 +#xA5E7 #x30E7 +#xA5E8 #x30E8 +#xA5E9 #x30E9 +#xA5EA #x30EA +#xA5EB #x30EB +#xA5EC #x30EC +#xA5ED #x30ED +#xA5EE #x30EE +#xA5EF #x30EF +#xA5F0 #x30F0 +#xA5F1 #x30F1 +#xA5F2 #x30F2 +#xA5F3 #x30F3 +#xA5F4 #x30F4 +#xA5F5 #x30F5 +#xA5F6 #x30F6 +#xA6A1 #x0391 +#xA6A2 #x0392 +#xA6A3 #x0393 +#xA6A4 #x0394 +#xA6A5 #x0395 +#xA6A6 #x0396 +#xA6A7 #x0397 +#xA6A8 #x0398 +#xA6A9 #x0399 +#xA6AA #x039A +#xA6AB #x039B +#xA6AC #x039C +#xA6AD #x039D +#xA6AE #x039E +#xA6AF #x039F +#xA6B0 #x03A0 +#xA6B1 #x03A1 +#xA6B2 #x03A3 +#xA6B3 #x03A4 +#xA6B4 #x03A5 +#xA6B5 #x03A6 +#xA6B6 #x03A7 +#xA6B7 #x03A8 +#xA6B8 #x03A9 +#xA6C1 #x03B1 +#xA6C2 #x03B2 +#xA6C3 #x03B3 +#xA6C4 #x03B4 +#xA6C5 #x03B5 +#xA6C6 #x03B6 +#xA6C7 #x03B7 +#xA6C8 #x03B8 +#xA6C9 #x03B9 +#xA6CA #x03BA +#xA6CB #x03BB +#xA6CC #x03BC +#xA6CD #x03BD +#xA6CE #x03BE +#xA6CF #x03BF +#xA6D0 #x03C0 +#xA6D1 #x03C1 +#xA6D2 #x03C3 +#xA6D3 #x03C4 +#xA6D4 #x03C5 +#xA6D5 #x03C6 +#xA6D6 #x03C7 +#xA6D7 #x03C8 +#xA6D8 #x03C9 +#xA7A1 #x0410 +#xA7A2 #x0411 +#xA7A3 #x0412 +#xA7A4 #x0413 +#xA7A5 #x0414 +#xA7A6 #x0415 +#xA7A7 #x0401 +#xA7A8 #x0416 +#xA7A9 #x0417 +#xA7AA #x0418 +#xA7AB #x0419 +#xA7AC #x041A +#xA7AD #x041B +#xA7AE #x041C +#xA7AF #x041D +#xA7B0 #x041E +#xA7B1 #x041F +#xA7B2 #x0420 +#xA7B3 #x0421 +#xA7B4 #x0422 +#xA7B5 #x0423 +#xA7B6 #x0424 +#xA7B7 #x0425 +#xA7B8 #x0426 +#xA7B9 #x0427 +#xA7BA #x0428 +#xA7BB #x0429 +#xA7BC #x042A +#xA7BD #x042B +#xA7BE #x042C +#xA7BF #x042D +#xA7C0 #x042E +#xA7C1 #x042F +#xA7D1 #x0430 +#xA7D2 #x0431 +#xA7D3 #x0432 +#xA7D4 #x0433 +#xA7D5 #x0434 +#xA7D6 #x0435 +#xA7D7 #x0451 +#xA7D8 #x0436 +#xA7D9 #x0437 +#xA7DA #x0438 +#xA7DB #x0439 +#xA7DC #x043A +#xA7DD #x043B +#xA7DE #x043C +#xA7DF #x043D +#xA7E0 #x043E +#xA7E1 #x043F +#xA7E2 #x0440 +#xA7E3 #x0441 +#xA7E4 #x0442 +#xA7E5 #x0443 +#xA7E6 #x0444 +#xA7E7 #x0445 +#xA7E8 #x0446 +#xA7E9 #x0447 +#xA7EA #x0448 +#xA7EB #x0449 +#xA7EC #x044A +#xA7ED #x044B +#xA7EE #x044C +#xA7EF #x044D +#xA7F0 #x044E +#xA7F1 #x044F +#xA8A1 #x2500 +#xA8A2 #x2502 +#xA8A3 #x250C +#xA8A4 #x2510 +#xA8A5 #x2518 +#xA8A6 #x2514 +#xA8A7 #x251C +#xA8A8 #x252C +#xA8A9 #x2524 +#xA8AA #x2534 +#xA8AB #x253C +#xA8AC #x2501 +#xA8AD #x2503 +#xA8AE #x250F +#xA8AF #x2513 +#xA8B0 #x251B +#xA8B1 #x2517 +#xA8B2 #x2523 +#xA8B3 #x2533 +#xA8B4 #x252B +#xA8B5 #x253B +#xA8B6 #x254B +#xA8B7 #x2520 +#xA8B8 #x252F +#xA8B9 #x2528 +#xA8BA #x2537 +#xA8BB #x253F +#xA8BC #x251D +#xA8BD #x2530 +#xA8BE #x2525 +#xA8BF #x2538 +#xA8C0 #x2542 +#xB0A1 #x4E9C +#xB0A2 #x5516 +#xB0A3 #x5A03 +#xB0A4 #x963F +#xB0A5 #x54C0 +#xB0A6 #x611B +#xB0A7 #x6328 +#xB0A8 #x59F6 +#xB0A9 #x9022 +#xB0AA #x8475 +#xB0AB #x831C +#xB0AC #x7A50 +#xB0AD #x60AA +#xB0AE #x63E1 +#xB0AF #x6E25 +#xB0B0 #x65ED +#xB0B1 #x8466 +#xB0B2 #x82A6 +#xB0B3 #x9BF5 +#xB0B4 #x6893 +#xB0B5 #x5727 +#xB0B6 #x65A1 +#xB0B7 #x6271 +#xB0B8 #x5B9B +#xB0B9 #x59D0 +#xB0BA #x867B +#xB0BB #x98F4 +#xB0BC #x7D62 +#xB0BD #x7DBE +#xB0BE #x9B8E +#xB0BF #x6216 +#xB0C0 #x7C9F +#xB0C1 #x88B7 +#xB0C2 #x5B89 +#xB0C3 #x5EB5 +#xB0C4 #x6309 +#xB0C5 #x6697 +#xB0C6 #x6848 +#xB0C7 #x95C7 +#xB0C8 #x978D +#xB0C9 #x674F +#xB0CA #x4EE5 +#xB0CB #x4F0A +#xB0CC #x4F4D +#xB0CD #x4F9D +#xB0CE #x5049 +#xB0CF #x56F2 +#xB0D0 #x5937 +#xB0D1 #x59D4 +#xB0D2 #x5A01 +#xB0D3 #x5C09 +#xB0D4 #x60DF +#xB0D5 #x610F +#xB0D6 #x6170 +#xB0D7 #x6613 +#xB0D8 #x6905 +#xB0D9 #x70BA +#xB0DA #x754F +#xB0DB #x7570 +#xB0DC #x79FB +#xB0DD #x7DAD +#xB0DE #x7DEF +#xB0DF #x80C3 +#xB0E0 #x840E +#xB0E1 #x8863 +#xB0E2 #x8B02 +#xB0E3 #x9055 +#xB0E4 #x907A +#xB0E5 #x533B +#xB0E6 #x4E95 +#xB0E7 #x4EA5 +#xB0E8 #x57DF +#xB0E9 #x80B2 +#xB0EA #x90C1 +#xB0EB #x78EF +#xB0EC #x4E00 +#xB0ED #x58F1 +#xB0EE #x6EA2 +#xB0EF #x9038 +#xB0F0 #x7A32 +#xB0F1 #x8328 +#xB0F2 #x828B +#xB0F3 #x9C2F +#xB0F4 #x5141 +#xB0F5 #x5370 +#xB0F6 #x54BD +#xB0F7 #x54E1 +#xB0F8 #x56E0 +#xB0F9 #x59FB +#xB0FA #x5F15 +#xB0FB #x98F2 +#xB0FC #x6DEB +#xB0FD #x80E4 +#xB0FE #x852D +#xB1A1 #x9662 +#xB1A2 #x9670 +#xB1A3 #x96A0 +#xB1A4 #x97FB +#xB1A5 #x540B +#xB1A6 #x53F3 +#xB1A7 #x5B87 +#xB1A8 #x70CF +#xB1A9 #x7FBD +#xB1AA #x8FC2 +#xB1AB #x96E8 +#xB1AC #x536F +#xB1AD #x9D5C +#xB1AE #x7ABA +#xB1AF #x4E11 +#xB1B0 #x7893 +#xB1B1 #x81FC +#xB1B2 #x6E26 +#xB1B3 #x5618 +#xB1B4 #x5504 +#xB1B5 #x6B1D +#xB1B6 #x851A +#xB1B7 #x9C3B +#xB1B8 #x59E5 +#xB1B9 #x53A9 +#xB1BA #x6D66 +#xB1BB #x74DC +#xB1BC #x958F +#xB1BD #x5642 +#xB1BE #x4E91 +#xB1BF #x904B +#xB1C0 #x96F2 +#xB1C1 #x834F +#xB1C2 #x990C +#xB1C3 #x53E1 +#xB1C4 #x55B6 +#xB1C5 #x5B30 +#xB1C6 #x5F71 +#xB1C7 #x6620 +#xB1C8 #x66F3 +#xB1C9 #x6804 +#xB1CA #x6C38 +#xB1CB #x6CF3 +#xB1CC #x6D29 +#xB1CD #x745B +#xB1CE #x76C8 +#xB1CF #x7A4E +#xB1D0 #x9834 +#xB1D1 #x82F1 +#xB1D2 #x885B +#xB1D3 #x8A60 +#xB1D4 #x92ED +#xB1D5 #x6DB2 +#xB1D6 #x75AB +#xB1D7 #x76CA +#xB1D8 #x99C5 +#xB1D9 #x60A6 +#xB1DA #x8B01 +#xB1DB #x8D8A +#xB1DC #x95B2 +#xB1DD #x698E +#xB1DE #x53AD +#xB1DF #x5186 +#xB1E0 #x5712 +#xB1E1 #x5830 +#xB1E2 #x5944 +#xB1E3 #x5BB4 +#xB1E4 #x5EF6 +#xB1E5 #x6028 +#xB1E6 #x63A9 +#xB1E7 #x63F4 +#xB1E8 #x6CBF +#xB1E9 #x6F14 +#xB1EA #x708E +#xB1EB #x7114 +#xB1EC #x7159 +#xB1ED #x71D5 +#xB1EE #x733F +#xB1EF #x7E01 +#xB1F0 #x8276 +#xB1F1 #x82D1 +#xB1F2 #x8597 +#xB1F3 #x9060 +#xB1F4 #x925B +#xB1F5 #x9D1B +#xB1F6 #x5869 +#xB1F7 #x65BC +#xB1F8 #x6C5A +#xB1F9 #x7525 +#xB1FA #x51F9 +#xB1FB #x592E +#xB1FC #x5965 +#xB1FD #x5F80 +#xB1FE #x5FDC +#xB2A1 #x62BC +#xB2A2 #x65FA +#xB2A3 #x6A2A +#xB2A4 #x6B27 +#xB2A5 #x6BB4 +#xB2A6 #x738B +#xB2A7 #x7FC1 +#xB2A8 #x8956 +#xB2A9 #x9D2C +#xB2AA #x9D0E +#xB2AB #x9EC4 +#xB2AC #x5CA1 +#xB2AD #x6C96 +#xB2AE #x837B +#xB2AF #x5104 +#xB2B0 #x5C4B +#xB2B1 #x61B6 +#xB2B2 #x81C6 +#xB2B3 #x6876 +#xB2B4 #x7261 +#xB2B5 #x4E59 +#xB2B6 #x4FFA +#xB2B7 #x5378 +#xB2B8 #x6069 +#xB2B9 #x6E29 +#xB2BA #x7A4F +#xB2BB #x97F3 +#xB2BC #x4E0B +#xB2BD #x5316 +#xB2BE #x4EEE +#xB2BF #x4F55 +#xB2C0 #x4F3D +#xB2C1 #x4FA1 +#xB2C2 #x4F73 +#xB2C3 #x52A0 +#xB2C4 #x53EF +#xB2C5 #x5609 +#xB2C6 #x590F +#xB2C7 #x5AC1 +#xB2C8 #x5BB6 +#xB2C9 #x5BE1 +#xB2CA #x79D1 +#xB2CB #x6687 +#xB2CC #x679C +#xB2CD #x67B6 +#xB2CE #x6B4C +#xB2CF #x6CB3 +#xB2D0 #x706B +#xB2D1 #x73C2 +#xB2D2 #x798D +#xB2D3 #x79BE +#xB2D4 #x7A3C +#xB2D5 #x7B87 +#xB2D6 #x82B1 +#xB2D7 #x82DB +#xB2D8 #x8304 +#xB2D9 #x8377 +#xB2DA #x83EF +#xB2DB #x83D3 +#xB2DC #x8766 +#xB2DD #x8AB2 +#xB2DE #x5629 +#xB2DF #x8CA8 +#xB2E0 #x8FE6 +#xB2E1 #x904E +#xB2E2 #x971E +#xB2E3 #x868A +#xB2E4 #x4FC4 +#xB2E5 #x5CE8 +#xB2E6 #x6211 +#xB2E7 #x7259 +#xB2E8 #x753B +#xB2E9 #x81E5 +#xB2EA #x82BD +#xB2EB #x86FE +#xB2EC #x8CC0 +#xB2ED #x96C5 +#xB2EE #x9913 +#xB2EF #x99D5 +#xB2F0 #x4ECB +#xB2F1 #x4F1A +#xB2F2 #x89E3 +#xB2F3 #x56DE +#xB2F4 #x584A +#xB2F5 #x58CA +#xB2F6 #x5EFB +#xB2F7 #x5FEB +#xB2F8 #x602A +#xB2F9 #x6094 +#xB2FA #x6062 +#xB2FB #x61D0 +#xB2FC #x6212 +#xB2FD #x62D0 +#xB2FE #x6539 +#xB3A1 #x9B41 +#xB3A2 #x6666 +#xB3A3 #x68B0 +#xB3A4 #x6D77 +#xB3A5 #x7070 +#xB3A6 #x754C +#xB3A7 #x7686 +#xB3A8 #x7D75 +#xB3A9 #x82A5 +#xB3AA #x87F9 +#xB3AB #x958B +#xB3AC #x968E +#xB3AD #x8C9D +#xB3AE #x51F1 +#xB3AF #x52BE +#xB3B0 #x5916 +#xB3B1 #x54B3 +#xB3B2 #x5BB3 +#xB3B3 #x5D16 +#xB3B4 #x6168 +#xB3B5 #x6982 +#xB3B6 #x6DAF +#xB3B7 #x788D +#xB3B8 #x84CB +#xB3B9 #x8857 +#xB3BA #x8A72 +#xB3BB #x93A7 +#xB3BC #x9AB8 +#xB3BD #x6D6C +#xB3BE #x99A8 +#xB3BF #x86D9 +#xB3C0 #x57A3 +#xB3C1 #x67FF +#xB3C2 #x86CE +#xB3C3 #x920E +#xB3C4 #x5283 +#xB3C5 #x5687 +#xB3C6 #x5404 +#xB3C7 #x5ED3 +#xB3C8 #x62E1 +#xB3C9 #x64B9 +#xB3CA #x683C +#xB3CB #x6838 +#xB3CC #x6BBB +#xB3CD #x7372 +#xB3CE #x78BA +#xB3CF #x7A6B +#xB3D0 #x899A +#xB3D1 #x89D2 +#xB3D2 #x8D6B +#xB3D3 #x8F03 +#xB3D4 #x90ED +#xB3D5 #x95A3 +#xB3D6 #x9694 +#xB3D7 #x9769 +#xB3D8 #x5B66 +#xB3D9 #x5CB3 +#xB3DA #x697D +#xB3DB #x984D +#xB3DC #x984E +#xB3DD #x639B +#xB3DE #x7B20 +#xB3DF #x6A2B +#xB3E0 #x6A7F +#xB3E1 #x68B6 +#xB3E2 #x9C0D +#xB3E3 #x6F5F +#xB3E4 #x5272 +#xB3E5 #x559D +#xB3E6 #x6070 +#xB3E7 #x62EC +#xB3E8 #x6D3B +#xB3E9 #x6E07 +#xB3EA #x6ED1 +#xB3EB #x845B +#xB3EC #x8910 +#xB3ED #x8F44 +#xB3EE #x4E14 +#xB3EF #x9C39 +#xB3F0 #x53F6 +#xB3F1 #x691B +#xB3F2 #x6A3A +#xB3F3 #x9784 +#xB3F4 #x682A +#xB3F5 #x515C +#xB3F6 #x7AC3 +#xB3F7 #x84B2 +#xB3F8 #x91DC +#xB3F9 #x938C +#xB3FA #x565B +#xB3FB #x9D28 +#xB3FC #x6822 +#xB3FD #x8305 +#xB3FE #x8431 +#xB4A1 #x7CA5 +#xB4A2 #x5208 +#xB4A3 #x82C5 +#xB4A4 #x74E6 +#xB4A5 #x4E7E +#xB4A6 #x4F83 +#xB4A7 #x51A0 +#xB4A8 #x5BD2 +#xB4A9 #x520A +#xB4AA #x52D8 +#xB4AB #x52E7 +#xB4AC #x5DFB +#xB4AD #x559A +#xB4AE #x582A +#xB4AF #x59E6 +#xB4B0 #x5B8C +#xB4B1 #x5B98 +#xB4B2 #x5BDB +#xB4B3 #x5E72 +#xB4B4 #x5E79 +#xB4B5 #x60A3 +#xB4B6 #x611F +#xB4B7 #x6163 +#xB4B8 #x61BE +#xB4B9 #x63DB +#xB4BA #x6562 +#xB4BB #x67D1 +#xB4BC #x6853 +#xB4BD #x68FA +#xB4BE #x6B3E +#xB4BF #x6B53 +#xB4C0 #x6C57 +#xB4C1 #x6F22 +#xB4C2 #x6F97 +#xB4C3 #x6F45 +#xB4C4 #x74B0 +#xB4C5 #x7518 +#xB4C6 #x76E3 +#xB4C7 #x770B +#xB4C8 #x7AFF +#xB4C9 #x7BA1 +#xB4CA #x7C21 +#xB4CB #x7DE9 +#xB4CC #x7F36 +#xB4CD #x7FF0 +#xB4CE #x809D +#xB4CF #x8266 +#xB4D0 #x839E +#xB4D1 #x89B3 +#xB4D2 #x8ACC +#xB4D3 #x8CAB +#xB4D4 #x9084 +#xB4D5 #x9451 +#xB4D6 #x9593 +#xB4D7 #x9591 +#xB4D8 #x95A2 +#xB4D9 #x9665 +#xB4DA #x97D3 +#xB4DB #x9928 +#xB4DC #x8218 +#xB4DD #x4E38 +#xB4DE #x542B +#xB4DF #x5CB8 +#xB4E0 #x5DCC +#xB4E1 #x73A9 +#xB4E2 #x764C +#xB4E3 #x773C +#xB4E4 #x5CA9 +#xB4E5 #x7FEB +#xB4E6 #x8D0B +#xB4E7 #x96C1 +#xB4E8 #x9811 +#xB4E9 #x9854 +#xB4EA #x9858 +#xB4EB #x4F01 +#xB4EC #x4F0E +#xB4ED #x5371 +#xB4EE #x559C +#xB4EF #x5668 +#xB4F0 #x57FA +#xB4F1 #x5947 +#xB4F2 #x5B09 +#xB4F3 #x5BC4 +#xB4F4 #x5C90 +#xB4F5 #x5E0C +#xB4F6 #x5E7E +#xB4F7 #x5FCC +#xB4F8 #x63EE +#xB4F9 #x673A +#xB4FA #x65D7 +#xB4FB #x65E2 +#xB4FC #x671F +#xB4FD #x68CB +#xB4FE #x68C4 +#xB5A1 #x6A5F +#xB5A2 #x5E30 +#xB5A3 #x6BC5 +#xB5A4 #x6C17 +#xB5A5 #x6C7D +#xB5A6 #x757F +#xB5A7 #x7948 +#xB5A8 #x5B63 +#xB5A9 #x7A00 +#xB5AA #x7D00 +#xB5AB #x5FBD +#xB5AC #x898F +#xB5AD #x8A18 +#xB5AE #x8CB4 +#xB5AF #x8D77 +#xB5B0 #x8ECC +#xB5B1 #x8F1D +#xB5B2 #x98E2 +#xB5B3 #x9A0E +#xB5B4 #x9B3C +#xB5B5 #x4E80 +#xB5B6 #x507D +#xB5B7 #x5100 +#xB5B8 #x5993 +#xB5B9 #x5B9C +#xB5BA #x622F +#xB5BB #x6280 +#xB5BC #x64EC +#xB5BD #x6B3A +#xB5BE #x72A0 +#xB5BF #x7591 +#xB5C0 #x7947 +#xB5C1 #x7FA9 +#xB5C2 #x87FB +#xB5C3 #x8ABC +#xB5C4 #x8B70 +#xB5C5 #x63AC +#xB5C6 #x83CA +#xB5C7 #x97A0 +#xB5C8 #x5409 +#xB5C9 #x5403 +#xB5CA #x55AB +#xB5CB #x6854 +#xB5CC #x6A58 +#xB5CD #x8A70 +#xB5CE #x7827 +#xB5CF #x6775 +#xB5D0 #x9ECD +#xB5D1 #x5374 +#xB5D2 #x5BA2 +#xB5D3 #x811A +#xB5D4 #x8650 +#xB5D5 #x9006 +#xB5D6 #x4E18 +#xB5D7 #x4E45 +#xB5D8 #x4EC7 +#xB5D9 #x4F11 +#xB5DA #x53CA +#xB5DB #x5438 +#xB5DC #x5BAE +#xB5DD #x5F13 +#xB5DE #x6025 +#xB5DF #x6551 +#xB5E0 #x673D +#xB5E1 #x6C42 +#xB5E2 #x6C72 +#xB5E3 #x6CE3 +#xB5E4 #x7078 +#xB5E5 #x7403 +#xB5E6 #x7A76 +#xB5E7 #x7AAE +#xB5E8 #x7B08 +#xB5E9 #x7D1A +#xB5EA #x7CFE +#xB5EB #x7D66 +#xB5EC #x65E7 +#xB5ED #x725B +#xB5EE #x53BB +#xB5EF #x5C45 +#xB5F0 #x5DE8 +#xB5F1 #x62D2 +#xB5F2 #x62E0 +#xB5F3 #x6319 +#xB5F4 #x6E20 +#xB5F5 #x865A +#xB5F6 #x8A31 +#xB5F7 #x8DDD +#xB5F8 #x92F8 +#xB5F9 #x6F01 +#xB5FA #x79A6 +#xB5FB #x9B5A +#xB5FC #x4EA8 +#xB5FD #x4EAB +#xB5FE #x4EAC +#xB6A1 #x4F9B +#xB6A2 #x4FA0 +#xB6A3 #x50D1 +#xB6A4 #x5147 +#xB6A5 #x7AF6 +#xB6A6 #x5171 +#xB6A7 #x51F6 +#xB6A8 #x5354 +#xB6A9 #x5321 +#xB6AA #x537F +#xB6AB #x53EB +#xB6AC #x55AC +#xB6AD #x5883 +#xB6AE #x5CE1 +#xB6AF #x5F37 +#xB6B0 #x5F4A +#xB6B1 #x602F +#xB6B2 #x6050 +#xB6B3 #x606D +#xB6B4 #x631F +#xB6B5 #x6559 +#xB6B6 #x6A4B +#xB6B7 #x6CC1 +#xB6B8 #x72C2 +#xB6B9 #x72ED +#xB6BA #x77EF +#xB6BB #x80F8 +#xB6BC #x8105 +#xB6BD #x8208 +#xB6BE #x854E +#xB6BF #x90F7 +#xB6C0 #x93E1 +#xB6C1 #x97FF +#xB6C2 #x9957 +#xB6C3 #x9A5A +#xB6C4 #x4EF0 +#xB6C5 #x51DD +#xB6C6 #x5C2D +#xB6C7 #x6681 +#xB6C8 #x696D +#xB6C9 #x5C40 +#xB6CA #x66F2 +#xB6CB #x6975 +#xB6CC #x7389 +#xB6CD #x6850 +#xB6CE #x7C81 +#xB6CF #x50C5 +#xB6D0 #x52E4 +#xB6D1 #x5747 +#xB6D2 #x5DFE +#xB6D3 #x9326 +#xB6D4 #x65A4 +#xB6D5 #x6B23 +#xB6D6 #x6B3D +#xB6D7 #x7434 +#xB6D8 #x7981 +#xB6D9 #x79BD +#xB6DA #x7B4B +#xB6DB #x7DCA +#xB6DC #x82B9 +#xB6DD #x83CC +#xB6DE #x887F +#xB6DF #x895F +#xB6E0 #x8B39 +#xB6E1 #x8FD1 +#xB6E2 #x91D1 +#xB6E3 #x541F +#xB6E4 #x9280 +#xB6E5 #x4E5D +#xB6E6 #x5036 +#xB6E7 #x53E5 +#xB6E8 #x533A +#xB6E9 #x72D7 +#xB6EA #x7396 +#xB6EB #x77E9 +#xB6EC #x82E6 +#xB6ED #x8EAF +#xB6EE #x99C6 +#xB6EF #x99C8 +#xB6F0 #x99D2 +#xB6F1 #x5177 +#xB6F2 #x611A +#xB6F3 #x865E +#xB6F4 #x55B0 +#xB6F5 #x7A7A +#xB6F6 #x5076 +#xB6F7 #x5BD3 +#xB6F8 #x9047 +#xB6F9 #x9685 +#xB6FA #x4E32 +#xB6FB #x6ADB +#xB6FC #x91E7 +#xB6FD #x5C51 +#xB6FE #x5C48 +#xB7A1 #x6398 +#xB7A2 #x7A9F +#xB7A3 #x6C93 +#xB7A4 #x9774 +#xB7A5 #x8F61 +#xB7A6 #x7AAA +#xB7A7 #x718A +#xB7A8 #x9688 +#xB7A9 #x7C82 +#xB7AA #x6817 +#xB7AB #x7E70 +#xB7AC #x6851 +#xB7AD #x936C +#xB7AE #x52F2 +#xB7AF #x541B +#xB7B0 #x85AB +#xB7B1 #x8A13 +#xB7B2 #x7FA4 +#xB7B3 #x8ECD +#xB7B4 #x90E1 +#xB7B5 #x5366 +#xB7B6 #x8888 +#xB7B7 #x7941 +#xB7B8 #x4FC2 +#xB7B9 #x50BE +#xB7BA #x5211 +#xB7BB #x5144 +#xB7BC #x5553 +#xB7BD #x572D +#xB7BE #x73EA +#xB7BF #x578B +#xB7C0 #x5951 +#xB7C1 #x5F62 +#xB7C2 #x5F84 +#xB7C3 #x6075 +#xB7C4 #x6176 +#xB7C5 #x6167 +#xB7C6 #x61A9 +#xB7C7 #x63B2 +#xB7C8 #x643A +#xB7C9 #x656C +#xB7CA #x666F +#xB7CB #x6842 +#xB7CC #x6E13 +#xB7CD #x7566 +#xB7CE #x7A3D +#xB7CF #x7CFB +#xB7D0 #x7D4C +#xB7D1 #x7D99 +#xB7D2 #x7E4B +#xB7D3 #x7F6B +#xB7D4 #x830E +#xB7D5 #x834A +#xB7D6 #x86CD +#xB7D7 #x8A08 +#xB7D8 #x8A63 +#xB7D9 #x8B66 +#xB7DA #x8EFD +#xB7DB #x981A +#xB7DC #x9D8F +#xB7DD #x82B8 +#xB7DE #x8FCE +#xB7DF #x9BE8 +#xB7E0 #x5287 +#xB7E1 #x621F +#xB7E2 #x6483 +#xB7E3 #x6FC0 +#xB7E4 #x9699 +#xB7E5 #x6841 +#xB7E6 #x5091 +#xB7E7 #x6B20 +#xB7E8 #x6C7A +#xB7E9 #x6F54 +#xB7EA #x7A74 +#xB7EB #x7D50 +#xB7EC #x8840 +#xB7ED #x8A23 +#xB7EE #x6708 +#xB7EF #x4EF6 +#xB7F0 #x5039 +#xB7F1 #x5026 +#xB7F2 #x5065 +#xB7F3 #x517C +#xB7F4 #x5238 +#xB7F5 #x5263 +#xB7F6 #x55A7 +#xB7F7 #x570F +#xB7F8 #x5805 +#xB7F9 #x5ACC +#xB7FA #x5EFA +#xB7FB #x61B2 +#xB7FC #x61F8 +#xB7FD #x62F3 +#xB7FE #x6372 +#xB8A1 #x691C +#xB8A2 #x6A29 +#xB8A3 #x727D +#xB8A4 #x72AC +#xB8A5 #x732E +#xB8A6 #x7814 +#xB8A7 #x786F +#xB8A8 #x7D79 +#xB8A9 #x770C +#xB8AA #x80A9 +#xB8AB #x898B +#xB8AC #x8B19 +#xB8AD #x8CE2 +#xB8AE #x8ED2 +#xB8AF #x9063 +#xB8B0 #x9375 +#xB8B1 #x967A +#xB8B2 #x9855 +#xB8B3 #x9A13 +#xB8B4 #x9E78 +#xB8B5 #x5143 +#xB8B6 #x539F +#xB8B7 #x53B3 +#xB8B8 #x5E7B +#xB8B9 #x5F26 +#xB8BA #x6E1B +#xB8BB #x6E90 +#xB8BC #x7384 +#xB8BD #x73FE +#xB8BE #x7D43 +#xB8BF #x8237 +#xB8C0 #x8A00 +#xB8C1 #x8AFA +#xB8C2 #x9650 +#xB8C3 #x4E4E +#xB8C4 #x500B +#xB8C5 #x53E4 +#xB8C6 #x547C +#xB8C7 #x56FA +#xB8C8 #x59D1 +#xB8C9 #x5B64 +#xB8CA #x5DF1 +#xB8CB #x5EAB +#xB8CC #x5F27 +#xB8CD #x6238 +#xB8CE #x6545 +#xB8CF #x67AF +#xB8D0 #x6E56 +#xB8D1 #x72D0 +#xB8D2 #x7CCA +#xB8D3 #x88B4 +#xB8D4 #x80A1 +#xB8D5 #x80E1 +#xB8D6 #x83F0 +#xB8D7 #x864E +#xB8D8 #x8A87 +#xB8D9 #x8DE8 +#xB8DA #x9237 +#xB8DB #x96C7 +#xB8DC #x9867 +#xB8DD #x9F13 +#xB8DE #x4E94 +#xB8DF #x4E92 +#xB8E0 #x4F0D +#xB8E1 #x5348 +#xB8E2 #x5449 +#xB8E3 #x543E +#xB8E4 #x5A2F +#xB8E5 #x5F8C +#xB8E6 #x5FA1 +#xB8E7 #x609F +#xB8E8 #x68A7 +#xB8E9 #x6A8E +#xB8EA #x745A +#xB8EB #x7881 +#xB8EC #x8A9E +#xB8ED #x8AA4 +#xB8EE #x8B77 +#xB8EF #x9190 +#xB8F0 #x4E5E +#xB8F1 #x9BC9 +#xB8F2 #x4EA4 +#xB8F3 #x4F7C +#xB8F4 #x4FAF +#xB8F5 #x5019 +#xB8F6 #x5016 +#xB8F7 #x5149 +#xB8F8 #x516C +#xB8F9 #x529F +#xB8FA #x52B9 +#xB8FB #x52FE +#xB8FC #x539A +#xB8FD #x53E3 +#xB8FE #x5411 +#xB9A1 #x540E +#xB9A2 #x5589 +#xB9A3 #x5751 +#xB9A4 #x57A2 +#xB9A5 #x597D +#xB9A6 #x5B54 +#xB9A7 #x5B5D +#xB9A8 #x5B8F +#xB9A9 #x5DE5 +#xB9AA #x5DE7 +#xB9AB #x5DF7 +#xB9AC #x5E78 +#xB9AD #x5E83 +#xB9AE #x5E9A +#xB9AF #x5EB7 +#xB9B0 #x5F18 +#xB9B1 #x6052 +#xB9B2 #x614C +#xB9B3 #x6297 +#xB9B4 #x62D8 +#xB9B5 #x63A7 +#xB9B6 #x653B +#xB9B7 #x6602 +#xB9B8 #x6643 +#xB9B9 #x66F4 +#xB9BA #x676D +#xB9BB #x6821 +#xB9BC #x6897 +#xB9BD #x69CB +#xB9BE #x6C5F +#xB9BF #x6D2A +#xB9C0 #x6D69 +#xB9C1 #x6E2F +#xB9C2 #x6E9D +#xB9C3 #x7532 +#xB9C4 #x7687 +#xB9C5 #x786C +#xB9C6 #x7A3F +#xB9C7 #x7CE0 +#xB9C8 #x7D05 +#xB9C9 #x7D18 +#xB9CA #x7D5E +#xB9CB #x7DB1 +#xB9CC #x8015 +#xB9CD #x8003 +#xB9CE #x80AF +#xB9CF #x80B1 +#xB9D0 #x8154 +#xB9D1 #x818F +#xB9D2 #x822A +#xB9D3 #x8352 +#xB9D4 #x884C +#xB9D5 #x8861 +#xB9D6 #x8B1B +#xB9D7 #x8CA2 +#xB9D8 #x8CFC +#xB9D9 #x90CA +#xB9DA #x9175 +#xB9DB #x9271 +#xB9DC #x783F +#xB9DD #x92FC +#xB9DE #x95A4 +#xB9DF #x964D +#xB9E0 #x9805 +#xB9E1 #x9999 +#xB9E2 #x9AD8 +#xB9E3 #x9D3B +#xB9E4 #x525B +#xB9E5 #x52AB +#xB9E6 #x53F7 +#xB9E7 #x5408 +#xB9E8 #x58D5 +#xB9E9 #x62F7 +#xB9EA #x6FE0 +#xB9EB #x8C6A +#xB9EC #x8F5F +#xB9ED #x9EB9 +#xB9EE #x514B +#xB9EF #x523B +#xB9F0 #x544A +#xB9F1 #x56FD +#xB9F2 #x7A40 +#xB9F3 #x9177 +#xB9F4 #x9D60 +#xB9F5 #x9ED2 +#xB9F6 #x7344 +#xB9F7 #x6F09 +#xB9F8 #x8170 +#xB9F9 #x7511 +#xB9FA #x5FFD +#xB9FB #x60DA +#xB9FC #x9AA8 +#xB9FD #x72DB +#xB9FE #x8FBC +#xBAA1 #x6B64 +#xBAA2 #x9803 +#xBAA3 #x4ECA +#xBAA4 #x56F0 +#xBAA5 #x5764 +#xBAA6 #x58BE +#xBAA7 #x5A5A +#xBAA8 #x6068 +#xBAA9 #x61C7 +#xBAAA #x660F +#xBAAB #x6606 +#xBAAC #x6839 +#xBAAD #x68B1 +#xBAAE #x6DF7 +#xBAAF #x75D5 +#xBAB0 #x7D3A +#xBAB1 #x826E +#xBAB2 #x9B42 +#xBAB3 #x4E9B +#xBAB4 #x4F50 +#xBAB5 #x53C9 +#xBAB6 #x5506 +#xBAB7 #x5D6F +#xBAB8 #x5DE6 +#xBAB9 #x5DEE +#xBABA #x67FB +#xBABB #x6C99 +#xBABC #x7473 +#xBABD #x7802 +#xBABE #x8A50 +#xBABF #x9396 +#xBAC0 #x88DF +#xBAC1 #x5750 +#xBAC2 #x5EA7 +#xBAC3 #x632B +#xBAC4 #x50B5 +#xBAC5 #x50AC +#xBAC6 #x518D +#xBAC7 #x6700 +#xBAC8 #x54C9 +#xBAC9 #x585E +#xBACA #x59BB +#xBACB #x5BB0 +#xBACC #x5F69 +#xBACD #x624D +#xBACE #x63A1 +#xBACF #x683D +#xBAD0 #x6B73 +#xBAD1 #x6E08 +#xBAD2 #x707D +#xBAD3 #x91C7 +#xBAD4 #x7280 +#xBAD5 #x7815 +#xBAD6 #x7826 +#xBAD7 #x796D +#xBAD8 #x658E +#xBAD9 #x7D30 +#xBADA #x83DC +#xBADB #x88C1 +#xBADC #x8F09 +#xBADD #x969B +#xBADE #x5264 +#xBADF #x5728 +#xBAE0 #x6750 +#xBAE1 #x7F6A +#xBAE2 #x8CA1 +#xBAE3 #x51B4 +#xBAE4 #x5742 +#xBAE5 #x962A +#xBAE6 #x583A +#xBAE7 #x698A +#xBAE8 #x80B4 +#xBAE9 #x54B2 +#xBAEA #x5D0E +#xBAEB #x57FC +#xBAEC #x7895 +#xBAED #x9DFA +#xBAEE #x4F5C +#xBAEF #x524A +#xBAF0 #x548B +#xBAF1 #x643E +#xBAF2 #x6628 +#xBAF3 #x6714 +#xBAF4 #x67F5 +#xBAF5 #x7A84 +#xBAF6 #x7B56 +#xBAF7 #x7D22 +#xBAF8 #x932F +#xBAF9 #x685C +#xBAFA #x9BAD +#xBAFB #x7B39 +#xBAFC #x5319 +#xBAFD #x518A +#xBAFE #x5237 +#xBBA1 #x5BDF +#xBBA2 #x62F6 +#xBBA3 #x64AE +#xBBA4 #x64E6 +#xBBA5 #x672D +#xBBA6 #x6BBA +#xBBA7 #x85A9 +#xBBA8 #x96D1 +#xBBA9 #x7690 +#xBBAA #x9BD6 +#xBBAB #x634C +#xBBAC #x9306 +#xBBAD #x9BAB +#xBBAE #x76BF +#xBBAF #x6652 +#xBBB0 #x4E09 +#xBBB1 #x5098 +#xBBB2 #x53C2 +#xBBB3 #x5C71 +#xBBB4 #x60E8 +#xBBB5 #x6492 +#xBBB6 #x6563 +#xBBB7 #x685F +#xBBB8 #x71E6 +#xBBB9 #x73CA +#xBBBA #x7523 +#xBBBB #x7B97 +#xBBBC #x7E82 +#xBBBD #x8695 +#xBBBE #x8B83 +#xBBBF #x8CDB +#xBBC0 #x9178 +#xBBC1 #x9910 +#xBBC2 #x65AC +#xBBC3 #x66AB +#xBBC4 #x6B8B +#xBBC5 #x4ED5 +#xBBC6 #x4ED4 +#xBBC7 #x4F3A +#xBBC8 #x4F7F +#xBBC9 #x523A +#xBBCA #x53F8 +#xBBCB #x53F2 +#xBBCC #x55E3 +#xBBCD #x56DB +#xBBCE #x58EB +#xBBCF #x59CB +#xBBD0 #x59C9 +#xBBD1 #x59FF +#xBBD2 #x5B50 +#xBBD3 #x5C4D +#xBBD4 #x5E02 +#xBBD5 #x5E2B +#xBBD6 #x5FD7 +#xBBD7 #x601D +#xBBD8 #x6307 +#xBBD9 #x652F +#xBBDA #x5B5C +#xBBDB #x65AF +#xBBDC #x65BD +#xBBDD #x65E8 +#xBBDE #x679D +#xBBDF #x6B62 +#xBBE0 #x6B7B +#xBBE1 #x6C0F +#xBBE2 #x7345 +#xBBE3 #x7949 +#xBBE4 #x79C1 +#xBBE5 #x7CF8 +#xBBE6 #x7D19 +#xBBE7 #x7D2B +#xBBE8 #x80A2 +#xBBE9 #x8102 +#xBBEA #x81F3 +#xBBEB #x8996 +#xBBEC #x8A5E +#xBBED #x8A69 +#xBBEE #x8A66 +#xBBEF #x8A8C +#xBBF0 #x8AEE +#xBBF1 #x8CC7 +#xBBF2 #x8CDC +#xBBF3 #x96CC +#xBBF4 #x98FC +#xBBF5 #x6B6F +#xBBF6 #x4E8B +#xBBF7 #x4F3C +#xBBF8 #x4F8D +#xBBF9 #x5150 +#xBBFA #x5B57 +#xBBFB #x5BFA +#xBBFC #x6148 +#xBBFD #x6301 +#xBBFE #x6642 +#xBCA1 #x6B21 +#xBCA2 #x6ECB +#xBCA3 #x6CBB +#xBCA4 #x723E +#xBCA5 #x74BD +#xBCA6 #x75D4 +#xBCA7 #x78C1 +#xBCA8 #x793A +#xBCA9 #x800C +#xBCAA #x8033 +#xBCAB #x81EA +#xBCAC #x8494 +#xBCAD #x8F9E +#xBCAE #x6C50 +#xBCAF #x9E7F +#xBCB0 #x5F0F +#xBCB1 #x8B58 +#xBCB2 #x9D2B +#xBCB3 #x7AFA +#xBCB4 #x8EF8 +#xBCB5 #x5B8D +#xBCB6 #x96EB +#xBCB7 #x4E03 +#xBCB8 #x53F1 +#xBCB9 #x57F7 +#xBCBA #x5931 +#xBCBB #x5AC9 +#xBCBC #x5BA4 +#xBCBD #x6089 +#xBCBE #x6E7F +#xBCBF #x6F06 +#xBCC0 #x75BE +#xBCC1 #x8CEA +#xBCC2 #x5B9F +#xBCC3 #x8500 +#xBCC4 #x7BE0 +#xBCC5 #x5072 +#xBCC6 #x67F4 +#xBCC7 #x829D +#xBCC8 #x5C61 +#xBCC9 #x854A +#xBCCA #x7E1E +#xBCCB #x820E +#xBCCC #x5199 +#xBCCD #x5C04 +#xBCCE #x6368 +#xBCCF #x8D66 +#xBCD0 #x659C +#xBCD1 #x716E +#xBCD2 #x793E +#xBCD3 #x7D17 +#xBCD4 #x8005 +#xBCD5 #x8B1D +#xBCD6 #x8ECA +#xBCD7 #x906E +#xBCD8 #x86C7 +#xBCD9 #x90AA +#xBCDA #x501F +#xBCDB #x52FA +#xBCDC #x5C3A +#xBCDD #x6753 +#xBCDE #x707C +#xBCDF #x7235 +#xBCE0 #x914C +#xBCE1 #x91C8 +#xBCE2 #x932B +#xBCE3 #x82E5 +#xBCE4 #x5BC2 +#xBCE5 #x5F31 +#xBCE6 #x60F9 +#xBCE7 #x4E3B +#xBCE8 #x53D6 +#xBCE9 #x5B88 +#xBCEA #x624B +#xBCEB #x6731 +#xBCEC #x6B8A +#xBCED #x72E9 +#xBCEE #x73E0 +#xBCEF #x7A2E +#xBCF0 #x816B +#xBCF1 #x8DA3 +#xBCF2 #x9152 +#xBCF3 #x9996 +#xBCF4 #x5112 +#xBCF5 #x53D7 +#xBCF6 #x546A +#xBCF7 #x5BFF +#xBCF8 #x6388 +#xBCF9 #x6A39 +#xBCFA #x7DAC +#xBCFB #x9700 +#xBCFC #x56DA +#xBCFD #x53CE +#xBCFE #x5468 +#xBDA1 #x5B97 +#xBDA2 #x5C31 +#xBDA3 #x5DDE +#xBDA4 #x4FEE +#xBDA5 #x6101 +#xBDA6 #x62FE +#xBDA7 #x6D32 +#xBDA8 #x79C0 +#xBDA9 #x79CB +#xBDAA #x7D42 +#xBDAB #x7E4D +#xBDAC #x7FD2 +#xBDAD #x81ED +#xBDAE #x821F +#xBDAF #x8490 +#xBDB0 #x8846 +#xBDB1 #x8972 +#xBDB2 #x8B90 +#xBDB3 #x8E74 +#xBDB4 #x8F2F +#xBDB5 #x9031 +#xBDB6 #x914B +#xBDB7 #x916C +#xBDB8 #x96C6 +#xBDB9 #x919C +#xBDBA #x4EC0 +#xBDBB #x4F4F +#xBDBC #x5145 +#xBDBD #x5341 +#xBDBE #x5F93 +#xBDBF #x620E +#xBDC0 #x67D4 +#xBDC1 #x6C41 +#xBDC2 #x6E0B +#xBDC3 #x7363 +#xBDC4 #x7E26 +#xBDC5 #x91CD +#xBDC6 #x9283 +#xBDC7 #x53D4 +#xBDC8 #x5919 +#xBDC9 #x5BBF +#xBDCA #x6DD1 +#xBDCB #x795D +#xBDCC #x7E2E +#xBDCD #x7C9B +#xBDCE #x587E +#xBDCF #x719F +#xBDD0 #x51FA +#xBDD1 #x8853 +#xBDD2 #x8FF0 +#xBDD3 #x4FCA +#xBDD4 #x5CFB +#xBDD5 #x6625 +#xBDD6 #x77AC +#xBDD7 #x7AE3 +#xBDD8 #x821C +#xBDD9 #x99FF +#xBDDA #x51C6 +#xBDDB #x5FAA +#xBDDC #x65EC +#xBDDD #x696F +#xBDDE #x6B89 +#xBDDF #x6DF3 +#xBDE0 #x6E96 +#xBDE1 #x6F64 +#xBDE2 #x76FE +#xBDE3 #x7D14 +#xBDE4 #x5DE1 +#xBDE5 #x9075 +#xBDE6 #x9187 +#xBDE7 #x9806 +#xBDE8 #x51E6 +#xBDE9 #x521D +#xBDEA #x6240 +#xBDEB #x6691 +#xBDEC #x66D9 +#xBDED #x6E1A +#xBDEE #x5EB6 +#xBDEF #x7DD2 +#xBDF0 #x7F72 +#xBDF1 #x66F8 +#xBDF2 #x85AF +#xBDF3 #x85F7 +#xBDF4 #x8AF8 +#xBDF5 #x52A9 +#xBDF6 #x53D9 +#xBDF7 #x5973 +#xBDF8 #x5E8F +#xBDF9 #x5F90 +#xBDFA #x6055 +#xBDFB #x92E4 +#xBDFC #x9664 +#xBDFD #x50B7 +#xBDFE #x511F +#xBEA1 #x52DD +#xBEA2 #x5320 +#xBEA3 #x5347 +#xBEA4 #x53EC +#xBEA5 #x54E8 +#xBEA6 #x5546 +#xBEA7 #x5531 +#xBEA8 #x5617 +#xBEA9 #x5968 +#xBEAA #x59BE +#xBEAB #x5A3C +#xBEAC #x5BB5 +#xBEAD #x5C06 +#xBEAE #x5C0F +#xBEAF #x5C11 +#xBEB0 #x5C1A +#xBEB1 #x5E84 +#xBEB2 #x5E8A +#xBEB3 #x5EE0 +#xBEB4 #x5F70 +#xBEB5 #x627F +#xBEB6 #x6284 +#xBEB7 #x62DB +#xBEB8 #x638C +#xBEB9 #x6377 +#xBEBA #x6607 +#xBEBB #x660C +#xBEBC #x662D +#xBEBD #x6676 +#xBEBE #x677E +#xBEBF #x68A2 +#xBEC0 #x6A1F +#xBEC1 #x6A35 +#xBEC2 #x6CBC +#xBEC3 #x6D88 +#xBEC4 #x6E09 +#xBEC5 #x6E58 +#xBEC6 #x713C +#xBEC7 #x7126 +#xBEC8 #x7167 +#xBEC9 #x75C7 +#xBECA #x7701 +#xBECB #x785D +#xBECC #x7901 +#xBECD #x7965 +#xBECE #x79F0 +#xBECF #x7AE0 +#xBED0 #x7B11 +#xBED1 #x7CA7 +#xBED2 #x7D39 +#xBED3 #x8096 +#xBED4 #x83D6 +#xBED5 #x848B +#xBED6 #x8549 +#xBED7 #x885D +#xBED8 #x88F3 +#xBED9 #x8A1F +#xBEDA #x8A3C +#xBEDB #x8A54 +#xBEDC #x8A73 +#xBEDD #x8C61 +#xBEDE #x8CDE +#xBEDF #x91A4 +#xBEE0 #x9266 +#xBEE1 #x937E +#xBEE2 #x9418 +#xBEE3 #x969C +#xBEE4 #x9798 +#xBEE5 #x4E0A +#xBEE6 #x4E08 +#xBEE7 #x4E1E +#xBEE8 #x4E57 +#xBEE9 #x5197 +#xBEEA #x5270 +#xBEEB #x57CE +#xBEEC #x5834 +#xBEED #x58CC +#xBEEE #x5B22 +#xBEEF #x5E38 +#xBEF0 #x60C5 +#xBEF1 #x64FE +#xBEF2 #x6761 +#xBEF3 #x6756 +#xBEF4 #x6D44 +#xBEF5 #x72B6 +#xBEF6 #x7573 +#xBEF7 #x7A63 +#xBEF8 #x84B8 +#xBEF9 #x8B72 +#xBEFA #x91B8 +#xBEFB #x9320 +#xBEFC #x5631 +#xBEFD #x57F4 +#xBEFE #x98FE +#xBFA1 #x62ED +#xBFA2 #x690D +#xBFA3 #x6B96 +#xBFA4 #x71ED +#xBFA5 #x7E54 +#xBFA6 #x8077 +#xBFA7 #x8272 +#xBFA8 #x89E6 +#xBFA9 #x98DF +#xBFAA #x8755 +#xBFAB #x8FB1 +#xBFAC #x5C3B +#xBFAD #x4F38 +#xBFAE #x4FE1 +#xBFAF #x4FB5 +#xBFB0 #x5507 +#xBFB1 #x5A20 +#xBFB2 #x5BDD +#xBFB3 #x5BE9 +#xBFB4 #x5FC3 +#xBFB5 #x614E +#xBFB6 #x632F +#xBFB7 #x65B0 +#xBFB8 #x664B +#xBFB9 #x68EE +#xBFBA #x699B +#xBFBB #x6D78 +#xBFBC #x6DF1 +#xBFBD #x7533 +#xBFBE #x75B9 +#xBFBF #x771F +#xBFC0 #x795E +#xBFC1 #x79E6 +#xBFC2 #x7D33 +#xBFC3 #x81E3 +#xBFC4 #x82AF +#xBFC5 #x85AA +#xBFC6 #x89AA +#xBFC7 #x8A3A +#xBFC8 #x8EAB +#xBFC9 #x8F9B +#xBFCA #x9032 +#xBFCB #x91DD +#xBFCC #x9707 +#xBFCD #x4EBA +#xBFCE #x4EC1 +#xBFCF #x5203 +#xBFD0 #x5875 +#xBFD1 #x58EC +#xBFD2 #x5C0B +#xBFD3 #x751A +#xBFD4 #x5C3D +#xBFD5 #x814E +#xBFD6 #x8A0A +#xBFD7 #x8FC5 +#xBFD8 #x9663 +#xBFD9 #x976D +#xBFDA #x7B25 +#xBFDB #x8ACF +#xBFDC #x9808 +#xBFDD #x9162 +#xBFDE #x56F3 +#xBFDF #x53A8 +#xBFE0 #x9017 +#xBFE1 #x5439 +#xBFE2 #x5782 +#xBFE3 #x5E25 +#xBFE4 #x63A8 +#xBFE5 #x6C34 +#xBFE6 #x708A +#xBFE7 #x7761 +#xBFE8 #x7C8B +#xBFE9 #x7FE0 +#xBFEA #x8870 +#xBFEB #x9042 +#xBFEC #x9154 +#xBFED #x9310 +#xBFEE #x9318 +#xBFEF #x968F +#xBFF0 #x745E +#xBFF1 #x9AC4 +#xBFF2 #x5D07 +#xBFF3 #x5D69 +#xBFF4 #x6570 +#xBFF5 #x67A2 +#xBFF6 #x8DA8 +#xBFF7 #x96DB +#xBFF8 #x636E +#xBFF9 #x6749 +#xBFFA #x6919 +#xBFFB #x83C5 +#xBFFC #x9817 +#xBFFD #x96C0 +#xBFFE #x88FE +#xC0A1 #x6F84 +#xC0A2 #x647A +#xC0A3 #x5BF8 +#xC0A4 #x4E16 +#xC0A5 #x702C +#xC0A6 #x755D +#xC0A7 #x662F +#xC0A8 #x51C4 +#xC0A9 #x5236 +#xC0AA #x52E2 +#xC0AB #x59D3 +#xC0AC #x5F81 +#xC0AD #x6027 +#xC0AE #x6210 +#xC0AF #x653F +#xC0B0 #x6574 +#xC0B1 #x661F +#xC0B2 #x6674 +#xC0B3 #x68F2 +#xC0B4 #x6816 +#xC0B5 #x6B63 +#xC0B6 #x6E05 +#xC0B7 #x7272 +#xC0B8 #x751F +#xC0B9 #x76DB +#xC0BA #x7CBE +#xC0BB #x8056 +#xC0BC #x58F0 +#xC0BD #x88FD +#xC0BE #x897F +#xC0BF #x8AA0 +#xC0C0 #x8A93 +#xC0C1 #x8ACB +#xC0C2 #x901D +#xC0C3 #x9192 +#xC0C4 #x9752 +#xC0C5 #x9759 +#xC0C6 #x6589 +#xC0C7 #x7A0E +#xC0C8 #x8106 +#xC0C9 #x96BB +#xC0CA #x5E2D +#xC0CB #x60DC +#xC0CC #x621A +#xC0CD #x65A5 +#xC0CE #x6614 +#xC0CF #x6790 +#xC0D0 #x77F3 +#xC0D1 #x7A4D +#xC0D2 #x7C4D +#xC0D3 #x7E3E +#xC0D4 #x810A +#xC0D5 #x8CAC +#xC0D6 #x8D64 +#xC0D7 #x8DE1 +#xC0D8 #x8E5F +#xC0D9 #x78A9 +#xC0DA #x5207 +#xC0DB #x62D9 +#xC0DC #x63A5 +#xC0DD #x6442 +#xC0DE #x6298 +#xC0DF #x8A2D +#xC0E0 #x7A83 +#xC0E1 #x7BC0 +#xC0E2 #x8AAC +#xC0E3 #x96EA +#xC0E4 #x7D76 +#xC0E5 #x820C +#xC0E6 #x8749 +#xC0E7 #x4ED9 +#xC0E8 #x5148 +#xC0E9 #x5343 +#xC0EA #x5360 +#xC0EB #x5BA3 +#xC0EC #x5C02 +#xC0ED #x5C16 +#xC0EE #x5DDD +#xC0EF #x6226 +#xC0F0 #x6247 +#xC0F1 #x64B0 +#xC0F2 #x6813 +#xC0F3 #x6834 +#xC0F4 #x6CC9 +#xC0F5 #x6D45 +#xC0F6 #x6D17 +#xC0F7 #x67D3 +#xC0F8 #x6F5C +#xC0F9 #x714E +#xC0FA #x717D +#xC0FB #x65CB +#xC0FC #x7A7F +#xC0FD #x7BAD +#xC0FE #x7DDA +#xC1A1 #x7E4A +#xC1A2 #x7FA8 +#xC1A3 #x817A +#xC1A4 #x821B +#xC1A5 #x8239 +#xC1A6 #x85A6 +#xC1A7 #x8A6E +#xC1A8 #x8CCE +#xC1A9 #x8DF5 +#xC1AA #x9078 +#xC1AB #x9077 +#xC1AC #x92AD +#xC1AD #x9291 +#xC1AE #x9583 +#xC1AF #x9BAE +#xC1B0 #x524D +#xC1B1 #x5584 +#xC1B2 #x6F38 +#xC1B3 #x7136 +#xC1B4 #x5168 +#xC1B5 #x7985 +#xC1B6 #x7E55 +#xC1B7 #x81B3 +#xC1B8 #x7CCE +#xC1B9 #x564C +#xC1BA #x5851 +#xC1BB #x5CA8 +#xC1BC #x63AA +#xC1BD #x66FE +#xC1BE #x66FD +#xC1BF #x695A +#xC1C0 #x72D9 +#xC1C1 #x758F +#xC1C2 #x758E +#xC1C3 #x790E +#xC1C4 #x7956 +#xC1C5 #x79DF +#xC1C6 #x7C97 +#xC1C7 #x7D20 +#xC1C8 #x7D44 +#xC1C9 #x8607 +#xC1CA #x8A34 +#xC1CB #x963B +#xC1CC #x9061 +#xC1CD #x9F20 +#xC1CE #x50E7 +#xC1CF #x5275 +#xC1D0 #x53CC +#xC1D1 #x53E2 +#xC1D2 #x5009 +#xC1D3 #x55AA +#xC1D4 #x58EE +#xC1D5 #x594F +#xC1D6 #x723D +#xC1D7 #x5B8B +#xC1D8 #x5C64 +#xC1D9 #x531D +#xC1DA #x60E3 +#xC1DB #x60F3 +#xC1DC #x635C +#xC1DD #x6383 +#xC1DE #x633F +#xC1DF #x63BB +#xC1E0 #x64CD +#xC1E1 #x65E9 +#xC1E2 #x66F9 +#xC1E3 #x5DE3 +#xC1E4 #x69CD +#xC1E5 #x69FD +#xC1E6 #x6F15 +#xC1E7 #x71E5 +#xC1E8 #x4E89 +#xC1E9 #x75E9 +#xC1EA #x76F8 +#xC1EB #x7A93 +#xC1EC #x7CDF +#xC1ED #x7DCF +#xC1EE #x7D9C +#xC1EF #x8061 +#xC1F0 #x8349 +#xC1F1 #x8358 +#xC1F2 #x846C +#xC1F3 #x84BC +#xC1F4 #x85FB +#xC1F5 #x88C5 +#xC1F6 #x8D70 +#xC1F7 #x9001 +#xC1F8 #x906D +#xC1F9 #x9397 +#xC1FA #x971C +#xC1FB #x9A12 +#xC1FC #x50CF +#xC1FD #x5897 +#xC1FE #x618E +#xC2A1 #x81D3 +#xC2A2 #x8535 +#xC2A3 #x8D08 +#xC2A4 #x9020 +#xC2A5 #x4FC3 +#xC2A6 #x5074 +#xC2A7 #x5247 +#xC2A8 #x5373 +#xC2A9 #x606F +#xC2AA #x6349 +#xC2AB #x675F +#xC2AC #x6E2C +#xC2AD #x8DB3 +#xC2AE #x901F +#xC2AF #x4FD7 +#xC2B0 #x5C5E +#xC2B1 #x8CCA +#xC2B2 #x65CF +#xC2B3 #x7D9A +#xC2B4 #x5352 +#xC2B5 #x8896 +#xC2B6 #x5176 +#xC2B7 #x63C3 +#xC2B8 #x5B58 +#xC2B9 #x5B6B +#xC2BA #x5C0A +#xC2BB #x640D +#xC2BC #x6751 +#xC2BD #x905C +#xC2BE #x4ED6 +#xC2BF #x591A +#xC2C0 #x592A +#xC2C1 #x6C70 +#xC2C2 #x8A51 +#xC2C3 #x553E +#xC2C4 #x5815 +#xC2C5 #x59A5 +#xC2C6 #x60F0 +#xC2C7 #x6253 +#xC2C8 #x67C1 +#xC2C9 #x8235 +#xC2CA #x6955 +#xC2CB #x9640 +#xC2CC #x99C4 +#xC2CD #x9A28 +#xC2CE #x4F53 +#xC2CF #x5806 +#xC2D0 #x5BFE +#xC2D1 #x8010 +#xC2D2 #x5CB1 +#xC2D3 #x5E2F +#xC2D4 #x5F85 +#xC2D5 #x6020 +#xC2D6 #x614B +#xC2D7 #x6234 +#xC2D8 #x66FF +#xC2D9 #x6CF0 +#xC2DA #x6EDE +#xC2DB #x80CE +#xC2DC #x817F +#xC2DD #x82D4 +#xC2DE #x888B +#xC2DF #x8CB8 +#xC2E0 #x9000 +#xC2E1 #x902E +#xC2E2 #x968A +#xC2E3 #x9EDB +#xC2E4 #x9BDB +#xC2E5 #x4EE3 +#xC2E6 #x53F0 +#xC2E7 #x5927 +#xC2E8 #x7B2C +#xC2E9 #x918D +#xC2EA #x984C +#xC2EB #x9DF9 +#xC2EC #x6EDD +#xC2ED #x7027 +#xC2EE #x5353 +#xC2EF #x5544 +#xC2F0 #x5B85 +#xC2F1 #x6258 +#xC2F2 #x629E +#xC2F3 #x62D3 +#xC2F4 #x6CA2 +#xC2F5 #x6FEF +#xC2F6 #x7422 +#xC2F7 #x8A17 +#xC2F8 #x9438 +#xC2F9 #x6FC1 +#xC2FA #x8AFE +#xC2FB #x8338 +#xC2FC #x51E7 +#xC2FD #x86F8 +#xC2FE #x53EA +#xC3A1 #x53E9 +#xC3A2 #x4F46 +#xC3A3 #x9054 +#xC3A4 #x8FB0 +#xC3A5 #x596A +#xC3A6 #x8131 +#xC3A7 #x5DFD +#xC3A8 #x7AEA +#xC3A9 #x8FBF +#xC3AA #x68DA +#xC3AB #x8C37 +#xC3AC #x72F8 +#xC3AD #x9C48 +#xC3AE #x6A3D +#xC3AF #x8AB0 +#xC3B0 #x4E39 +#xC3B1 #x5358 +#xC3B2 #x5606 +#xC3B3 #x5766 +#xC3B4 #x62C5 +#xC3B5 #x63A2 +#xC3B6 #x65E6 +#xC3B7 #x6B4E +#xC3B8 #x6DE1 +#xC3B9 #x6E5B +#xC3BA #x70AD +#xC3BB #x77ED +#xC3BC #x7AEF +#xC3BD #x7BAA +#xC3BE #x7DBB +#xC3BF #x803D +#xC3C0 #x80C6 +#xC3C1 #x86CB +#xC3C2 #x8A95 +#xC3C3 #x935B +#xC3C4 #x56E3 +#xC3C5 #x58C7 +#xC3C6 #x5F3E +#xC3C7 #x65AD +#xC3C8 #x6696 +#xC3C9 #x6A80 +#xC3CA #x6BB5 +#xC3CB #x7537 +#xC3CC #x8AC7 +#xC3CD #x5024 +#xC3CE #x77E5 +#xC3CF #x5730 +#xC3D0 #x5F1B +#xC3D1 #x6065 +#xC3D2 #x667A +#xC3D3 #x6C60 +#xC3D4 #x75F4 +#xC3D5 #x7A1A +#xC3D6 #x7F6E +#xC3D7 #x81F4 +#xC3D8 #x8718 +#xC3D9 #x9045 +#xC3DA #x99B3 +#xC3DB #x7BC9 +#xC3DC #x755C +#xC3DD #x7AF9 +#xC3DE #x7B51 +#xC3DF #x84C4 +#xC3E0 #x9010 +#xC3E1 #x79E9 +#xC3E2 #x7A92 +#xC3E3 #x8336 +#xC3E4 #x5AE1 +#xC3E5 #x7740 +#xC3E6 #x4E2D +#xC3E7 #x4EF2 +#xC3E8 #x5B99 +#xC3E9 #x5FE0 +#xC3EA #x62BD +#xC3EB #x663C +#xC3EC #x67F1 +#xC3ED #x6CE8 +#xC3EE #x866B +#xC3EF #x8877 +#xC3F0 #x8A3B +#xC3F1 #x914E +#xC3F2 #x92F3 +#xC3F3 #x99D0 +#xC3F4 #x6A17 +#xC3F5 #x7026 +#xC3F6 #x732A +#xC3F7 #x82E7 +#xC3F8 #x8457 +#xC3F9 #x8CAF +#xC3FA #x4E01 +#xC3FB #x5146 +#xC3FC #x51CB +#xC3FD #x558B +#xC3FE #x5BF5 +#xC4A1 #x5E16 +#xC4A2 #x5E33 +#xC4A3 #x5E81 +#xC4A4 #x5F14 +#xC4A5 #x5F35 +#xC4A6 #x5F6B +#xC4A7 #x5FB4 +#xC4A8 #x61F2 +#xC4A9 #x6311 +#xC4AA #x66A2 +#xC4AB #x671D +#xC4AC #x6F6E +#xC4AD #x7252 +#xC4AE #x753A +#xC4AF #x773A +#xC4B0 #x8074 +#xC4B1 #x8139 +#xC4B2 #x8178 +#xC4B3 #x8776 +#xC4B4 #x8ABF +#xC4B5 #x8ADC +#xC4B6 #x8D85 +#xC4B7 #x8DF3 +#xC4B8 #x929A +#xC4B9 #x9577 +#xC4BA #x9802 +#xC4BB #x9CE5 +#xC4BC #x52C5 +#xC4BD #x6357 +#xC4BE #x76F4 +#xC4BF #x6715 +#xC4C0 #x6C88 +#xC4C1 #x73CD +#xC4C2 #x8CC3 +#xC4C3 #x93AE +#xC4C4 #x9673 +#xC4C5 #x6D25 +#xC4C6 #x589C +#xC4C7 #x690E +#xC4C8 #x69CC +#xC4C9 #x8FFD +#xC4CA #x939A +#xC4CB #x75DB +#xC4CC #x901A +#xC4CD #x585A +#xC4CE #x6802 +#xC4CF #x63B4 +#xC4D0 #x69FB +#xC4D1 #x4F43 +#xC4D2 #x6F2C +#xC4D3 #x67D8 +#xC4D4 #x8FBB +#xC4D5 #x8526 +#xC4D6 #x7DB4 +#xC4D7 #x9354 +#xC4D8 #x693F +#xC4D9 #x6F70 +#xC4DA #x576A +#xC4DB #x58F7 +#xC4DC #x5B2C +#xC4DD #x7D2C +#xC4DE #x722A +#xC4DF #x540A +#xC4E0 #x91E3 +#xC4E1 #x9DB4 +#xC4E2 #x4EAD +#xC4E3 #x4F4E +#xC4E4 #x505C +#xC4E5 #x5075 +#xC4E6 #x5243 +#xC4E7 #x8C9E +#xC4E8 #x5448 +#xC4E9 #x5824 +#xC4EA #x5B9A +#xC4EB #x5E1D +#xC4EC #x5E95 +#xC4ED #x5EAD +#xC4EE #x5EF7 +#xC4EF #x5F1F +#xC4F0 #x608C +#xC4F1 #x62B5 +#xC4F2 #x633A +#xC4F3 #x63D0 +#xC4F4 #x68AF +#xC4F5 #x6C40 +#xC4F6 #x7887 +#xC4F7 #x798E +#xC4F8 #x7A0B +#xC4F9 #x7DE0 +#xC4FA #x8247 +#xC4FB #x8A02 +#xC4FC #x8AE6 +#xC4FD #x8E44 +#xC4FE #x9013 +#xC5A1 #x90B8 +#xC5A2 #x912D +#xC5A3 #x91D8 +#xC5A4 #x9F0E +#xC5A5 #x6CE5 +#xC5A6 #x6458 +#xC5A7 #x64E2 +#xC5A8 #x6575 +#xC5A9 #x6EF4 +#xC5AA #x7684 +#xC5AB #x7B1B +#xC5AC #x9069 +#xC5AD #x93D1 +#xC5AE #x6EBA +#xC5AF #x54F2 +#xC5B0 #x5FB9 +#xC5B1 #x64A4 +#xC5B2 #x8F4D +#xC5B3 #x8FED +#xC5B4 #x9244 +#xC5B5 #x5178 +#xC5B6 #x586B +#xC5B7 #x5929 +#xC5B8 #x5C55 +#xC5B9 #x5E97 +#xC5BA #x6DFB +#xC5BB #x7E8F +#xC5BC #x751C +#xC5BD #x8CBC +#xC5BE #x8EE2 +#xC5BF #x985B +#xC5C0 #x70B9 +#xC5C1 #x4F1D +#xC5C2 #x6BBF +#xC5C3 #x6FB1 +#xC5C4 #x7530 +#xC5C5 #x96FB +#xC5C6 #x514E +#xC5C7 #x5410 +#xC5C8 #x5835 +#xC5C9 #x5857 +#xC5CA #x59AC +#xC5CB #x5C60 +#xC5CC #x5F92 +#xC5CD #x6597 +#xC5CE #x675C +#xC5CF #x6E21 +#xC5D0 #x767B +#xC5D1 #x83DF +#xC5D2 #x8CED +#xC5D3 #x9014 +#xC5D4 #x90FD +#xC5D5 #x934D +#xC5D6 #x7825 +#xC5D7 #x783A +#xC5D8 #x52AA +#xC5D9 #x5EA6 +#xC5DA #x571F +#xC5DB #x5974 +#xC5DC #x6012 +#xC5DD #x5012 +#xC5DE #x515A +#xC5DF #x51AC +#xC5E0 #x51CD +#xC5E1 #x5200 +#xC5E2 #x5510 +#xC5E3 #x5854 +#xC5E4 #x5858 +#xC5E5 #x5957 +#xC5E6 #x5B95 +#xC5E7 #x5CF6 +#xC5E8 #x5D8B +#xC5E9 #x60BC +#xC5EA #x6295 +#xC5EB #x642D +#xC5EC #x6771 +#xC5ED #x6843 +#xC5EE #x68BC +#xC5EF #x68DF +#xC5F0 #x76D7 +#xC5F1 #x6DD8 +#xC5F2 #x6E6F +#xC5F3 #x6D9B +#xC5F4 #x706F +#xC5F5 #x71C8 +#xC5F6 #x5F53 +#xC5F7 #x75D8 +#xC5F8 #x7977 +#xC5F9 #x7B49 +#xC5FA #x7B54 +#xC5FB #x7B52 +#xC5FC #x7CD6 +#xC5FD #x7D71 +#xC5FE #x5230 +#xC6A1 #x8463 +#xC6A2 #x8569 +#xC6A3 #x85E4 +#xC6A4 #x8A0E +#xC6A5 #x8B04 +#xC6A6 #x8C46 +#xC6A7 #x8E0F +#xC6A8 #x9003 +#xC6A9 #x900F +#xC6AA #x9419 +#xC6AB #x9676 +#xC6AC #x982D +#xC6AD #x9A30 +#xC6AE #x95D8 +#xC6AF #x50CD +#xC6B0 #x52D5 +#xC6B1 #x540C +#xC6B2 #x5802 +#xC6B3 #x5C0E +#xC6B4 #x61A7 +#xC6B5 #x649E +#xC6B6 #x6D1E +#xC6B7 #x77B3 +#xC6B8 #x7AE5 +#xC6B9 #x80F4 +#xC6BA #x8404 +#xC6BB #x9053 +#xC6BC #x9285 +#xC6BD #x5CE0 +#xC6BE #x9D07 +#xC6BF #x533F +#xC6C0 #x5F97 +#xC6C1 #x5FB3 +#xC6C2 #x6D9C +#xC6C3 #x7279 +#xC6C4 #x7763 +#xC6C5 #x79BF +#xC6C6 #x7BE4 +#xC6C7 #x6BD2 +#xC6C8 #x72EC +#xC6C9 #x8AAD +#xC6CA #x6803 +#xC6CB #x6A61 +#xC6CC #x51F8 +#xC6CD #x7A81 +#xC6CE #x6934 +#xC6CF #x5C4A +#xC6D0 #x9CF6 +#xC6D1 #x82EB +#xC6D2 #x5BC5 +#xC6D3 #x9149 +#xC6D4 #x701E +#xC6D5 #x5678 +#xC6D6 #x5C6F +#xC6D7 #x60C7 +#xC6D8 #x6566 +#xC6D9 #x6C8C +#xC6DA #x8C5A +#xC6DB #x9041 +#xC6DC #x9813 +#xC6DD #x5451 +#xC6DE #x66C7 +#xC6DF #x920D +#xC6E0 #x5948 +#xC6E1 #x90A3 +#xC6E2 #x5185 +#xC6E3 #x4E4D +#xC6E4 #x51EA +#xC6E5 #x8599 +#xC6E6 #x8B0E +#xC6E7 #x7058 +#xC6E8 #x637A +#xC6E9 #x934B +#xC6EA #x6962 +#xC6EB #x99B4 +#xC6EC #x7E04 +#xC6ED #x7577 +#xC6EE #x5357 +#xC6EF #x6960 +#xC6F0 #x8EDF +#xC6F1 #x96E3 +#xC6F2 #x6C5D +#xC6F3 #x4E8C +#xC6F4 #x5C3C +#xC6F5 #x5F10 +#xC6F6 #x8FE9 +#xC6F7 #x5302 +#xC6F8 #x8CD1 +#xC6F9 #x8089 +#xC6FA #x8679 +#xC6FB #x5EFF +#xC6FC #x65E5 +#xC6FD #x4E73 +#xC6FE #x5165 +#xC7A1 #x5982 +#xC7A2 #x5C3F +#xC7A3 #x97EE +#xC7A4 #x4EFB +#xC7A5 #x598A +#xC7A6 #x5FCD +#xC7A7 #x8A8D +#xC7A8 #x6FE1 +#xC7A9 #x79B0 +#xC7AA #x7962 +#xC7AB #x5BE7 +#xC7AC #x8471 +#xC7AD #x732B +#xC7AE #x71B1 +#xC7AF #x5E74 +#xC7B0 #x5FF5 +#xC7B1 #x637B +#xC7B2 #x649A +#xC7B3 #x71C3 +#xC7B4 #x7C98 +#xC7B5 #x4E43 +#xC7B6 #x5EFC +#xC7B7 #x4E4B +#xC7B8 #x57DC +#xC7B9 #x56A2 +#xC7BA #x60A9 +#xC7BB #x6FC3 +#xC7BC #x7D0D +#xC7BD #x80FD +#xC7BE #x8133 +#xC7BF #x81BF +#xC7C0 #x8FB2 +#xC7C1 #x8997 +#xC7C2 #x86A4 +#xC7C3 #x5DF4 +#xC7C4 #x628A +#xC7C5 #x64AD +#xC7C6 #x8987 +#xC7C7 #x6777 +#xC7C8 #x6CE2 +#xC7C9 #x6D3E +#xC7CA #x7436 +#xC7CB #x7834 +#xC7CC #x5A46 +#xC7CD #x7F75 +#xC7CE #x82AD +#xC7CF #x99AC +#xC7D0 #x4FF3 +#xC7D1 #x5EC3 +#xC7D2 #x62DD +#xC7D3 #x6392 +#xC7D4 #x6557 +#xC7D5 #x676F +#xC7D6 #x76C3 +#xC7D7 #x724C +#xC7D8 #x80CC +#xC7D9 #x80BA +#xC7DA #x8F29 +#xC7DB #x914D +#xC7DC #x500D +#xC7DD #x57F9 +#xC7DE #x5A92 +#xC7DF #x6885 +#xC7E0 #x6973 +#xC7E1 #x7164 +#xC7E2 #x72FD +#xC7E3 #x8CB7 +#xC7E4 #x58F2 +#xC7E5 #x8CE0 +#xC7E6 #x966A +#xC7E7 #x9019 +#xC7E8 #x877F +#xC7E9 #x79E4 +#xC7EA #x77E7 +#xC7EB #x8429 +#xC7EC #x4F2F +#xC7ED #x5265 +#xC7EE #x535A +#xC7EF #x62CD +#xC7F0 #x67CF +#xC7F1 #x6CCA +#xC7F2 #x767D +#xC7F3 #x7B94 +#xC7F4 #x7C95 +#xC7F5 #x8236 +#xC7F6 #x8584 +#xC7F7 #x8FEB +#xC7F8 #x66DD +#xC7F9 #x6F20 +#xC7FA #x7206 +#xC7FB #x7E1B +#xC7FC #x83AB +#xC7FD #x99C1 +#xC7FE #x9EA6 +#xC8A1 #x51FD +#xC8A2 #x7BB1 +#xC8A3 #x7872 +#xC8A4 #x7BB8 +#xC8A5 #x8087 +#xC8A6 #x7B48 +#xC8A7 #x6AE8 +#xC8A8 #x5E61 +#xC8A9 #x808C +#xC8AA #x7551 +#xC8AB #x7560 +#xC8AC #x516B +#xC8AD #x9262 +#xC8AE #x6E8C +#xC8AF #x767A +#xC8B0 #x9197 +#xC8B1 #x9AEA +#xC8B2 #x4F10 +#xC8B3 #x7F70 +#xC8B4 #x629C +#xC8B5 #x7B4F +#xC8B6 #x95A5 +#xC8B7 #x9CE9 +#xC8B8 #x567A +#xC8B9 #x5859 +#xC8BA #x86E4 +#xC8BB #x96BC +#xC8BC #x4F34 +#xC8BD #x5224 +#xC8BE #x534A +#xC8BF #x53CD +#xC8C0 #x53DB +#xC8C1 #x5E06 +#xC8C2 #x642C +#xC8C3 #x6591 +#xC8C4 #x677F +#xC8C5 #x6C3E +#xC8C6 #x6C4E +#xC8C7 #x7248 +#xC8C8 #x72AF +#xC8C9 #x73ED +#xC8CA #x7554 +#xC8CB #x7E41 +#xC8CC #x822C +#xC8CD #x85E9 +#xC8CE #x8CA9 +#xC8CF #x7BC4 +#xC8D0 #x91C6 +#xC8D1 #x7169 +#xC8D2 #x9812 +#xC8D3 #x98EF +#xC8D4 #x633D +#xC8D5 #x6669 +#xC8D6 #x756A +#xC8D7 #x76E4 +#xC8D8 #x78D0 +#xC8D9 #x8543 +#xC8DA #x86EE +#xC8DB #x532A +#xC8DC #x5351 +#xC8DD #x5426 +#xC8DE #x5983 +#xC8DF #x5E87 +#xC8E0 #x5F7C +#xC8E1 #x60B2 +#xC8E2 #x6249 +#xC8E3 #x6279 +#xC8E4 #x62AB +#xC8E5 #x6590 +#xC8E6 #x6BD4 +#xC8E7 #x6CCC +#xC8E8 #x75B2 +#xC8E9 #x76AE +#xC8EA #x7891 +#xC8EB #x79D8 +#xC8EC #x7DCB +#xC8ED #x7F77 +#xC8EE #x80A5 +#xC8EF #x88AB +#xC8F0 #x8AB9 +#xC8F1 #x8CBB +#xC8F2 #x907F +#xC8F3 #x975E +#xC8F4 #x98DB +#xC8F5 #x6A0B +#xC8F6 #x7C38 +#xC8F7 #x5099 +#xC8F8 #x5C3E +#xC8F9 #x5FAE +#xC8FA #x6787 +#xC8FB #x6BD8 +#xC8FC #x7435 +#xC8FD #x7709 +#xC8FE #x7F8E +#xC9A1 #x9F3B +#xC9A2 #x67CA +#xC9A3 #x7A17 +#xC9A4 #x5339 +#xC9A5 #x758B +#xC9A6 #x9AED +#xC9A7 #x5F66 +#xC9A8 #x819D +#xC9A9 #x83F1 +#xC9AA #x8098 +#xC9AB #x5F3C +#xC9AC #x5FC5 +#xC9AD #x7562 +#xC9AE #x7B46 +#xC9AF #x903C +#xC9B0 #x6867 +#xC9B1 #x59EB +#xC9B2 #x5A9B +#xC9B3 #x7D10 +#xC9B4 #x767E +#xC9B5 #x8B2C +#xC9B6 #x4FF5 +#xC9B7 #x5F6A +#xC9B8 #x6A19 +#xC9B9 #x6C37 +#xC9BA #x6F02 +#xC9BB #x74E2 +#xC9BC #x7968 +#xC9BD #x8868 +#xC9BE #x8A55 +#xC9BF #x8C79 +#xC9C0 #x5EDF +#xC9C1 #x63CF +#xC9C2 #x75C5 +#xC9C3 #x79D2 +#xC9C4 #x82D7 +#xC9C5 #x9328 +#xC9C6 #x92F2 +#xC9C7 #x849C +#xC9C8 #x86ED +#xC9C9 #x9C2D +#xC9CA #x54C1 +#xC9CB #x5F6C +#xC9CC #x658C +#xC9CD #x6D5C +#xC9CE #x7015 +#xC9CF #x8CA7 +#xC9D0 #x8CD3 +#xC9D1 #x983B +#xC9D2 #x654F +#xC9D3 #x74F6 +#xC9D4 #x4E0D +#xC9D5 #x4ED8 +#xC9D6 #x57E0 +#xC9D7 #x592B +#xC9D8 #x5A66 +#xC9D9 #x5BCC +#xC9DA #x51A8 +#xC9DB #x5E03 +#xC9DC #x5E9C +#xC9DD #x6016 +#xC9DE #x6276 +#xC9DF #x6577 +#xC9E0 #x65A7 +#xC9E1 #x666E +#xC9E2 #x6D6E +#xC9E3 #x7236 +#xC9E4 #x7B26 +#xC9E5 #x8150 +#xC9E6 #x819A +#xC9E7 #x8299 +#xC9E8 #x8B5C +#xC9E9 #x8CA0 +#xC9EA #x8CE6 +#xC9EB #x8D74 +#xC9EC #x961C +#xC9ED #x9644 +#xC9EE #x4FAE +#xC9EF #x64AB +#xC9F0 #x6B66 +#xC9F1 #x821E +#xC9F2 #x8461 +#xC9F3 #x856A +#xC9F4 #x90E8 +#xC9F5 #x5C01 +#xC9F6 #x6953 +#xC9F7 #x98A8 +#xC9F8 #x847A +#xC9F9 #x8557 +#xC9FA #x4F0F +#xC9FB #x526F +#xC9FC #x5FA9 +#xC9FD #x5E45 +#xC9FE #x670D +#xCAA1 #x798F +#xCAA2 #x8179 +#xCAA3 #x8907 +#xCAA4 #x8986 +#xCAA5 #x6DF5 +#xCAA6 #x5F17 +#xCAA7 #x6255 +#xCAA8 #x6CB8 +#xCAA9 #x4ECF +#xCAAA #x7269 +#xCAAB #x9B92 +#xCAAC #x5206 +#xCAAD #x543B +#xCAAE #x5674 +#xCAAF #x58B3 +#xCAB0 #x61A4 +#xCAB1 #x626E +#xCAB2 #x711A +#xCAB3 #x596E +#xCAB4 #x7C89 +#xCAB5 #x7CDE +#xCAB6 #x7D1B +#xCAB7 #x96F0 +#xCAB8 #x6587 +#xCAB9 #x805E +#xCABA #x4E19 +#xCABB #x4F75 +#xCABC #x5175 +#xCABD #x5840 +#xCABE #x5E63 +#xCABF #x5E73 +#xCAC0 #x5F0A +#xCAC1 #x67C4 +#xCAC2 #x4E26 +#xCAC3 #x853D +#xCAC4 #x9589 +#xCAC5 #x965B +#xCAC6 #x7C73 +#xCAC7 #x9801 +#xCAC8 #x50FB +#xCAC9 #x58C1 +#xCACA #x7656 +#xCACB #x78A7 +#xCACC #x5225 +#xCACD #x77A5 +#xCACE #x8511 +#xCACF #x7B86 +#xCAD0 #x504F +#xCAD1 #x5909 +#xCAD2 #x7247 +#xCAD3 #x7BC7 +#xCAD4 #x7DE8 +#xCAD5 #x8FBA +#xCAD6 #x8FD4 +#xCAD7 #x904D +#xCAD8 #x4FBF +#xCAD9 #x52C9 +#xCADA #x5A29 +#xCADB #x5F01 +#xCADC #x97AD +#xCADD #x4FDD +#xCADE #x8217 +#xCADF #x92EA +#xCAE0 #x5703 +#xCAE1 #x6355 +#xCAE2 #x6B69 +#xCAE3 #x752B +#xCAE4 #x88DC +#xCAE5 #x8F14 +#xCAE6 #x7A42 +#xCAE7 #x52DF +#xCAE8 #x5893 +#xCAE9 #x6155 +#xCAEA #x620A +#xCAEB #x66AE +#xCAEC #x6BCD +#xCAED #x7C3F +#xCAEE #x83E9 +#xCAEF #x5023 +#xCAF0 #x4FF8 +#xCAF1 #x5305 +#xCAF2 #x5446 +#xCAF3 #x5831 +#xCAF4 #x5949 +#xCAF5 #x5B9D +#xCAF6 #x5CF0 +#xCAF7 #x5CEF +#xCAF8 #x5D29 +#xCAF9 #x5E96 +#xCAFA #x62B1 +#xCAFB #x6367 +#xCAFC #x653E +#xCAFD #x65B9 +#xCAFE #x670B +#xCBA1 #x6CD5 +#xCBA2 #x6CE1 +#xCBA3 #x70F9 +#xCBA4 #x7832 +#xCBA5 #x7E2B +#xCBA6 #x80DE +#xCBA7 #x82B3 +#xCBA8 #x840C +#xCBA9 #x84EC +#xCBAA #x8702 +#xCBAB #x8912 +#xCBAC #x8A2A +#xCBAD #x8C4A +#xCBAE #x90A6 +#xCBAF #x92D2 +#xCBB0 #x98FD +#xCBB1 #x9CF3 +#xCBB2 #x9D6C +#xCBB3 #x4E4F +#xCBB4 #x4EA1 +#xCBB5 #x508D +#xCBB6 #x5256 +#xCBB7 #x574A +#xCBB8 #x59A8 +#xCBB9 #x5E3D +#xCBBA #x5FD8 +#xCBBB #x5FD9 +#xCBBC #x623F +#xCBBD #x66B4 +#xCBBE #x671B +#xCBBF #x67D0 +#xCBC0 #x68D2 +#xCBC1 #x5192 +#xCBC2 #x7D21 +#xCBC3 #x80AA +#xCBC4 #x81A8 +#xCBC5 #x8B00 +#xCBC6 #x8C8C +#xCBC7 #x8CBF +#xCBC8 #x927E +#xCBC9 #x9632 +#xCBCA #x5420 +#xCBCB #x982C +#xCBCC #x5317 +#xCBCD #x50D5 +#xCBCE #x535C +#xCBCF #x58A8 +#xCBD0 #x64B2 +#xCBD1 #x6734 +#xCBD2 #x7267 +#xCBD3 #x7766 +#xCBD4 #x7A46 +#xCBD5 #x91E6 +#xCBD6 #x52C3 +#xCBD7 #x6CA1 +#xCBD8 #x6B86 +#xCBD9 #x5800 +#xCBDA #x5E4C +#xCBDB #x5954 +#xCBDC #x672C +#xCBDD #x7FFB +#xCBDE #x51E1 +#xCBDF #x76C6 +#xCBE0 #x6469 +#xCBE1 #x78E8 +#xCBE2 #x9B54 +#xCBE3 #x9EBB +#xCBE4 #x57CB +#xCBE5 #x59B9 +#xCBE6 #x6627 +#xCBE7 #x679A +#xCBE8 #x6BCE +#xCBE9 #x54E9 +#xCBEA #x69D9 +#xCBEB #x5E55 +#xCBEC #x819C +#xCBED #x6795 +#xCBEE #x9BAA +#xCBEF #x67FE +#xCBF0 #x9C52 +#xCBF1 #x685D +#xCBF2 #x4EA6 +#xCBF3 #x4FE3 +#xCBF4 #x53C8 +#xCBF5 #x62B9 +#xCBF6 #x672B +#xCBF7 #x6CAB +#xCBF8 #x8FC4 +#xCBF9 #x4FAD +#xCBFA #x7E6D +#xCBFB #x9EBF +#xCBFC #x4E07 +#xCBFD #x6162 +#xCBFE #x6E80 +#xCCA1 #x6F2B +#xCCA2 #x8513 +#xCCA3 #x5473 +#xCCA4 #x672A +#xCCA5 #x9B45 +#xCCA6 #x5DF3 +#xCCA7 #x7B95 +#xCCA8 #x5CAC +#xCCA9 #x5BC6 +#xCCAA #x871C +#xCCAB #x6E4A +#xCCAC #x84D1 +#xCCAD #x7A14 +#xCCAE #x8108 +#xCCAF #x5999 +#xCCB0 #x7C8D +#xCCB1 #x6C11 +#xCCB2 #x7720 +#xCCB3 #x52D9 +#xCCB4 #x5922 +#xCCB5 #x7121 +#xCCB6 #x725F +#xCCB7 #x77DB +#xCCB8 #x9727 +#xCCB9 #x9D61 +#xCCBA #x690B +#xCCBB #x5A7F +#xCCBC #x5A18 +#xCCBD #x51A5 +#xCCBE #x540D +#xCCBF #x547D +#xCCC0 #x660E +#xCCC1 #x76DF +#xCCC2 #x8FF7 +#xCCC3 #x9298 +#xCCC4 #x9CF4 +#xCCC5 #x59EA +#xCCC6 #x725D +#xCCC7 #x6EC5 +#xCCC8 #x514D +#xCCC9 #x68C9 +#xCCCA #x7DBF +#xCCCB #x7DEC +#xCCCC #x9762 +#xCCCD #x9EBA +#xCCCE #x6478 +#xCCCF #x6A21 +#xCCD0 #x8302 +#xCCD1 #x5984 +#xCCD2 #x5B5F +#xCCD3 #x6BDB +#xCCD4 #x731B +#xCCD5 #x76F2 +#xCCD6 #x7DB2 +#xCCD7 #x8017 +#xCCD8 #x8499 +#xCCD9 #x5132 +#xCCDA #x6728 +#xCCDB #x9ED9 +#xCCDC #x76EE +#xCCDD #x6762 +#xCCDE #x52FF +#xCCDF #x9905 +#xCCE0 #x5C24 +#xCCE1 #x623B +#xCCE2 #x7C7E +#xCCE3 #x8CB0 +#xCCE4 #x554F +#xCCE5 #x60B6 +#xCCE6 #x7D0B +#xCCE7 #x9580 +#xCCE8 #x5301 +#xCCE9 #x4E5F +#xCCEA #x51B6 +#xCCEB #x591C +#xCCEC #x723A +#xCCED #x8036 +#xCCEE #x91CE +#xCCEF #x5F25 +#xCCF0 #x77E2 +#xCCF1 #x5384 +#xCCF2 #x5F79 +#xCCF3 #x7D04 +#xCCF4 #x85AC +#xCCF5 #x8A33 +#xCCF6 #x8E8D +#xCCF7 #x9756 +#xCCF8 #x67F3 +#xCCF9 #x85AE +#xCCFA #x9453 +#xCCFB #x6109 +#xCCFC #x6108 +#xCCFD #x6CB9 +#xCCFE #x7652 +#xCDA1 #x8AED +#xCDA2 #x8F38 +#xCDA3 #x552F +#xCDA4 #x4F51 +#xCDA5 #x512A +#xCDA6 #x52C7 +#xCDA7 #x53CB +#xCDA8 #x5BA5 +#xCDA9 #x5E7D +#xCDAA #x60A0 +#xCDAB #x6182 +#xCDAC #x63D6 +#xCDAD #x6709 +#xCDAE #x67DA +#xCDAF #x6E67 +#xCDB0 #x6D8C +#xCDB1 #x7336 +#xCDB2 #x7337 +#xCDB3 #x7531 +#xCDB4 #x7950 +#xCDB5 #x88D5 +#xCDB6 #x8A98 +#xCDB7 #x904A +#xCDB8 #x9091 +#xCDB9 #x90F5 +#xCDBA #x96C4 +#xCDBB #x878D +#xCDBC #x5915 +#xCDBD #x4E88 +#xCDBE #x4F59 +#xCDBF #x4E0E +#xCDC0 #x8A89 +#xCDC1 #x8F3F +#xCDC2 #x9810 +#xCDC3 #x50AD +#xCDC4 #x5E7C +#xCDC5 #x5996 +#xCDC6 #x5BB9 +#xCDC7 #x5EB8 +#xCDC8 #x63DA +#xCDC9 #x63FA +#xCDCA #x64C1 +#xCDCB #x66DC +#xCDCC #x694A +#xCDCD #x69D8 +#xCDCE #x6D0B +#xCDCF #x6EB6 +#xCDD0 #x7194 +#xCDD1 #x7528 +#xCDD2 #x7AAF +#xCDD3 #x7F8A +#xCDD4 #x8000 +#xCDD5 #x8449 +#xCDD6 #x84C9 +#xCDD7 #x8981 +#xCDD8 #x8B21 +#xCDD9 #x8E0A +#xCDDA #x9065 +#xCDDB #x967D +#xCDDC #x990A +#xCDDD #x617E +#xCDDE #x6291 +#xCDDF #x6B32 +#xCDE0 #x6C83 +#xCDE1 #x6D74 +#xCDE2 #x7FCC +#xCDE3 #x7FFC +#xCDE4 #x6DC0 +#xCDE5 #x7F85 +#xCDE6 #x87BA +#xCDE7 #x88F8 +#xCDE8 #x6765 +#xCDE9 #x83B1 +#xCDEA #x983C +#xCDEB #x96F7 +#xCDEC #x6D1B +#xCDED #x7D61 +#xCDEE #x843D +#xCDEF #x916A +#xCDF0 #x4E71 +#xCDF1 #x5375 +#xCDF2 #x5D50 +#xCDF3 #x6B04 +#xCDF4 #x6FEB +#xCDF5 #x85CD +#xCDF6 #x862D +#xCDF7 #x89A7 +#xCDF8 #x5229 +#xCDF9 #x540F +#xCDFA #x5C65 +#xCDFB #x674E +#xCDFC #x68A8 +#xCDFD #x7406 +#xCDFE #x7483 +#xCEA1 #x75E2 +#xCEA2 #x88CF +#xCEA3 #x88E1 +#xCEA4 #x91CC +#xCEA5 #x96E2 +#xCEA6 #x9678 +#xCEA7 #x5F8B +#xCEA8 #x7387 +#xCEA9 #x7ACB +#xCEAA #x844E +#xCEAB #x63A0 +#xCEAC #x7565 +#xCEAD #x5289 +#xCEAE #x6D41 +#xCEAF #x6E9C +#xCEB0 #x7409 +#xCEB1 #x7559 +#xCEB2 #x786B +#xCEB3 #x7C92 +#xCEB4 #x9686 +#xCEB5 #x7ADC +#xCEB6 #x9F8D +#xCEB7 #x4FB6 +#xCEB8 #x616E +#xCEB9 #x65C5 +#xCEBA #x865C +#xCEBB #x4E86 +#xCEBC #x4EAE +#xCEBD #x50DA +#xCEBE #x4E21 +#xCEBF #x51CC +#xCEC0 #x5BEE +#xCEC1 #x6599 +#xCEC2 #x6881 +#xCEC3 #x6DBC +#xCEC4 #x731F +#xCEC5 #x7642 +#xCEC6 #x77AD +#xCEC7 #x7A1C +#xCEC8 #x7CE7 +#xCEC9 #x826F +#xCECA #x8AD2 +#xCECB #x907C +#xCECC #x91CF +#xCECD #x9675 +#xCECE #x9818 +#xCECF #x529B +#xCED0 #x7DD1 +#xCED1 #x502B +#xCED2 #x5398 +#xCED3 #x6797 +#xCED4 #x6DCB +#xCED5 #x71D0 +#xCED6 #x7433 +#xCED7 #x81E8 +#xCED8 #x8F2A +#xCED9 #x96A3 +#xCEDA #x9C57 +#xCEDB #x9E9F +#xCEDC #x7460 +#xCEDD #x5841 +#xCEDE #x6D99 +#xCEDF #x7D2F +#xCEE0 #x985E +#xCEE1 #x4EE4 +#xCEE2 #x4F36 +#xCEE3 #x4F8B +#xCEE4 #x51B7 +#xCEE5 #x52B1 +#xCEE6 #x5DBA +#xCEE7 #x601C +#xCEE8 #x73B2 +#xCEE9 #x793C +#xCEEA #x82D3 +#xCEEB #x9234 +#xCEEC #x96B7 +#xCEED #x96F6 +#xCEEE #x970A +#xCEEF #x9E97 +#xCEF0 #x9F62 +#xCEF1 #x66A6 +#xCEF2 #x6B74 +#xCEF3 #x5217 +#xCEF4 #x52A3 +#xCEF5 #x70C8 +#xCEF6 #x88C2 +#xCEF7 #x5EC9 +#xCEF8 #x604B +#xCEF9 #x6190 +#xCEFA #x6F23 +#xCEFB #x7149 +#xCEFC #x7C3E +#xCEFD #x7DF4 +#xCEFE #x806F +#xCFA1 #x84EE +#xCFA2 #x9023 +#xCFA3 #x932C +#xCFA4 #x5442 +#xCFA5 #x9B6F +#xCFA6 #x6AD3 +#xCFA7 #x7089 +#xCFA8 #x8CC2 +#xCFA9 #x8DEF +#xCFAA #x9732 +#xCFAB #x52B4 +#xCFAC #x5A41 +#xCFAD #x5ECA +#xCFAE #x5F04 +#xCFAF #x6717 +#xCFB0 #x697C +#xCFB1 #x6994 +#xCFB2 #x6D6A +#xCFB3 #x6F0F +#xCFB4 #x7262 +#xCFB5 #x72FC +#xCFB6 #x7BED +#xCFB7 #x8001 +#xCFB8 #x807E +#xCFB9 #x874B +#xCFBA #x90CE +#xCFBB #x516D +#xCFBC #x9E93 +#xCFBD #x7984 +#xCFBE #x808B +#xCFBF #x9332 +#xCFC0 #x8AD6 +#xCFC1 #x502D +#xCFC2 #x548C +#xCFC3 #x8A71 +#xCFC4 #x6B6A +#xCFC5 #x8CC4 +#xCFC6 #x8107 +#xCFC7 #x60D1 +#xCFC8 #x67A0 +#xCFC9 #x9DF2 +#xCFCA #x4E99 +#xCFCB #x4E98 +#xCFCC #x9C10 +#xCFCD #x8A6B +#xCFCE #x85C1 +#xCFCF #x8568 +#xCFD0 #x6900 +#xCFD1 #x6E7E +#xCFD2 #x7897 +#xCFD3 #x8155 +#xD0A1 #x5F0C +#xD0A2 #x4E10 +#xD0A3 #x4E15 +#xD0A4 #x4E2A +#xD0A5 #x4E31 +#xD0A6 #x4E36 +#xD0A7 #x4E3C +#xD0A8 #x4E3F +#xD0A9 #x4E42 +#xD0AA #x4E56 +#xD0AB #x4E58 +#xD0AC #x4E82 +#xD0AD #x4E85 +#xD0AE #x8C6B +#xD0AF #x4E8A +#xD0B0 #x8212 +#xD0B1 #x5F0D +#xD0B2 #x4E8E +#xD0B3 #x4E9E +#xD0B4 #x4E9F +#xD0B5 #x4EA0 +#xD0B6 #x4EA2 +#xD0B7 #x4EB0 +#xD0B8 #x4EB3 +#xD0B9 #x4EB6 +#xD0BA #x4ECE +#xD0BB #x4ECD +#xD0BC #x4EC4 +#xD0BD #x4EC6 +#xD0BE #x4EC2 +#xD0BF #x4ED7 +#xD0C0 #x4EDE +#xD0C1 #x4EED +#xD0C2 #x4EDF +#xD0C3 #x4EF7 +#xD0C4 #x4F09 +#xD0C5 #x4F5A +#xD0C6 #x4F30 +#xD0C7 #x4F5B +#xD0C8 #x4F5D +#xD0C9 #x4F57 +#xD0CA #x4F47 +#xD0CB #x4F76 +#xD0CC #x4F88 +#xD0CD #x4F8F +#xD0CE #x4F98 +#xD0CF #x4F7B +#xD0D0 #x4F69 +#xD0D1 #x4F70 +#xD0D2 #x4F91 +#xD0D3 #x4F6F +#xD0D4 #x4F86 +#xD0D5 #x4F96 +#xD0D6 #x5118 +#xD0D7 #x4FD4 +#xD0D8 #x4FDF +#xD0D9 #x4FCE +#xD0DA #x4FD8 +#xD0DB #x4FDB +#xD0DC #x4FD1 +#xD0DD #x4FDA +#xD0DE #x4FD0 +#xD0DF #x4FE4 +#xD0E0 #x4FE5 +#xD0E1 #x501A +#xD0E2 #x5028 +#xD0E3 #x5014 +#xD0E4 #x502A +#xD0E5 #x5025 +#xD0E6 #x5005 +#xD0E7 #x4F1C +#xD0E8 #x4FF6 +#xD0E9 #x5021 +#xD0EA #x5029 +#xD0EB #x502C +#xD0EC #x4FFE +#xD0ED #x4FEF +#xD0EE #x5011 +#xD0EF #x5006 +#xD0F0 #x5043 +#xD0F1 #x5047 +#xD0F2 #x6703 +#xD0F3 #x5055 +#xD0F4 #x5050 +#xD0F5 #x5048 +#xD0F6 #x505A +#xD0F7 #x5056 +#xD0F8 #x506C +#xD0F9 #x5078 +#xD0FA #x5080 +#xD0FB #x509A +#xD0FC #x5085 +#xD0FD #x50B4 +#xD0FE #x50B2 +#xD1A1 #x50C9 +#xD1A2 #x50CA +#xD1A3 #x50B3 +#xD1A4 #x50C2 +#xD1A5 #x50D6 +#xD1A6 #x50DE +#xD1A7 #x50E5 +#xD1A8 #x50ED +#xD1A9 #x50E3 +#xD1AA #x50EE +#xD1AB #x50F9 +#xD1AC #x50F5 +#xD1AD #x5109 +#xD1AE #x5101 +#xD1AF #x5102 +#xD1B0 #x5116 +#xD1B1 #x5115 +#xD1B2 #x5114 +#xD1B3 #x511A +#xD1B4 #x5121 +#xD1B5 #x513A +#xD1B6 #x5137 +#xD1B7 #x513C +#xD1B8 #x513B +#xD1B9 #x513F +#xD1BA #x5140 +#xD1BB #x5152 +#xD1BC #x514C +#xD1BD #x5154 +#xD1BE #x5162 +#xD1BF #x7AF8 +#xD1C0 #x5169 +#xD1C1 #x516A +#xD1C2 #x516E +#xD1C3 #x5180 +#xD1C4 #x5182 +#xD1C5 #x56D8 +#xD1C6 #x518C +#xD1C7 #x5189 +#xD1C8 #x518F +#xD1C9 #x5191 +#xD1CA #x5193 +#xD1CB #x5195 +#xD1CC #x5196 +#xD1CD #x51A4 +#xD1CE #x51A6 +#xD1CF #x51A2 +#xD1D0 #x51A9 +#xD1D1 #x51AA +#xD1D2 #x51AB +#xD1D3 #x51B3 +#xD1D4 #x51B1 +#xD1D5 #x51B2 +#xD1D6 #x51B0 +#xD1D7 #x51B5 +#xD1D8 #x51BD +#xD1D9 #x51C5 +#xD1DA #x51C9 +#xD1DB #x51DB +#xD1DC #x51E0 +#xD1DD #x8655 +#xD1DE #x51E9 +#xD1DF #x51ED +#xD1E0 #x51F0 +#xD1E1 #x51F5 +#xD1E2 #x51FE +#xD1E3 #x5204 +#xD1E4 #x520B +#xD1E5 #x5214 +#xD1E6 #x520E +#xD1E7 #x5227 +#xD1E8 #x522A +#xD1E9 #x522E +#xD1EA #x5233 +#xD1EB #x5239 +#xD1EC #x524F +#xD1ED #x5244 +#xD1EE #x524B +#xD1EF #x524C +#xD1F0 #x525E +#xD1F1 #x5254 +#xD1F2 #x526A +#xD1F3 #x5274 +#xD1F4 #x5269 +#xD1F5 #x5273 +#xD1F6 #x527F +#xD1F7 #x527D +#xD1F8 #x528D +#xD1F9 #x5294 +#xD1FA #x5292 +#xD1FB #x5271 +#xD1FC #x5288 +#xD1FD #x5291 +#xD1FE #x8FA8 +#xD2A1 #x8FA7 +#xD2A2 #x52AC +#xD2A3 #x52AD +#xD2A4 #x52BC +#xD2A5 #x52B5 +#xD2A6 #x52C1 +#xD2A7 #x52CD +#xD2A8 #x52D7 +#xD2A9 #x52DE +#xD2AA #x52E3 +#xD2AB #x52E6 +#xD2AC #x98ED +#xD2AD #x52E0 +#xD2AE #x52F3 +#xD2AF #x52F5 +#xD2B0 #x52F8 +#xD2B1 #x52F9 +#xD2B2 #x5306 +#xD2B3 #x5308 +#xD2B4 #x7538 +#xD2B5 #x530D +#xD2B6 #x5310 +#xD2B7 #x530F +#xD2B8 #x5315 +#xD2B9 #x531A +#xD2BA #x5323 +#xD2BB #x532F +#xD2BC #x5331 +#xD2BD #x5333 +#xD2BE #x5338 +#xD2BF #x5340 +#xD2C0 #x5346 +#xD2C1 #x5345 +#xD2C2 #x4E17 +#xD2C3 #x5349 +#xD2C4 #x534D +#xD2C5 #x51D6 +#xD2C6 #x535E +#xD2C7 #x5369 +#xD2C8 #x536E +#xD2C9 #x5918 +#xD2CA #x537B +#xD2CB #x5377 +#xD2CC #x5382 +#xD2CD #x5396 +#xD2CE #x53A0 +#xD2CF #x53A6 +#xD2D0 #x53A5 +#xD2D1 #x53AE +#xD2D2 #x53B0 +#xD2D3 #x53B6 +#xD2D4 #x53C3 +#xD2D5 #x7C12 +#xD2D6 #x96D9 +#xD2D7 #x53DF +#xD2D8 #x66FC +#xD2D9 #x71EE +#xD2DA #x53EE +#xD2DB #x53E8 +#xD2DC #x53ED +#xD2DD #x53FA +#xD2DE #x5401 +#xD2DF #x543D +#xD2E0 #x5440 +#xD2E1 #x542C +#xD2E2 #x542D +#xD2E3 #x543C +#xD2E4 #x542E +#xD2E5 #x5436 +#xD2E6 #x5429 +#xD2E7 #x541D +#xD2E8 #x544E +#xD2E9 #x548F +#xD2EA #x5475 +#xD2EB #x548E +#xD2EC #x545F +#xD2ED #x5471 +#xD2EE #x5477 +#xD2EF #x5470 +#xD2F0 #x5492 +#xD2F1 #x547B +#xD2F2 #x5480 +#xD2F3 #x5476 +#xD2F4 #x5484 +#xD2F5 #x5490 +#xD2F6 #x5486 +#xD2F7 #x54C7 +#xD2F8 #x54A2 +#xD2F9 #x54B8 +#xD2FA #x54A5 +#xD2FB #x54AC +#xD2FC #x54C4 +#xD2FD #x54C8 +#xD2FE #x54A8 +#xD3A1 #x54AB +#xD3A2 #x54C2 +#xD3A3 #x54A4 +#xD3A4 #x54BE +#xD3A5 #x54BC +#xD3A6 #x54D8 +#xD3A7 #x54E5 +#xD3A8 #x54E6 +#xD3A9 #x550F +#xD3AA #x5514 +#xD3AB #x54FD +#xD3AC #x54EE +#xD3AD #x54ED +#xD3AE #x54FA +#xD3AF #x54E2 +#xD3B0 #x5539 +#xD3B1 #x5540 +#xD3B2 #x5563 +#xD3B3 #x554C +#xD3B4 #x552E +#xD3B5 #x555C +#xD3B6 #x5545 +#xD3B7 #x5556 +#xD3B8 #x5557 +#xD3B9 #x5538 +#xD3BA #x5533 +#xD3BB #x555D +#xD3BC #x5599 +#xD3BD #x5580 +#xD3BE #x54AF +#xD3BF #x558A +#xD3C0 #x559F +#xD3C1 #x557B +#xD3C2 #x557E +#xD3C3 #x5598 +#xD3C4 #x559E +#xD3C5 #x55AE +#xD3C6 #x557C +#xD3C7 #x5583 +#xD3C8 #x55A9 +#xD3C9 #x5587 +#xD3CA #x55A8 +#xD3CB #x55DA +#xD3CC #x55C5 +#xD3CD #x55DF +#xD3CE #x55C4 +#xD3CF #x55DC +#xD3D0 #x55E4 +#xD3D1 #x55D4 +#xD3D2 #x5614 +#xD3D3 #x55F7 +#xD3D4 #x5616 +#xD3D5 #x55FE +#xD3D6 #x55FD +#xD3D7 #x561B +#xD3D8 #x55F9 +#xD3D9 #x564E +#xD3DA #x5650 +#xD3DB #x71DF +#xD3DC #x5634 +#xD3DD #x5636 +#xD3DE #x5632 +#xD3DF #x5638 +#xD3E0 #x566B +#xD3E1 #x5664 +#xD3E2 #x562F +#xD3E3 #x566C +#xD3E4 #x566A +#xD3E5 #x5686 +#xD3E6 #x5680 +#xD3E7 #x568A +#xD3E8 #x56A0 +#xD3E9 #x5694 +#xD3EA #x568F +#xD3EB #x56A5 +#xD3EC #x56AE +#xD3ED #x56B6 +#xD3EE #x56B4 +#xD3EF #x56C2 +#xD3F0 #x56BC +#xD3F1 #x56C1 +#xD3F2 #x56C3 +#xD3F3 #x56C0 +#xD3F4 #x56C8 +#xD3F5 #x56CE +#xD3F6 #x56D1 +#xD3F7 #x56D3 +#xD3F8 #x56D7 +#xD3F9 #x56EE +#xD3FA #x56F9 +#xD3FB #x5700 +#xD3FC #x56FF +#xD3FD #x5704 +#xD3FE #x5709 +#xD4A1 #x5708 +#xD4A2 #x570B +#xD4A3 #x570D +#xD4A4 #x5713 +#xD4A5 #x5718 +#xD4A6 #x5716 +#xD4A7 #x55C7 +#xD4A8 #x571C +#xD4A9 #x5726 +#xD4AA #x5737 +#xD4AB #x5738 +#xD4AC #x574E +#xD4AD #x573B +#xD4AE #x5740 +#xD4AF #x574F +#xD4B0 #x5769 +#xD4B1 #x57C0 +#xD4B2 #x5788 +#xD4B3 #x5761 +#xD4B4 #x577F +#xD4B5 #x5789 +#xD4B6 #x5793 +#xD4B7 #x57A0 +#xD4B8 #x57B3 +#xD4B9 #x57A4 +#xD4BA #x57AA +#xD4BB #x57B0 +#xD4BC #x57C3 +#xD4BD #x57C6 +#xD4BE #x57D4 +#xD4BF #x57D2 +#xD4C0 #x57D3 +#xD4C1 #x580A +#xD4C2 #x57D6 +#xD4C3 #x57E3 +#xD4C4 #x580B +#xD4C5 #x5819 +#xD4C6 #x581D +#xD4C7 #x5872 +#xD4C8 #x5821 +#xD4C9 #x5862 +#xD4CA #x584B +#xD4CB #x5870 +#xD4CC #x6BC0 +#xD4CD #x5852 +#xD4CE #x583D +#xD4CF #x5879 +#xD4D0 #x5885 +#xD4D1 #x58B9 +#xD4D2 #x589F +#xD4D3 #x58AB +#xD4D4 #x58BA +#xD4D5 #x58DE +#xD4D6 #x58BB +#xD4D7 #x58B8 +#xD4D8 #x58AE +#xD4D9 #x58C5 +#xD4DA #x58D3 +#xD4DB #x58D1 +#xD4DC #x58D7 +#xD4DD #x58D9 +#xD4DE #x58D8 +#xD4DF #x58E5 +#xD4E0 #x58DC +#xD4E1 #x58E4 +#xD4E2 #x58DF +#xD4E3 #x58EF +#xD4E4 #x58FA +#xD4E5 #x58F9 +#xD4E6 #x58FB +#xD4E7 #x58FC +#xD4E8 #x58FD +#xD4E9 #x5902 +#xD4EA #x590A +#xD4EB #x5910 +#xD4EC #x591B +#xD4ED #x68A6 +#xD4EE #x5925 +#xD4EF #x592C +#xD4F0 #x592D +#xD4F1 #x5932 +#xD4F2 #x5938 +#xD4F3 #x593E +#xD4F4 #x7AD2 +#xD4F5 #x5955 +#xD4F6 #x5950 +#xD4F7 #x594E +#xD4F8 #x595A +#xD4F9 #x5958 +#xD4FA #x5962 +#xD4FB #x5960 +#xD4FC #x5967 +#xD4FD #x596C +#xD4FE #x5969 +#xD5A1 #x5978 +#xD5A2 #x5981 +#xD5A3 #x599D +#xD5A4 #x4F5E +#xD5A5 #x4FAB +#xD5A6 #x59A3 +#xD5A7 #x59B2 +#xD5A8 #x59C6 +#xD5A9 #x59E8 +#xD5AA #x59DC +#xD5AB #x598D +#xD5AC #x59D9 +#xD5AD #x59DA +#xD5AE #x5A25 +#xD5AF #x5A1F +#xD5B0 #x5A11 +#xD5B1 #x5A1C +#xD5B2 #x5A09 +#xD5B3 #x5A1A +#xD5B4 #x5A40 +#xD5B5 #x5A6C +#xD5B6 #x5A49 +#xD5B7 #x5A35 +#xD5B8 #x5A36 +#xD5B9 #x5A62 +#xD5BA #x5A6A +#xD5BB #x5A9A +#xD5BC #x5ABC +#xD5BD #x5ABE +#xD5BE #x5ACB +#xD5BF #x5AC2 +#xD5C0 #x5ABD +#xD5C1 #x5AE3 +#xD5C2 #x5AD7 +#xD5C3 #x5AE6 +#xD5C4 #x5AE9 +#xD5C5 #x5AD6 +#xD5C6 #x5AFA +#xD5C7 #x5AFB +#xD5C8 #x5B0C +#xD5C9 #x5B0B +#xD5CA #x5B16 +#xD5CB #x5B32 +#xD5CC #x5AD0 +#xD5CD #x5B2A +#xD5CE #x5B36 +#xD5CF #x5B3E +#xD5D0 #x5B43 +#xD5D1 #x5B45 +#xD5D2 #x5B40 +#xD5D3 #x5B51 +#xD5D4 #x5B55 +#xD5D5 #x5B5A +#xD5D6 #x5B5B +#xD5D7 #x5B65 +#xD5D8 #x5B69 +#xD5D9 #x5B70 +#xD5DA #x5B73 +#xD5DB #x5B75 +#xD5DC #x5B78 +#xD5DD #x6588 +#xD5DE #x5B7A +#xD5DF #x5B80 +#xD5E0 #x5B83 +#xD5E1 #x5BA6 +#xD5E2 #x5BB8 +#xD5E3 #x5BC3 +#xD5E4 #x5BC7 +#xD5E5 #x5BC9 +#xD5E6 #x5BD4 +#xD5E7 #x5BD0 +#xD5E8 #x5BE4 +#xD5E9 #x5BE6 +#xD5EA #x5BE2 +#xD5EB #x5BDE +#xD5EC #x5BE5 +#xD5ED #x5BEB +#xD5EE #x5BF0 +#xD5EF #x5BF6 +#xD5F0 #x5BF3 +#xD5F1 #x5C05 +#xD5F2 #x5C07 +#xD5F3 #x5C08 +#xD5F4 #x5C0D +#xD5F5 #x5C13 +#xD5F6 #x5C20 +#xD5F7 #x5C22 +#xD5F8 #x5C28 +#xD5F9 #x5C38 +#xD5FA #x5C39 +#xD5FB #x5C41 +#xD5FC #x5C46 +#xD5FD #x5C4E +#xD5FE #x5C53 +#xD6A1 #x5C50 +#xD6A2 #x5C4F +#xD6A3 #x5B71 +#xD6A4 #x5C6C +#xD6A5 #x5C6E +#xD6A6 #x4E62 +#xD6A7 #x5C76 +#xD6A8 #x5C79 +#xD6A9 #x5C8C +#xD6AA #x5C91 +#xD6AB #x5C94 +#xD6AC #x599B +#xD6AD #x5CAB +#xD6AE #x5CBB +#xD6AF #x5CB6 +#xD6B0 #x5CBC +#xD6B1 #x5CB7 +#xD6B2 #x5CC5 +#xD6B3 #x5CBE +#xD6B4 #x5CC7 +#xD6B5 #x5CD9 +#xD6B6 #x5CE9 +#xD6B7 #x5CFD +#xD6B8 #x5CFA +#xD6B9 #x5CED +#xD6BA #x5D8C +#xD6BB #x5CEA +#xD6BC #x5D0B +#xD6BD #x5D15 +#xD6BE #x5D17 +#xD6BF #x5D5C +#xD6C0 #x5D1F +#xD6C1 #x5D1B +#xD6C2 #x5D11 +#xD6C3 #x5D14 +#xD6C4 #x5D22 +#xD6C5 #x5D1A +#xD6C6 #x5D19 +#xD6C7 #x5D18 +#xD6C8 #x5D4C +#xD6C9 #x5D52 +#xD6CA #x5D4E +#xD6CB #x5D4B +#xD6CC #x5D6C +#xD6CD #x5D73 +#xD6CE #x5D76 +#xD6CF #x5D87 +#xD6D0 #x5D84 +#xD6D1 #x5D82 +#xD6D2 #x5DA2 +#xD6D3 #x5D9D +#xD6D4 #x5DAC +#xD6D5 #x5DAE +#xD6D6 #x5DBD +#xD6D7 #x5D90 +#xD6D8 #x5DB7 +#xD6D9 #x5DBC +#xD6DA #x5DC9 +#xD6DB #x5DCD +#xD6DC #x5DD3 +#xD6DD #x5DD2 +#xD6DE #x5DD6 +#xD6DF #x5DDB +#xD6E0 #x5DEB +#xD6E1 #x5DF2 +#xD6E2 #x5DF5 +#xD6E3 #x5E0B +#xD6E4 #x5E1A +#xD6E5 #x5E19 +#xD6E6 #x5E11 +#xD6E7 #x5E1B +#xD6E8 #x5E36 +#xD6E9 #x5E37 +#xD6EA #x5E44 +#xD6EB #x5E43 +#xD6EC #x5E40 +#xD6ED #x5E4E +#xD6EE #x5E57 +#xD6EF #x5E54 +#xD6F0 #x5E5F +#xD6F1 #x5E62 +#xD6F2 #x5E64 +#xD6F3 #x5E47 +#xD6F4 #x5E75 +#xD6F5 #x5E76 +#xD6F6 #x5E7A +#xD6F7 #x9EBC +#xD6F8 #x5E7F +#xD6F9 #x5EA0 +#xD6FA #x5EC1 +#xD6FB #x5EC2 +#xD6FC #x5EC8 +#xD6FD #x5ED0 +#xD6FE #x5ECF +#xD7A1 #x5ED6 +#xD7A2 #x5EE3 +#xD7A3 #x5EDD +#xD7A4 #x5EDA +#xD7A5 #x5EDB +#xD7A6 #x5EE2 +#xD7A7 #x5EE1 +#xD7A8 #x5EE8 +#xD7A9 #x5EE9 +#xD7AA #x5EEC +#xD7AB #x5EF1 +#xD7AC #x5EF3 +#xD7AD #x5EF0 +#xD7AE #x5EF4 +#xD7AF #x5EF8 +#xD7B0 #x5EFE +#xD7B1 #x5F03 +#xD7B2 #x5F09 +#xD7B3 #x5F5D +#xD7B4 #x5F5C +#xD7B5 #x5F0B +#xD7B6 #x5F11 +#xD7B7 #x5F16 +#xD7B8 #x5F29 +#xD7B9 #x5F2D +#xD7BA #x5F38 +#xD7BB #x5F41 +#xD7BC #x5F48 +#xD7BD #x5F4C +#xD7BE #x5F4E +#xD7BF #x5F2F +#xD7C0 #x5F51 +#xD7C1 #x5F56 +#xD7C2 #x5F57 +#xD7C3 #x5F59 +#xD7C4 #x5F61 +#xD7C5 #x5F6D +#xD7C6 #x5F73 +#xD7C7 #x5F77 +#xD7C8 #x5F83 +#xD7C9 #x5F82 +#xD7CA #x5F7F +#xD7CB #x5F8A +#xD7CC #x5F88 +#xD7CD #x5F91 +#xD7CE #x5F87 +#xD7CF #x5F9E +#xD7D0 #x5F99 +#xD7D1 #x5F98 +#xD7D2 #x5FA0 +#xD7D3 #x5FA8 +#xD7D4 #x5FAD +#xD7D5 #x5FBC +#xD7D6 #x5FD6 +#xD7D7 #x5FFB +#xD7D8 #x5FE4 +#xD7D9 #x5FF8 +#xD7DA #x5FF1 +#xD7DB #x5FDD +#xD7DC #x60B3 +#xD7DD #x5FFF +#xD7DE #x6021 +#xD7DF #x6060 +#xD7E0 #x6019 +#xD7E1 #x6010 +#xD7E2 #x6029 +#xD7E3 #x600E +#xD7E4 #x6031 +#xD7E5 #x601B +#xD7E6 #x6015 +#xD7E7 #x602B +#xD7E8 #x6026 +#xD7E9 #x600F +#xD7EA #x603A +#xD7EB #x605A +#xD7EC #x6041 +#xD7ED #x606A +#xD7EE #x6077 +#xD7EF #x605F +#xD7F0 #x604A +#xD7F1 #x6046 +#xD7F2 #x604D +#xD7F3 #x6063 +#xD7F4 #x6043 +#xD7F5 #x6064 +#xD7F6 #x6042 +#xD7F7 #x606C +#xD7F8 #x606B +#xD7F9 #x6059 +#xD7FA #x6081 +#xD7FB #x608D +#xD7FC #x60E7 +#xD7FD #x6083 +#xD7FE #x609A +#xD8A1 #x6084 +#xD8A2 #x609B +#xD8A3 #x6096 +#xD8A4 #x6097 +#xD8A5 #x6092 +#xD8A6 #x60A7 +#xD8A7 #x608B +#xD8A8 #x60E1 +#xD8A9 #x60B8 +#xD8AA #x60E0 +#xD8AB #x60D3 +#xD8AC #x60B4 +#xD8AD #x5FF0 +#xD8AE #x60BD +#xD8AF #x60C6 +#xD8B0 #x60B5 +#xD8B1 #x60D8 +#xD8B2 #x614D +#xD8B3 #x6115 +#xD8B4 #x6106 +#xD8B5 #x60F6 +#xD8B6 #x60F7 +#xD8B7 #x6100 +#xD8B8 #x60F4 +#xD8B9 #x60FA +#xD8BA #x6103 +#xD8BB #x6121 +#xD8BC #x60FB +#xD8BD #x60F1 +#xD8BE #x610D +#xD8BF #x610E +#xD8C0 #x6147 +#xD8C1 #x613E +#xD8C2 #x6128 +#xD8C3 #x6127 +#xD8C4 #x614A +#xD8C5 #x613F +#xD8C6 #x613C +#xD8C7 #x612C +#xD8C8 #x6134 +#xD8C9 #x613D +#xD8CA #x6142 +#xD8CB #x6144 +#xD8CC #x6173 +#xD8CD #x6177 +#xD8CE #x6158 +#xD8CF #x6159 +#xD8D0 #x615A +#xD8D1 #x616B +#xD8D2 #x6174 +#xD8D3 #x616F +#xD8D4 #x6165 +#xD8D5 #x6171 +#xD8D6 #x615F +#xD8D7 #x615D +#xD8D8 #x6153 +#xD8D9 #x6175 +#xD8DA #x6199 +#xD8DB #x6196 +#xD8DC #x6187 +#xD8DD #x61AC +#xD8DE #x6194 +#xD8DF #x619A +#xD8E0 #x618A +#xD8E1 #x6191 +#xD8E2 #x61AB +#xD8E3 #x61AE +#xD8E4 #x61CC +#xD8E5 #x61CA +#xD8E6 #x61C9 +#xD8E7 #x61F7 +#xD8E8 #x61C8 +#xD8E9 #x61C3 +#xD8EA #x61C6 +#xD8EB #x61BA +#xD8EC #x61CB +#xD8ED #x7F79 +#xD8EE #x61CD +#xD8EF #x61E6 +#xD8F0 #x61E3 +#xD8F1 #x61F6 +#xD8F2 #x61FA +#xD8F3 #x61F4 +#xD8F4 #x61FF +#xD8F5 #x61FD +#xD8F6 #x61FC +#xD8F7 #x61FE +#xD8F8 #x6200 +#xD8F9 #x6208 +#xD8FA #x6209 +#xD8FB #x620D +#xD8FC #x620C +#xD8FD #x6214 +#xD8FE #x621B +#xD9A1 #x621E +#xD9A2 #x6221 +#xD9A3 #x622A +#xD9A4 #x622E +#xD9A5 #x6230 +#xD9A6 #x6232 +#xD9A7 #x6233 +#xD9A8 #x6241 +#xD9A9 #x624E +#xD9AA #x625E +#xD9AB #x6263 +#xD9AC #x625B +#xD9AD #x6260 +#xD9AE #x6268 +#xD9AF #x627C +#xD9B0 #x6282 +#xD9B1 #x6289 +#xD9B2 #x627E +#xD9B3 #x6292 +#xD9B4 #x6293 +#xD9B5 #x6296 +#xD9B6 #x62D4 +#xD9B7 #x6283 +#xD9B8 #x6294 +#xD9B9 #x62D7 +#xD9BA #x62D1 +#xD9BB #x62BB +#xD9BC #x62CF +#xD9BD #x62FF +#xD9BE #x62C6 +#xD9BF #x64D4 +#xD9C0 #x62C8 +#xD9C1 #x62DC +#xD9C2 #x62CC +#xD9C3 #x62CA +#xD9C4 #x62C2 +#xD9C5 #x62C7 +#xD9C6 #x629B +#xD9C7 #x62C9 +#xD9C8 #x630C +#xD9C9 #x62EE +#xD9CA #x62F1 +#xD9CB #x6327 +#xD9CC #x6302 +#xD9CD #x6308 +#xD9CE #x62EF +#xD9CF #x62F5 +#xD9D0 #x6350 +#xD9D1 #x633E +#xD9D2 #x634D +#xD9D3 #x641C +#xD9D4 #x634F +#xD9D5 #x6396 +#xD9D6 #x638E +#xD9D7 #x6380 +#xD9D8 #x63AB +#xD9D9 #x6376 +#xD9DA #x63A3 +#xD9DB #x638F +#xD9DC #x6389 +#xD9DD #x639F +#xD9DE #x63B5 +#xD9DF #x636B +#xD9E0 #x6369 +#xD9E1 #x63BE +#xD9E2 #x63E9 +#xD9E3 #x63C0 +#xD9E4 #x63C6 +#xD9E5 #x63E3 +#xD9E6 #x63C9 +#xD9E7 #x63D2 +#xD9E8 #x63F6 +#xD9E9 #x63C4 +#xD9EA #x6416 +#xD9EB #x6434 +#xD9EC #x6406 +#xD9ED #x6413 +#xD9EE #x6426 +#xD9EF #x6436 +#xD9F0 #x651D +#xD9F1 #x6417 +#xD9F2 #x6428 +#xD9F3 #x640F +#xD9F4 #x6467 +#xD9F5 #x646F +#xD9F6 #x6476 +#xD9F7 #x644E +#xD9F8 #x652A +#xD9F9 #x6495 +#xD9FA #x6493 +#xD9FB #x64A5 +#xD9FC #x64A9 +#xD9FD #x6488 +#xD9FE #x64BC +#xDAA1 #x64DA +#xDAA2 #x64D2 +#xDAA3 #x64C5 +#xDAA4 #x64C7 +#xDAA5 #x64BB +#xDAA6 #x64D8 +#xDAA7 #x64C2 +#xDAA8 #x64F1 +#xDAA9 #x64E7 +#xDAAA #x8209 +#xDAAB #x64E0 +#xDAAC #x64E1 +#xDAAD #x62AC +#xDAAE #x64E3 +#xDAAF #x64EF +#xDAB0 #x652C +#xDAB1 #x64F6 +#xDAB2 #x64F4 +#xDAB3 #x64F2 +#xDAB4 #x64FA +#xDAB5 #x6500 +#xDAB6 #x64FD +#xDAB7 #x6518 +#xDAB8 #x651C +#xDAB9 #x6505 +#xDABA #x6524 +#xDABB #x6523 +#xDABC #x652B +#xDABD #x6534 +#xDABE #x6535 +#xDABF #x6537 +#xDAC0 #x6536 +#xDAC1 #x6538 +#xDAC2 #x754B +#xDAC3 #x6548 +#xDAC4 #x6556 +#xDAC5 #x6555 +#xDAC6 #x654D +#xDAC7 #x6558 +#xDAC8 #x655E +#xDAC9 #x655D +#xDACA #x6572 +#xDACB #x6578 +#xDACC #x6582 +#xDACD #x6583 +#xDACE #x8B8A +#xDACF #x659B +#xDAD0 #x659F +#xDAD1 #x65AB +#xDAD2 #x65B7 +#xDAD3 #x65C3 +#xDAD4 #x65C6 +#xDAD5 #x65C1 +#xDAD6 #x65C4 +#xDAD7 #x65CC +#xDAD8 #x65D2 +#xDAD9 #x65DB +#xDADA #x65D9 +#xDADB #x65E0 +#xDADC #x65E1 +#xDADD #x65F1 +#xDADE #x6772 +#xDADF #x660A +#xDAE0 #x6603 +#xDAE1 #x65FB +#xDAE2 #x6773 +#xDAE3 #x6635 +#xDAE4 #x6636 +#xDAE5 #x6634 +#xDAE6 #x661C +#xDAE7 #x664F +#xDAE8 #x6644 +#xDAE9 #x6649 +#xDAEA #x6641 +#xDAEB #x665E +#xDAEC #x665D +#xDAED #x6664 +#xDAEE #x6667 +#xDAEF #x6668 +#xDAF0 #x665F +#xDAF1 #x6662 +#xDAF2 #x6670 +#xDAF3 #x6683 +#xDAF4 #x6688 +#xDAF5 #x668E +#xDAF6 #x6689 +#xDAF7 #x6684 +#xDAF8 #x6698 +#xDAF9 #x669D +#xDAFA #x66C1 +#xDAFB #x66B9 +#xDAFC #x66C9 +#xDAFD #x66BE +#xDAFE #x66BC +#xDBA1 #x66C4 +#xDBA2 #x66B8 +#xDBA3 #x66D6 +#xDBA4 #x66DA +#xDBA5 #x66E0 +#xDBA6 #x663F +#xDBA7 #x66E6 +#xDBA8 #x66E9 +#xDBA9 #x66F0 +#xDBAA #x66F5 +#xDBAB #x66F7 +#xDBAC #x670F +#xDBAD #x6716 +#xDBAE #x671E +#xDBAF #x6726 +#xDBB0 #x6727 +#xDBB1 #x9738 +#xDBB2 #x672E +#xDBB3 #x673F +#xDBB4 #x6736 +#xDBB5 #x6741 +#xDBB6 #x6738 +#xDBB7 #x6737 +#xDBB8 #x6746 +#xDBB9 #x675E +#xDBBA #x6760 +#xDBBB #x6759 +#xDBBC #x6763 +#xDBBD #x6764 +#xDBBE #x6789 +#xDBBF #x6770 +#xDBC0 #x67A9 +#xDBC1 #x677C +#xDBC2 #x676A +#xDBC3 #x678C +#xDBC4 #x678B +#xDBC5 #x67A6 +#xDBC6 #x67A1 +#xDBC7 #x6785 +#xDBC8 #x67B7 +#xDBC9 #x67EF +#xDBCA #x67B4 +#xDBCB #x67EC +#xDBCC #x67B3 +#xDBCD #x67E9 +#xDBCE #x67B8 +#xDBCF #x67E4 +#xDBD0 #x67DE +#xDBD1 #x67DD +#xDBD2 #x67E2 +#xDBD3 #x67EE +#xDBD4 #x67B9 +#xDBD5 #x67CE +#xDBD6 #x67C6 +#xDBD7 #x67E7 +#xDBD8 #x6A9C +#xDBD9 #x681E +#xDBDA #x6846 +#xDBDB #x6829 +#xDBDC #x6840 +#xDBDD #x684D +#xDBDE #x6832 +#xDBDF #x684E +#xDBE0 #x68B3 +#xDBE1 #x682B +#xDBE2 #x6859 +#xDBE3 #x6863 +#xDBE4 #x6877 +#xDBE5 #x687F +#xDBE6 #x689F +#xDBE7 #x688F +#xDBE8 #x68AD +#xDBE9 #x6894 +#xDBEA #x689D +#xDBEB #x689B +#xDBEC #x6883 +#xDBED #x6AAE +#xDBEE #x68B9 +#xDBEF #x6874 +#xDBF0 #x68B5 +#xDBF1 #x68A0 +#xDBF2 #x68BA +#xDBF3 #x690F +#xDBF4 #x688D +#xDBF5 #x687E +#xDBF6 #x6901 +#xDBF7 #x68CA +#xDBF8 #x6908 +#xDBF9 #x68D8 +#xDBFA #x6922 +#xDBFB #x6926 +#xDBFC #x68E1 +#xDBFD #x690C +#xDBFE #x68CD +#xDCA1 #x68D4 +#xDCA2 #x68E7 +#xDCA3 #x68D5 +#xDCA4 #x6936 +#xDCA5 #x6912 +#xDCA6 #x6904 +#xDCA7 #x68D7 +#xDCA8 #x68E3 +#xDCA9 #x6925 +#xDCAA #x68F9 +#xDCAB #x68E0 +#xDCAC #x68EF +#xDCAD #x6928 +#xDCAE #x692A +#xDCAF #x691A +#xDCB0 #x6923 +#xDCB1 #x6921 +#xDCB2 #x68C6 +#xDCB3 #x6979 +#xDCB4 #x6977 +#xDCB5 #x695C +#xDCB6 #x6978 +#xDCB7 #x696B +#xDCB8 #x6954 +#xDCB9 #x697E +#xDCBA #x696E +#xDCBB #x6939 +#xDCBC #x6974 +#xDCBD #x693D +#xDCBE #x6959 +#xDCBF #x6930 +#xDCC0 #x6961 +#xDCC1 #x695E +#xDCC2 #x695D +#xDCC3 #x6981 +#xDCC4 #x696A +#xDCC5 #x69B2 +#xDCC6 #x69AE +#xDCC7 #x69D0 +#xDCC8 #x69BF +#xDCC9 #x69C1 +#xDCCA #x69D3 +#xDCCB #x69BE +#xDCCC #x69CE +#xDCCD #x5BE8 +#xDCCE #x69CA +#xDCCF #x69DD +#xDCD0 #x69BB +#xDCD1 #x69C3 +#xDCD2 #x69A7 +#xDCD3 #x6A2E +#xDCD4 #x6991 +#xDCD5 #x69A0 +#xDCD6 #x699C +#xDCD7 #x6995 +#xDCD8 #x69B4 +#xDCD9 #x69DE +#xDCDA #x69E8 +#xDCDB #x6A02 +#xDCDC #x6A1B +#xDCDD #x69FF +#xDCDE #x6B0A +#xDCDF #x69F9 +#xDCE0 #x69F2 +#xDCE1 #x69E7 +#xDCE2 #x6A05 +#xDCE3 #x69B1 +#xDCE4 #x6A1E +#xDCE5 #x69ED +#xDCE6 #x6A14 +#xDCE7 #x69EB +#xDCE8 #x6A0A +#xDCE9 #x6A12 +#xDCEA #x6AC1 +#xDCEB #x6A23 +#xDCEC #x6A13 +#xDCED #x6A44 +#xDCEE #x6A0C +#xDCEF #x6A72 +#xDCF0 #x6A36 +#xDCF1 #x6A78 +#xDCF2 #x6A47 +#xDCF3 #x6A62 +#xDCF4 #x6A59 +#xDCF5 #x6A66 +#xDCF6 #x6A48 +#xDCF7 #x6A38 +#xDCF8 #x6A22 +#xDCF9 #x6A90 +#xDCFA #x6A8D +#xDCFB #x6AA0 +#xDCFC #x6A84 +#xDCFD #x6AA2 +#xDCFE #x6AA3 +#xDDA1 #x6A97 +#xDDA2 #x8617 +#xDDA3 #x6ABB +#xDDA4 #x6AC3 +#xDDA5 #x6AC2 +#xDDA6 #x6AB8 +#xDDA7 #x6AB3 +#xDDA8 #x6AAC +#xDDA9 #x6ADE +#xDDAA #x6AD1 +#xDDAB #x6ADF +#xDDAC #x6AAA +#xDDAD #x6ADA +#xDDAE #x6AEA +#xDDAF #x6AFB +#xDDB0 #x6B05 +#xDDB1 #x8616 +#xDDB2 #x6AFA +#xDDB3 #x6B12 +#xDDB4 #x6B16 +#xDDB5 #x9B31 +#xDDB6 #x6B1F +#xDDB7 #x6B38 +#xDDB8 #x6B37 +#xDDB9 #x76DC +#xDDBA #x6B39 +#xDDBB #x98EE +#xDDBC #x6B47 +#xDDBD #x6B43 +#xDDBE #x6B49 +#xDDBF #x6B50 +#xDDC0 #x6B59 +#xDDC1 #x6B54 +#xDDC2 #x6B5B +#xDDC3 #x6B5F +#xDDC4 #x6B61 +#xDDC5 #x6B78 +#xDDC6 #x6B79 +#xDDC7 #x6B7F +#xDDC8 #x6B80 +#xDDC9 #x6B84 +#xDDCA #x6B83 +#xDDCB #x6B8D +#xDDCC #x6B98 +#xDDCD #x6B95 +#xDDCE #x6B9E +#xDDCF #x6BA4 +#xDDD0 #x6BAA +#xDDD1 #x6BAB +#xDDD2 #x6BAF +#xDDD3 #x6BB2 +#xDDD4 #x6BB1 +#xDDD5 #x6BB3 +#xDDD6 #x6BB7 +#xDDD7 #x6BBC +#xDDD8 #x6BC6 +#xDDD9 #x6BCB +#xDDDA #x6BD3 +#xDDDB #x6BDF +#xDDDC #x6BEC +#xDDDD #x6BEB +#xDDDE #x6BF3 +#xDDDF #x6BEF +#xDDE0 #x9EBE +#xDDE1 #x6C08 +#xDDE2 #x6C13 +#xDDE3 #x6C14 +#xDDE4 #x6C1B +#xDDE5 #x6C24 +#xDDE6 #x6C23 +#xDDE7 #x6C5E +#xDDE8 #x6C55 +#xDDE9 #x6C62 +#xDDEA #x6C6A +#xDDEB #x6C82 +#xDDEC #x6C8D +#xDDED #x6C9A +#xDDEE #x6C81 +#xDDEF #x6C9B +#xDDF0 #x6C7E +#xDDF1 #x6C68 +#xDDF2 #x6C73 +#xDDF3 #x6C92 +#xDDF4 #x6C90 +#xDDF5 #x6CC4 +#xDDF6 #x6CF1 +#xDDF7 #x6CD3 +#xDDF8 #x6CBD +#xDDF9 #x6CD7 +#xDDFA #x6CC5 +#xDDFB #x6CDD +#xDDFC #x6CAE +#xDDFD #x6CB1 +#xDDFE #x6CBE +#xDEA1 #x6CBA +#xDEA2 #x6CDB +#xDEA3 #x6CEF +#xDEA4 #x6CD9 +#xDEA5 #x6CEA +#xDEA6 #x6D1F +#xDEA7 #x884D +#xDEA8 #x6D36 +#xDEA9 #x6D2B +#xDEAA #x6D3D +#xDEAB #x6D38 +#xDEAC #x6D19 +#xDEAD #x6D35 +#xDEAE #x6D33 +#xDEAF #x6D12 +#xDEB0 #x6D0C +#xDEB1 #x6D63 +#xDEB2 #x6D93 +#xDEB3 #x6D64 +#xDEB4 #x6D5A +#xDEB5 #x6D79 +#xDEB6 #x6D59 +#xDEB7 #x6D8E +#xDEB8 #x6D95 +#xDEB9 #x6FE4 +#xDEBA #x6D85 +#xDEBB #x6DF9 +#xDEBC #x6E15 +#xDEBD #x6E0A +#xDEBE #x6DB5 +#xDEBF #x6DC7 +#xDEC0 #x6DE6 +#xDEC1 #x6DB8 +#xDEC2 #x6DC6 +#xDEC3 #x6DEC +#xDEC4 #x6DDE +#xDEC5 #x6DCC +#xDEC6 #x6DE8 +#xDEC7 #x6DD2 +#xDEC8 #x6DC5 +#xDEC9 #x6DFA +#xDECA #x6DD9 +#xDECB #x6DE4 +#xDECC #x6DD5 +#xDECD #x6DEA +#xDECE #x6DEE +#xDECF #x6E2D +#xDED0 #x6E6E +#xDED1 #x6E2E +#xDED2 #x6E19 +#xDED3 #x6E72 +#xDED4 #x6E5F +#xDED5 #x6E3E +#xDED6 #x6E23 +#xDED7 #x6E6B +#xDED8 #x6E2B +#xDED9 #x6E76 +#xDEDA #x6E4D +#xDEDB #x6E1F +#xDEDC #x6E43 +#xDEDD #x6E3A +#xDEDE #x6E4E +#xDEDF #x6E24 +#xDEE0 #x6EFF +#xDEE1 #x6E1D +#xDEE2 #x6E38 +#xDEE3 #x6E82 +#xDEE4 #x6EAA +#xDEE5 #x6E98 +#xDEE6 #x6EC9 +#xDEE7 #x6EB7 +#xDEE8 #x6ED3 +#xDEE9 #x6EBD +#xDEEA #x6EAF +#xDEEB #x6EC4 +#xDEEC #x6EB2 +#xDEED #x6ED4 +#xDEEE #x6ED5 +#xDEEF #x6E8F +#xDEF0 #x6EA5 +#xDEF1 #x6EC2 +#xDEF2 #x6E9F +#xDEF3 #x6F41 +#xDEF4 #x6F11 +#xDEF5 #x704C +#xDEF6 #x6EEC +#xDEF7 #x6EF8 +#xDEF8 #x6EFE +#xDEF9 #x6F3F +#xDEFA #x6EF2 +#xDEFB #x6F31 +#xDEFC #x6EEF +#xDEFD #x6F32 +#xDEFE #x6ECC +#xDFA1 #x6F3E +#xDFA2 #x6F13 +#xDFA3 #x6EF7 +#xDFA4 #x6F86 +#xDFA5 #x6F7A +#xDFA6 #x6F78 +#xDFA7 #x6F81 +#xDFA8 #x6F80 +#xDFA9 #x6F6F +#xDFAA #x6F5B +#xDFAB #x6FF3 +#xDFAC #x6F6D +#xDFAD #x6F82 +#xDFAE #x6F7C +#xDFAF #x6F58 +#xDFB0 #x6F8E +#xDFB1 #x6F91 +#xDFB2 #x6FC2 +#xDFB3 #x6F66 +#xDFB4 #x6FB3 +#xDFB5 #x6FA3 +#xDFB6 #x6FA1 +#xDFB7 #x6FA4 +#xDFB8 #x6FB9 +#xDFB9 #x6FC6 +#xDFBA #x6FAA +#xDFBB #x6FDF +#xDFBC #x6FD5 +#xDFBD #x6FEC +#xDFBE #x6FD4 +#xDFBF #x6FD8 +#xDFC0 #x6FF1 +#xDFC1 #x6FEE +#xDFC2 #x6FDB +#xDFC3 #x7009 +#xDFC4 #x700B +#xDFC5 #x6FFA +#xDFC6 #x7011 +#xDFC7 #x7001 +#xDFC8 #x700F +#xDFC9 #x6FFE +#xDFCA #x701B +#xDFCB #x701A +#xDFCC #x6F74 +#xDFCD #x701D +#xDFCE #x7018 +#xDFCF #x701F +#xDFD0 #x7030 +#xDFD1 #x703E +#xDFD2 #x7032 +#xDFD3 #x7051 +#xDFD4 #x7063 +#xDFD5 #x7099 +#xDFD6 #x7092 +#xDFD7 #x70AF +#xDFD8 #x70F1 +#xDFD9 #x70AC +#xDFDA #x70B8 +#xDFDB #x70B3 +#xDFDC #x70AE +#xDFDD #x70DF +#xDFDE #x70CB +#xDFDF #x70DD +#xDFE0 #x70D9 +#xDFE1 #x7109 +#xDFE2 #x70FD +#xDFE3 #x711C +#xDFE4 #x7119 +#xDFE5 #x7165 +#xDFE6 #x7155 +#xDFE7 #x7188 +#xDFE8 #x7166 +#xDFE9 #x7162 +#xDFEA #x714C +#xDFEB #x7156 +#xDFEC #x716C +#xDFED #x718F +#xDFEE #x71FB +#xDFEF #x7184 +#xDFF0 #x7195 +#xDFF1 #x71A8 +#xDFF2 #x71AC +#xDFF3 #x71D7 +#xDFF4 #x71B9 +#xDFF5 #x71BE +#xDFF6 #x71D2 +#xDFF7 #x71C9 +#xDFF8 #x71D4 +#xDFF9 #x71CE +#xDFFA #x71E0 +#xDFFB #x71EC +#xDFFC #x71E7 +#xDFFD #x71F5 +#xDFFE #x71FC +#xE0A1 #x71F9 +#xE0A2 #x71FF +#xE0A3 #x720D +#xE0A4 #x7210 +#xE0A5 #x721B +#xE0A6 #x7228 +#xE0A7 #x722D +#xE0A8 #x722C +#xE0A9 #x7230 +#xE0AA #x7232 +#xE0AB #x723B +#xE0AC #x723C +#xE0AD #x723F +#xE0AE #x7240 +#xE0AF #x7246 +#xE0B0 #x724B +#xE0B1 #x7258 +#xE0B2 #x7274 +#xE0B3 #x727E +#xE0B4 #x7282 +#xE0B5 #x7281 +#xE0B6 #x7287 +#xE0B7 #x7292 +#xE0B8 #x7296 +#xE0B9 #x72A2 +#xE0BA #x72A7 +#xE0BB #x72B9 +#xE0BC #x72B2 +#xE0BD #x72C3 +#xE0BE #x72C6 +#xE0BF #x72C4 +#xE0C0 #x72CE +#xE0C1 #x72D2 +#xE0C2 #x72E2 +#xE0C3 #x72E0 +#xE0C4 #x72E1 +#xE0C5 #x72F9 +#xE0C6 #x72F7 +#xE0C7 #x500F +#xE0C8 #x7317 +#xE0C9 #x730A +#xE0CA #x731C +#xE0CB #x7316 +#xE0CC #x731D +#xE0CD #x7334 +#xE0CE #x732F +#xE0CF #x7329 +#xE0D0 #x7325 +#xE0D1 #x733E +#xE0D2 #x734E +#xE0D3 #x734F +#xE0D4 #x9ED8 +#xE0D5 #x7357 +#xE0D6 #x736A +#xE0D7 #x7368 +#xE0D8 #x7370 +#xE0D9 #x7378 +#xE0DA #x7375 +#xE0DB #x737B +#xE0DC #x737A +#xE0DD #x73C8 +#xE0DE #x73B3 +#xE0DF #x73CE +#xE0E0 #x73BB +#xE0E1 #x73C0 +#xE0E2 #x73E5 +#xE0E3 #x73EE +#xE0E4 #x73DE +#xE0E5 #x74A2 +#xE0E6 #x7405 +#xE0E7 #x746F +#xE0E8 #x7425 +#xE0E9 #x73F8 +#xE0EA #x7432 +#xE0EB #x743A +#xE0EC #x7455 +#xE0ED #x743F +#xE0EE #x745F +#xE0EF #x7459 +#xE0F0 #x7441 +#xE0F1 #x745C +#xE0F2 #x7469 +#xE0F3 #x7470 +#xE0F4 #x7463 +#xE0F5 #x746A +#xE0F6 #x7476 +#xE0F7 #x747E +#xE0F8 #x748B +#xE0F9 #x749E +#xE0FA #x74A7 +#xE0FB #x74CA +#xE0FC #x74CF +#xE0FD #x74D4 +#xE0FE #x73F1 +#xE1A1 #x74E0 +#xE1A2 #x74E3 +#xE1A3 #x74E7 +#xE1A4 #x74E9 +#xE1A5 #x74EE +#xE1A6 #x74F2 +#xE1A7 #x74F0 +#xE1A8 #x74F1 +#xE1A9 #x74F8 +#xE1AA #x74F7 +#xE1AB #x7504 +#xE1AC #x7503 +#xE1AD #x7505 +#xE1AE #x750C +#xE1AF #x750E +#xE1B0 #x750D +#xE1B1 #x7515 +#xE1B2 #x7513 +#xE1B3 #x751E +#xE1B4 #x7526 +#xE1B5 #x752C +#xE1B6 #x753C +#xE1B7 #x7544 +#xE1B8 #x754D +#xE1B9 #x754A +#xE1BA #x7549 +#xE1BB #x755B +#xE1BC #x7546 +#xE1BD #x755A +#xE1BE #x7569 +#xE1BF #x7564 +#xE1C0 #x7567 +#xE1C1 #x756B +#xE1C2 #x756D +#xE1C3 #x7578 +#xE1C4 #x7576 +#xE1C5 #x7586 +#xE1C6 #x7587 +#xE1C7 #x7574 +#xE1C8 #x758A +#xE1C9 #x7589 +#xE1CA #x7582 +#xE1CB #x7594 +#xE1CC #x759A +#xE1CD #x759D +#xE1CE #x75A5 +#xE1CF #x75A3 +#xE1D0 #x75C2 +#xE1D1 #x75B3 +#xE1D2 #x75C3 +#xE1D3 #x75B5 +#xE1D4 #x75BD +#xE1D5 #x75B8 +#xE1D6 #x75BC +#xE1D7 #x75B1 +#xE1D8 #x75CD +#xE1D9 #x75CA +#xE1DA #x75D2 +#xE1DB #x75D9 +#xE1DC #x75E3 +#xE1DD #x75DE +#xE1DE #x75FE +#xE1DF #x75FF +#xE1E0 #x75FC +#xE1E1 #x7601 +#xE1E2 #x75F0 +#xE1E3 #x75FA +#xE1E4 #x75F2 +#xE1E5 #x75F3 +#xE1E6 #x760B +#xE1E7 #x760D +#xE1E8 #x7609 +#xE1E9 #x761F +#xE1EA #x7627 +#xE1EB #x7620 +#xE1EC #x7621 +#xE1ED #x7622 +#xE1EE #x7624 +#xE1EF #x7634 +#xE1F0 #x7630 +#xE1F1 #x763B +#xE1F2 #x7647 +#xE1F3 #x7648 +#xE1F4 #x7646 +#xE1F5 #x765C +#xE1F6 #x7658 +#xE1F7 #x7661 +#xE1F8 #x7662 +#xE1F9 #x7668 +#xE1FA #x7669 +#xE1FB #x766A +#xE1FC #x7667 +#xE1FD #x766C +#xE1FE #x7670 +#xE2A1 #x7672 +#xE2A2 #x7676 +#xE2A3 #x7678 +#xE2A4 #x767C +#xE2A5 #x7680 +#xE2A6 #x7683 +#xE2A7 #x7688 +#xE2A8 #x768B +#xE2A9 #x768E +#xE2AA #x7696 +#xE2AB #x7693 +#xE2AC #x7699 +#xE2AD #x769A +#xE2AE #x76B0 +#xE2AF #x76B4 +#xE2B0 #x76B8 +#xE2B1 #x76B9 +#xE2B2 #x76BA +#xE2B3 #x76C2 +#xE2B4 #x76CD +#xE2B5 #x76D6 +#xE2B6 #x76D2 +#xE2B7 #x76DE +#xE2B8 #x76E1 +#xE2B9 #x76E5 +#xE2BA #x76E7 +#xE2BB #x76EA +#xE2BC #x862F +#xE2BD #x76FB +#xE2BE #x7708 +#xE2BF #x7707 +#xE2C0 #x7704 +#xE2C1 #x7729 +#xE2C2 #x7724 +#xE2C3 #x771E +#xE2C4 #x7725 +#xE2C5 #x7726 +#xE2C6 #x771B +#xE2C7 #x7737 +#xE2C8 #x7738 +#xE2C9 #x7747 +#xE2CA #x775A +#xE2CB #x7768 +#xE2CC #x776B +#xE2CD #x775B +#xE2CE #x7765 +#xE2CF #x777F +#xE2D0 #x777E +#xE2D1 #x7779 +#xE2D2 #x778E +#xE2D3 #x778B +#xE2D4 #x7791 +#xE2D5 #x77A0 +#xE2D6 #x779E +#xE2D7 #x77B0 +#xE2D8 #x77B6 +#xE2D9 #x77B9 +#xE2DA #x77BF +#xE2DB #x77BC +#xE2DC #x77BD +#xE2DD #x77BB +#xE2DE #x77C7 +#xE2DF #x77CD +#xE2E0 #x77D7 +#xE2E1 #x77DA +#xE2E2 #x77DC +#xE2E3 #x77E3 +#xE2E4 #x77EE +#xE2E5 #x77FC +#xE2E6 #x780C +#xE2E7 #x7812 +#xE2E8 #x7926 +#xE2E9 #x7820 +#xE2EA #x792A +#xE2EB #x7845 +#xE2EC #x788E +#xE2ED #x7874 +#xE2EE #x7886 +#xE2EF #x787C +#xE2F0 #x789A +#xE2F1 #x788C +#xE2F2 #x78A3 +#xE2F3 #x78B5 +#xE2F4 #x78AA +#xE2F5 #x78AF +#xE2F6 #x78D1 +#xE2F7 #x78C6 +#xE2F8 #x78CB +#xE2F9 #x78D4 +#xE2FA #x78BE +#xE2FB #x78BC +#xE2FC #x78C5 +#xE2FD #x78CA +#xE2FE #x78EC +#xE3A1 #x78E7 +#xE3A2 #x78DA +#xE3A3 #x78FD +#xE3A4 #x78F4 +#xE3A5 #x7907 +#xE3A6 #x7912 +#xE3A7 #x7911 +#xE3A8 #x7919 +#xE3A9 #x792C +#xE3AA #x792B +#xE3AB #x7940 +#xE3AC #x7960 +#xE3AD #x7957 +#xE3AE #x795F +#xE3AF #x795A +#xE3B0 #x7955 +#xE3B1 #x7953 +#xE3B2 #x797A +#xE3B3 #x797F +#xE3B4 #x798A +#xE3B5 #x799D +#xE3B6 #x79A7 +#xE3B7 #x9F4B +#xE3B8 #x79AA +#xE3B9 #x79AE +#xE3BA #x79B3 +#xE3BB #x79B9 +#xE3BC #x79BA +#xE3BD #x79C9 +#xE3BE #x79D5 +#xE3BF #x79E7 +#xE3C0 #x79EC +#xE3C1 #x79E1 +#xE3C2 #x79E3 +#xE3C3 #x7A08 +#xE3C4 #x7A0D +#xE3C5 #x7A18 +#xE3C6 #x7A19 +#xE3C7 #x7A20 +#xE3C8 #x7A1F +#xE3C9 #x7980 +#xE3CA #x7A31 +#xE3CB #x7A3B +#xE3CC #x7A3E +#xE3CD #x7A37 +#xE3CE #x7A43 +#xE3CF #x7A57 +#xE3D0 #x7A49 +#xE3D1 #x7A61 +#xE3D2 #x7A62 +#xE3D3 #x7A69 +#xE3D4 #x9F9D +#xE3D5 #x7A70 +#xE3D6 #x7A79 +#xE3D7 #x7A7D +#xE3D8 #x7A88 +#xE3D9 #x7A97 +#xE3DA #x7A95 +#xE3DB #x7A98 +#xE3DC #x7A96 +#xE3DD #x7AA9 +#xE3DE #x7AC8 +#xE3DF #x7AB0 +#xE3E0 #x7AB6 +#xE3E1 #x7AC5 +#xE3E2 #x7AC4 +#xE3E3 #x7ABF +#xE3E4 #x9083 +#xE3E5 #x7AC7 +#xE3E6 #x7ACA +#xE3E7 #x7ACD +#xE3E8 #x7ACF +#xE3E9 #x7AD5 +#xE3EA #x7AD3 +#xE3EB #x7AD9 +#xE3EC #x7ADA +#xE3ED #x7ADD +#xE3EE #x7AE1 +#xE3EF #x7AE2 +#xE3F0 #x7AE6 +#xE3F1 #x7AED +#xE3F2 #x7AF0 +#xE3F3 #x7B02 +#xE3F4 #x7B0F +#xE3F5 #x7B0A +#xE3F6 #x7B06 +#xE3F7 #x7B33 +#xE3F8 #x7B18 +#xE3F9 #x7B19 +#xE3FA #x7B1E +#xE3FB #x7B35 +#xE3FC #x7B28 +#xE3FD #x7B36 +#xE3FE #x7B50 +#xE4A1 #x7B7A +#xE4A2 #x7B04 +#xE4A3 #x7B4D +#xE4A4 #x7B0B +#xE4A5 #x7B4C +#xE4A6 #x7B45 +#xE4A7 #x7B75 +#xE4A8 #x7B65 +#xE4A9 #x7B74 +#xE4AA #x7B67 +#xE4AB #x7B70 +#xE4AC #x7B71 +#xE4AD #x7B6C +#xE4AE #x7B6E +#xE4AF #x7B9D +#xE4B0 #x7B98 +#xE4B1 #x7B9F +#xE4B2 #x7B8D +#xE4B3 #x7B9C +#xE4B4 #x7B9A +#xE4B5 #x7B8B +#xE4B6 #x7B92 +#xE4B7 #x7B8F +#xE4B8 #x7B5D +#xE4B9 #x7B99 +#xE4BA #x7BCB +#xE4BB #x7BC1 +#xE4BC #x7BCC +#xE4BD #x7BCF +#xE4BE #x7BB4 +#xE4BF #x7BC6 +#xE4C0 #x7BDD +#xE4C1 #x7BE9 +#xE4C2 #x7C11 +#xE4C3 #x7C14 +#xE4C4 #x7BE6 +#xE4C5 #x7BE5 +#xE4C6 #x7C60 +#xE4C7 #x7C00 +#xE4C8 #x7C07 +#xE4C9 #x7C13 +#xE4CA #x7BF3 +#xE4CB #x7BF7 +#xE4CC #x7C17 +#xE4CD #x7C0D +#xE4CE #x7BF6 +#xE4CF #x7C23 +#xE4D0 #x7C27 +#xE4D1 #x7C2A +#xE4D2 #x7C1F +#xE4D3 #x7C37 +#xE4D4 #x7C2B +#xE4D5 #x7C3D +#xE4D6 #x7C4C +#xE4D7 #x7C43 +#xE4D8 #x7C54 +#xE4D9 #x7C4F +#xE4DA #x7C40 +#xE4DB #x7C50 +#xE4DC #x7C58 +#xE4DD #x7C5F +#xE4DE #x7C64 +#xE4DF #x7C56 +#xE4E0 #x7C65 +#xE4E1 #x7C6C +#xE4E2 #x7C75 +#xE4E3 #x7C83 +#xE4E4 #x7C90 +#xE4E5 #x7CA4 +#xE4E6 #x7CAD +#xE4E7 #x7CA2 +#xE4E8 #x7CAB +#xE4E9 #x7CA1 +#xE4EA #x7CA8 +#xE4EB #x7CB3 +#xE4EC #x7CB2 +#xE4ED #x7CB1 +#xE4EE #x7CAE +#xE4EF #x7CB9 +#xE4F0 #x7CBD +#xE4F1 #x7CC0 +#xE4F2 #x7CC5 +#xE4F3 #x7CC2 +#xE4F4 #x7CD8 +#xE4F5 #x7CD2 +#xE4F6 #x7CDC +#xE4F7 #x7CE2 +#xE4F8 #x9B3B +#xE4F9 #x7CEF +#xE4FA #x7CF2 +#xE4FB #x7CF4 +#xE4FC #x7CF6 +#xE4FD #x7CFA +#xE4FE #x7D06 +#xE5A1 #x7D02 +#xE5A2 #x7D1C +#xE5A3 #x7D15 +#xE5A4 #x7D0A +#xE5A5 #x7D45 +#xE5A6 #x7D4B +#xE5A7 #x7D2E +#xE5A8 #x7D32 +#xE5A9 #x7D3F +#xE5AA #x7D35 +#xE5AB #x7D46 +#xE5AC #x7D73 +#xE5AD #x7D56 +#xE5AE #x7D4E +#xE5AF #x7D72 +#xE5B0 #x7D68 +#xE5B1 #x7D6E +#xE5B2 #x7D4F +#xE5B3 #x7D63 +#xE5B4 #x7D93 +#xE5B5 #x7D89 +#xE5B6 #x7D5B +#xE5B7 #x7D8F +#xE5B8 #x7D7D +#xE5B9 #x7D9B +#xE5BA #x7DBA +#xE5BB #x7DAE +#xE5BC #x7DA3 +#xE5BD #x7DB5 +#xE5BE #x7DC7 +#xE5BF #x7DBD +#xE5C0 #x7DAB +#xE5C1 #x7E3D +#xE5C2 #x7DA2 +#xE5C3 #x7DAF +#xE5C4 #x7DDC +#xE5C5 #x7DB8 +#xE5C6 #x7D9F +#xE5C7 #x7DB0 +#xE5C8 #x7DD8 +#xE5C9 #x7DDD +#xE5CA #x7DE4 +#xE5CB #x7DDE +#xE5CC #x7DFB +#xE5CD #x7DF2 +#xE5CE #x7DE1 +#xE5CF #x7E05 +#xE5D0 #x7E0A +#xE5D1 #x7E23 +#xE5D2 #x7E21 +#xE5D3 #x7E12 +#xE5D4 #x7E31 +#xE5D5 #x7E1F +#xE5D6 #x7E09 +#xE5D7 #x7E0B +#xE5D8 #x7E22 +#xE5D9 #x7E46 +#xE5DA #x7E66 +#xE5DB #x7E3B +#xE5DC #x7E35 +#xE5DD #x7E39 +#xE5DE #x7E43 +#xE5DF #x7E37 +#xE5E0 #x7E32 +#xE5E1 #x7E3A +#xE5E2 #x7E67 +#xE5E3 #x7E5D +#xE5E4 #x7E56 +#xE5E5 #x7E5E +#xE5E6 #x7E59 +#xE5E7 #x7E5A +#xE5E8 #x7E79 +#xE5E9 #x7E6A +#xE5EA #x7E69 +#xE5EB #x7E7C +#xE5EC #x7E7B +#xE5ED #x7E83 +#xE5EE #x7DD5 +#xE5EF #x7E7D +#xE5F0 #x8FAE +#xE5F1 #x7E7F +#xE5F2 #x7E88 +#xE5F3 #x7E89 +#xE5F4 #x7E8C +#xE5F5 #x7E92 +#xE5F6 #x7E90 +#xE5F7 #x7E93 +#xE5F8 #x7E94 +#xE5F9 #x7E96 +#xE5FA #x7E8E +#xE5FB #x7E9B +#xE5FC #x7E9C +#xE5FD #x7F38 +#xE5FE #x7F3A +#xE6A1 #x7F45 +#xE6A2 #x7F4C +#xE6A3 #x7F4D +#xE6A4 #x7F4E +#xE6A5 #x7F50 +#xE6A6 #x7F51 +#xE6A7 #x7F55 +#xE6A8 #x7F54 +#xE6A9 #x7F58 +#xE6AA #x7F5F +#xE6AB #x7F60 +#xE6AC #x7F68 +#xE6AD #x7F69 +#xE6AE #x7F67 +#xE6AF #x7F78 +#xE6B0 #x7F82 +#xE6B1 #x7F86 +#xE6B2 #x7F83 +#xE6B3 #x7F88 +#xE6B4 #x7F87 +#xE6B5 #x7F8C +#xE6B6 #x7F94 +#xE6B7 #x7F9E +#xE6B8 #x7F9D +#xE6B9 #x7F9A +#xE6BA #x7FA3 +#xE6BB #x7FAF +#xE6BC #x7FB2 +#xE6BD #x7FB9 +#xE6BE #x7FAE +#xE6BF #x7FB6 +#xE6C0 #x7FB8 +#xE6C1 #x8B71 +#xE6C2 #x7FC5 +#xE6C3 #x7FC6 +#xE6C4 #x7FCA +#xE6C5 #x7FD5 +#xE6C6 #x7FD4 +#xE6C7 #x7FE1 +#xE6C8 #x7FE6 +#xE6C9 #x7FE9 +#xE6CA #x7FF3 +#xE6CB #x7FF9 +#xE6CC #x98DC +#xE6CD #x8006 +#xE6CE #x8004 +#xE6CF #x800B +#xE6D0 #x8012 +#xE6D1 #x8018 +#xE6D2 #x8019 +#xE6D3 #x801C +#xE6D4 #x8021 +#xE6D5 #x8028 +#xE6D6 #x803F +#xE6D7 #x803B +#xE6D8 #x804A +#xE6D9 #x8046 +#xE6DA #x8052 +#xE6DB #x8058 +#xE6DC #x805A +#xE6DD #x805F +#xE6DE #x8062 +#xE6DF #x8068 +#xE6E0 #x8073 +#xE6E1 #x8072 +#xE6E2 #x8070 +#xE6E3 #x8076 +#xE6E4 #x8079 +#xE6E5 #x807D +#xE6E6 #x807F +#xE6E7 #x8084 +#xE6E8 #x8086 +#xE6E9 #x8085 +#xE6EA #x809B +#xE6EB #x8093 +#xE6EC #x809A +#xE6ED #x80AD +#xE6EE #x5190 +#xE6EF #x80AC +#xE6F0 #x80DB +#xE6F1 #x80E5 +#xE6F2 #x80D9 +#xE6F3 #x80DD +#xE6F4 #x80C4 +#xE6F5 #x80DA +#xE6F6 #x80D6 +#xE6F7 #x8109 +#xE6F8 #x80EF +#xE6F9 #x80F1 +#xE6FA #x811B +#xE6FB #x8129 +#xE6FC #x8123 +#xE6FD #x812F +#xE6FE #x814B +#xE7A1 #x968B +#xE7A2 #x8146 +#xE7A3 #x813E +#xE7A4 #x8153 +#xE7A5 #x8151 +#xE7A6 #x80FC +#xE7A7 #x8171 +#xE7A8 #x816E +#xE7A9 #x8165 +#xE7AA #x8166 +#xE7AB #x8174 +#xE7AC #x8183 +#xE7AD #x8188 +#xE7AE #x818A +#xE7AF #x8180 +#xE7B0 #x8182 +#xE7B1 #x81A0 +#xE7B2 #x8195 +#xE7B3 #x81A4 +#xE7B4 #x81A3 +#xE7B5 #x815F +#xE7B6 #x8193 +#xE7B7 #x81A9 +#xE7B8 #x81B0 +#xE7B9 #x81B5 +#xE7BA #x81BE +#xE7BB #x81B8 +#xE7BC #x81BD +#xE7BD #x81C0 +#xE7BE #x81C2 +#xE7BF #x81BA +#xE7C0 #x81C9 +#xE7C1 #x81CD +#xE7C2 #x81D1 +#xE7C3 #x81D9 +#xE7C4 #x81D8 +#xE7C5 #x81C8 +#xE7C6 #x81DA +#xE7C7 #x81DF +#xE7C8 #x81E0 +#xE7C9 #x81E7 +#xE7CA #x81FA +#xE7CB #x81FB +#xE7CC #x81FE +#xE7CD #x8201 +#xE7CE #x8202 +#xE7CF #x8205 +#xE7D0 #x8207 +#xE7D1 #x820A +#xE7D2 #x820D +#xE7D3 #x8210 +#xE7D4 #x8216 +#xE7D5 #x8229 +#xE7D6 #x822B +#xE7D7 #x8238 +#xE7D8 #x8233 +#xE7D9 #x8240 +#xE7DA #x8259 +#xE7DB #x8258 +#xE7DC #x825D +#xE7DD #x825A +#xE7DE #x825F +#xE7DF #x8264 +#xE7E0 #x8262 +#xE7E1 #x8268 +#xE7E2 #x826A +#xE7E3 #x826B +#xE7E4 #x822E +#xE7E5 #x8271 +#xE7E6 #x8277 +#xE7E7 #x8278 +#xE7E8 #x827E +#xE7E9 #x828D +#xE7EA #x8292 +#xE7EB #x82AB +#xE7EC #x829F +#xE7ED #x82BB +#xE7EE #x82AC +#xE7EF #x82E1 +#xE7F0 #x82E3 +#xE7F1 #x82DF +#xE7F2 #x82D2 +#xE7F3 #x82F4 +#xE7F4 #x82F3 +#xE7F5 #x82FA +#xE7F6 #x8393 +#xE7F7 #x8303 +#xE7F8 #x82FB +#xE7F9 #x82F9 +#xE7FA #x82DE +#xE7FB #x8306 +#xE7FC #x82DC +#xE7FD #x8309 +#xE7FE #x82D9 +#xE8A1 #x8335 +#xE8A2 #x8334 +#xE8A3 #x8316 +#xE8A4 #x8332 +#xE8A5 #x8331 +#xE8A6 #x8340 +#xE8A7 #x8339 +#xE8A8 #x8350 +#xE8A9 #x8345 +#xE8AA #x832F +#xE8AB #x832B +#xE8AC #x8317 +#xE8AD #x8318 +#xE8AE #x8385 +#xE8AF #x839A +#xE8B0 #x83AA +#xE8B1 #x839F +#xE8B2 #x83A2 +#xE8B3 #x8396 +#xE8B4 #x8323 +#xE8B5 #x838E +#xE8B6 #x8387 +#xE8B7 #x838A +#xE8B8 #x837C +#xE8B9 #x83B5 +#xE8BA #x8373 +#xE8BB #x8375 +#xE8BC #x83A0 +#xE8BD #x8389 +#xE8BE #x83A8 +#xE8BF #x83F4 +#xE8C0 #x8413 +#xE8C1 #x83EB +#xE8C2 #x83CE +#xE8C3 #x83FD +#xE8C4 #x8403 +#xE8C5 #x83D8 +#xE8C6 #x840B +#xE8C7 #x83C1 +#xE8C8 #x83F7 +#xE8C9 #x8407 +#xE8CA #x83E0 +#xE8CB #x83F2 +#xE8CC #x840D +#xE8CD #x8422 +#xE8CE #x8420 +#xE8CF #x83BD +#xE8D0 #x8438 +#xE8D1 #x8506 +#xE8D2 #x83FB +#xE8D3 #x846D +#xE8D4 #x842A +#xE8D5 #x843C +#xE8D6 #x855A +#xE8D7 #x8484 +#xE8D8 #x8477 +#xE8D9 #x846B +#xE8DA #x84AD +#xE8DB #x846E +#xE8DC #x8482 +#xE8DD #x8469 +#xE8DE #x8446 +#xE8DF #x842C +#xE8E0 #x846F +#xE8E1 #x8479 +#xE8E2 #x8435 +#xE8E3 #x84CA +#xE8E4 #x8462 +#xE8E5 #x84B9 +#xE8E6 #x84BF +#xE8E7 #x849F +#xE8E8 #x84D9 +#xE8E9 #x84CD +#xE8EA #x84BB +#xE8EB #x84DA +#xE8EC #x84D0 +#xE8ED #x84C1 +#xE8EE #x84C6 +#xE8EF #x84D6 +#xE8F0 #x84A1 +#xE8F1 #x8521 +#xE8F2 #x84FF +#xE8F3 #x84F4 +#xE8F4 #x8517 +#xE8F5 #x8518 +#xE8F6 #x852C +#xE8F7 #x851F +#xE8F8 #x8515 +#xE8F9 #x8514 +#xE8FA #x84FC +#xE8FB #x8540 +#xE8FC #x8563 +#xE8FD #x8558 +#xE8FE #x8548 +#xE9A1 #x8541 +#xE9A2 #x8602 +#xE9A3 #x854B +#xE9A4 #x8555 +#xE9A5 #x8580 +#xE9A6 #x85A4 +#xE9A7 #x8588 +#xE9A8 #x8591 +#xE9A9 #x858A +#xE9AA #x85A8 +#xE9AB #x856D +#xE9AC #x8594 +#xE9AD #x859B +#xE9AE #x85EA +#xE9AF #x8587 +#xE9B0 #x859C +#xE9B1 #x8577 +#xE9B2 #x857E +#xE9B3 #x8590 +#xE9B4 #x85C9 +#xE9B5 #x85BA +#xE9B6 #x85CF +#xE9B7 #x85B9 +#xE9B8 #x85D0 +#xE9B9 #x85D5 +#xE9BA #x85DD +#xE9BB #x85E5 +#xE9BC #x85DC +#xE9BD #x85F9 +#xE9BE #x860A +#xE9BF #x8613 +#xE9C0 #x860B +#xE9C1 #x85FE +#xE9C2 #x85FA +#xE9C3 #x8606 +#xE9C4 #x8622 +#xE9C5 #x861A +#xE9C6 #x8630 +#xE9C7 #x863F +#xE9C8 #x864D +#xE9C9 #x4E55 +#xE9CA #x8654 +#xE9CB #x865F +#xE9CC #x8667 +#xE9CD #x8671 +#xE9CE #x8693 +#xE9CF #x86A3 +#xE9D0 #x86A9 +#xE9D1 #x86AA +#xE9D2 #x868B +#xE9D3 #x868C +#xE9D4 #x86B6 +#xE9D5 #x86AF +#xE9D6 #x86C4 +#xE9D7 #x86C6 +#xE9D8 #x86B0 +#xE9D9 #x86C9 +#xE9DA #x8823 +#xE9DB #x86AB +#xE9DC #x86D4 +#xE9DD #x86DE +#xE9DE #x86E9 +#xE9DF #x86EC +#xE9E0 #x86DF +#xE9E1 #x86DB +#xE9E2 #x86EF +#xE9E3 #x8712 +#xE9E4 #x8706 +#xE9E5 #x8708 +#xE9E6 #x8700 +#xE9E7 #x8703 +#xE9E8 #x86FB +#xE9E9 #x8711 +#xE9EA #x8709 +#xE9EB #x870D +#xE9EC #x86F9 +#xE9ED #x870A +#xE9EE #x8734 +#xE9EF #x873F +#xE9F0 #x8737 +#xE9F1 #x873B +#xE9F2 #x8725 +#xE9F3 #x8729 +#xE9F4 #x871A +#xE9F5 #x8760 +#xE9F6 #x875F +#xE9F7 #x8778 +#xE9F8 #x874C +#xE9F9 #x874E +#xE9FA #x8774 +#xE9FB #x8757 +#xE9FC #x8768 +#xE9FD #x876E +#xE9FE #x8759 +#xEAA1 #x8753 +#xEAA2 #x8763 +#xEAA3 #x876A +#xEAA4 #x8805 +#xEAA5 #x87A2 +#xEAA6 #x879F +#xEAA7 #x8782 +#xEAA8 #x87AF +#xEAA9 #x87CB +#xEAAA #x87BD +#xEAAB #x87C0 +#xEAAC #x87D0 +#xEAAD #x96D6 +#xEAAE #x87AB +#xEAAF #x87C4 +#xEAB0 #x87B3 +#xEAB1 #x87C7 +#xEAB2 #x87C6 +#xEAB3 #x87BB +#xEAB4 #x87EF +#xEAB5 #x87F2 +#xEAB6 #x87E0 +#xEAB7 #x880F +#xEAB8 #x880D +#xEAB9 #x87FE +#xEABA #x87F6 +#xEABB #x87F7 +#xEABC #x880E +#xEABD #x87D2 +#xEABE #x8811 +#xEABF #x8816 +#xEAC0 #x8815 +#xEAC1 #x8822 +#xEAC2 #x8821 +#xEAC3 #x8831 +#xEAC4 #x8836 +#xEAC5 #x8839 +#xEAC6 #x8827 +#xEAC7 #x883B +#xEAC8 #x8844 +#xEAC9 #x8842 +#xEACA #x8852 +#xEACB #x8859 +#xEACC #x885E +#xEACD #x8862 +#xEACE #x886B +#xEACF #x8881 +#xEAD0 #x887E +#xEAD1 #x889E +#xEAD2 #x8875 +#xEAD3 #x887D +#xEAD4 #x88B5 +#xEAD5 #x8872 +#xEAD6 #x8882 +#xEAD7 #x8897 +#xEAD8 #x8892 +#xEAD9 #x88AE +#xEADA #x8899 +#xEADB #x88A2 +#xEADC #x888D +#xEADD #x88A4 +#xEADE #x88B0 +#xEADF #x88BF +#xEAE0 #x88B1 +#xEAE1 #x88C3 +#xEAE2 #x88C4 +#xEAE3 #x88D4 +#xEAE4 #x88D8 +#xEAE5 #x88D9 +#xEAE6 #x88DD +#xEAE7 #x88F9 +#xEAE8 #x8902 +#xEAE9 #x88FC +#xEAEA #x88F4 +#xEAEB #x88E8 +#xEAEC #x88F2 +#xEAED #x8904 +#xEAEE #x890C +#xEAEF #x890A +#xEAF0 #x8913 +#xEAF1 #x8943 +#xEAF2 #x891E +#xEAF3 #x8925 +#xEAF4 #x892A +#xEAF5 #x892B +#xEAF6 #x8941 +#xEAF7 #x8944 +#xEAF8 #x893B +#xEAF9 #x8936 +#xEAFA #x8938 +#xEAFB #x894C +#xEAFC #x891D +#xEAFD #x8960 +#xEAFE #x895E +#xEBA1 #x8966 +#xEBA2 #x8964 +#xEBA3 #x896D +#xEBA4 #x896A +#xEBA5 #x896F +#xEBA6 #x8974 +#xEBA7 #x8977 +#xEBA8 #x897E +#xEBA9 #x8983 +#xEBAA #x8988 +#xEBAB #x898A +#xEBAC #x8993 +#xEBAD #x8998 +#xEBAE #x89A1 +#xEBAF #x89A9 +#xEBB0 #x89A6 +#xEBB1 #x89AC +#xEBB2 #x89AF +#xEBB3 #x89B2 +#xEBB4 #x89BA +#xEBB5 #x89BD +#xEBB6 #x89BF +#xEBB7 #x89C0 +#xEBB8 #x89DA +#xEBB9 #x89DC +#xEBBA #x89DD +#xEBBB #x89E7 +#xEBBC #x89F4 +#xEBBD #x89F8 +#xEBBE #x8A03 +#xEBBF #x8A16 +#xEBC0 #x8A10 +#xEBC1 #x8A0C +#xEBC2 #x8A1B +#xEBC3 #x8A1D +#xEBC4 #x8A25 +#xEBC5 #x8A36 +#xEBC6 #x8A41 +#xEBC7 #x8A5B +#xEBC8 #x8A52 +#xEBC9 #x8A46 +#xEBCA #x8A48 +#xEBCB #x8A7C +#xEBCC #x8A6D +#xEBCD #x8A6C +#xEBCE #x8A62 +#xEBCF #x8A85 +#xEBD0 #x8A82 +#xEBD1 #x8A84 +#xEBD2 #x8AA8 +#xEBD3 #x8AA1 +#xEBD4 #x8A91 +#xEBD5 #x8AA5 +#xEBD6 #x8AA6 +#xEBD7 #x8A9A +#xEBD8 #x8AA3 +#xEBD9 #x8AC4 +#xEBDA #x8ACD +#xEBDB #x8AC2 +#xEBDC #x8ADA +#xEBDD #x8AEB +#xEBDE #x8AF3 +#xEBDF #x8AE7 +#xEBE0 #x8AE4 +#xEBE1 #x8AF1 +#xEBE2 #x8B14 +#xEBE3 #x8AE0 +#xEBE4 #x8AE2 +#xEBE5 #x8AF7 +#xEBE6 #x8ADE +#xEBE7 #x8ADB +#xEBE8 #x8B0C +#xEBE9 #x8B07 +#xEBEA #x8B1A +#xEBEB #x8AE1 +#xEBEC #x8B16 +#xEBED #x8B10 +#xEBEE #x8B17 +#xEBEF #x8B20 +#xEBF0 #x8B33 +#xEBF1 #x97AB +#xEBF2 #x8B26 +#xEBF3 #x8B2B +#xEBF4 #x8B3E +#xEBF5 #x8B28 +#xEBF6 #x8B41 +#xEBF7 #x8B4C +#xEBF8 #x8B4F +#xEBF9 #x8B4E +#xEBFA #x8B49 +#xEBFB #x8B56 +#xEBFC #x8B5B +#xEBFD #x8B5A +#xEBFE #x8B6B +#xECA1 #x8B5F +#xECA2 #x8B6C +#xECA3 #x8B6F +#xECA4 #x8B74 +#xECA5 #x8B7D +#xECA6 #x8B80 +#xECA7 #x8B8C +#xECA8 #x8B8E +#xECA9 #x8B92 +#xECAA #x8B93 +#xECAB #x8B96 +#xECAC #x8B99 +#xECAD #x8B9A +#xECAE #x8C3A +#xECAF #x8C41 +#xECB0 #x8C3F +#xECB1 #x8C48 +#xECB2 #x8C4C +#xECB3 #x8C4E +#xECB4 #x8C50 +#xECB5 #x8C55 +#xECB6 #x8C62 +#xECB7 #x8C6C +#xECB8 #x8C78 +#xECB9 #x8C7A +#xECBA #x8C82 +#xECBB #x8C89 +#xECBC #x8C85 +#xECBD #x8C8A +#xECBE #x8C8D +#xECBF #x8C8E +#xECC0 #x8C94 +#xECC1 #x8C7C +#xECC2 #x8C98 +#xECC3 #x621D +#xECC4 #x8CAD +#xECC5 #x8CAA +#xECC6 #x8CBD +#xECC7 #x8CB2 +#xECC8 #x8CB3 +#xECC9 #x8CAE +#xECCA #x8CB6 +#xECCB #x8CC8 +#xECCC #x8CC1 +#xECCD #x8CE4 +#xECCE #x8CE3 +#xECCF #x8CDA +#xECD0 #x8CFD +#xECD1 #x8CFA +#xECD2 #x8CFB +#xECD3 #x8D04 +#xECD4 #x8D05 +#xECD5 #x8D0A +#xECD6 #x8D07 +#xECD7 #x8D0F +#xECD8 #x8D0D +#xECD9 #x8D10 +#xECDA #x9F4E +#xECDB #x8D13 +#xECDC #x8CCD +#xECDD #x8D14 +#xECDE #x8D16 +#xECDF #x8D67 +#xECE0 #x8D6D +#xECE1 #x8D71 +#xECE2 #x8D73 +#xECE3 #x8D81 +#xECE4 #x8D99 +#xECE5 #x8DC2 +#xECE6 #x8DBE +#xECE7 #x8DBA +#xECE8 #x8DCF +#xECE9 #x8DDA +#xECEA #x8DD6 +#xECEB #x8DCC +#xECEC #x8DDB +#xECED #x8DCB +#xECEE #x8DEA +#xECEF #x8DEB +#xECF0 #x8DDF +#xECF1 #x8DE3 +#xECF2 #x8DFC +#xECF3 #x8E08 +#xECF4 #x8E09 +#xECF5 #x8DFF +#xECF6 #x8E1D +#xECF7 #x8E1E +#xECF8 #x8E10 +#xECF9 #x8E1F +#xECFA #x8E42 +#xECFB #x8E35 +#xECFC #x8E30 +#xECFD #x8E34 +#xECFE #x8E4A +#xEDA1 #x8E47 +#xEDA2 #x8E49 +#xEDA3 #x8E4C +#xEDA4 #x8E50 +#xEDA5 #x8E48 +#xEDA6 #x8E59 +#xEDA7 #x8E64 +#xEDA8 #x8E60 +#xEDA9 #x8E2A +#xEDAA #x8E63 +#xEDAB #x8E55 +#xEDAC #x8E76 +#xEDAD #x8E72 +#xEDAE #x8E7C +#xEDAF #x8E81 +#xEDB0 #x8E87 +#xEDB1 #x8E85 +#xEDB2 #x8E84 +#xEDB3 #x8E8B +#xEDB4 #x8E8A +#xEDB5 #x8E93 +#xEDB6 #x8E91 +#xEDB7 #x8E94 +#xEDB8 #x8E99 +#xEDB9 #x8EAA +#xEDBA #x8EA1 +#xEDBB #x8EAC +#xEDBC #x8EB0 +#xEDBD #x8EC6 +#xEDBE #x8EB1 +#xEDBF #x8EBE +#xEDC0 #x8EC5 +#xEDC1 #x8EC8 +#xEDC2 #x8ECB +#xEDC3 #x8EDB +#xEDC4 #x8EE3 +#xEDC5 #x8EFC +#xEDC6 #x8EFB +#xEDC7 #x8EEB +#xEDC8 #x8EFE +#xEDC9 #x8F0A +#xEDCA #x8F05 +#xEDCB #x8F15 +#xEDCC #x8F12 +#xEDCD #x8F19 +#xEDCE #x8F13 +#xEDCF #x8F1C +#xEDD0 #x8F1F +#xEDD1 #x8F1B +#xEDD2 #x8F0C +#xEDD3 #x8F26 +#xEDD4 #x8F33 +#xEDD5 #x8F3B +#xEDD6 #x8F39 +#xEDD7 #x8F45 +#xEDD8 #x8F42 +#xEDD9 #x8F3E +#xEDDA #x8F4C +#xEDDB #x8F49 +#xEDDC #x8F46 +#xEDDD #x8F4E +#xEDDE #x8F57 +#xEDDF #x8F5C +#xEDE0 #x8F62 +#xEDE1 #x8F63 +#xEDE2 #x8F64 +#xEDE3 #x8F9C +#xEDE4 #x8F9F +#xEDE5 #x8FA3 +#xEDE6 #x8FAD +#xEDE7 #x8FAF +#xEDE8 #x8FB7 +#xEDE9 #x8FDA +#xEDEA #x8FE5 +#xEDEB #x8FE2 +#xEDEC #x8FEA +#xEDED #x8FEF +#xEDEE #x9087 +#xEDEF #x8FF4 +#xEDF0 #x9005 +#xEDF1 #x8FF9 +#xEDF2 #x8FFA +#xEDF3 #x9011 +#xEDF4 #x9015 +#xEDF5 #x9021 +#xEDF6 #x900D +#xEDF7 #x901E +#xEDF8 #x9016 +#xEDF9 #x900B +#xEDFA #x9027 +#xEDFB #x9036 +#xEDFC #x9035 +#xEDFD #x9039 +#xEDFE #x8FF8 +#xEEA1 #x904F +#xEEA2 #x9050 +#xEEA3 #x9051 +#xEEA4 #x9052 +#xEEA5 #x900E +#xEEA6 #x9049 +#xEEA7 #x903E +#xEEA8 #x9056 +#xEEA9 #x9058 +#xEEAA #x905E +#xEEAB #x9068 +#xEEAC #x906F +#xEEAD #x9076 +#xEEAE #x96A8 +#xEEAF #x9072 +#xEEB0 #x9082 +#xEEB1 #x907D +#xEEB2 #x9081 +#xEEB3 #x9080 +#xEEB4 #x908A +#xEEB5 #x9089 +#xEEB6 #x908F +#xEEB7 #x90A8 +#xEEB8 #x90AF +#xEEB9 #x90B1 +#xEEBA #x90B5 +#xEEBB #x90E2 +#xEEBC #x90E4 +#xEEBD #x6248 +#xEEBE #x90DB +#xEEBF #x9102 +#xEEC0 #x9112 +#xEEC1 #x9119 +#xEEC2 #x9132 +#xEEC3 #x9130 +#xEEC4 #x914A +#xEEC5 #x9156 +#xEEC6 #x9158 +#xEEC7 #x9163 +#xEEC8 #x9165 +#xEEC9 #x9169 +#xEECA #x9173 +#xEECB #x9172 +#xEECC #x918B +#xEECD #x9189 +#xEECE #x9182 +#xEECF #x91A2 +#xEED0 #x91AB +#xEED1 #x91AF +#xEED2 #x91AA +#xEED3 #x91B5 +#xEED4 #x91B4 +#xEED5 #x91BA +#xEED6 #x91C0 +#xEED7 #x91C1 +#xEED8 #x91C9 +#xEED9 #x91CB +#xEEDA #x91D0 +#xEEDB #x91D6 +#xEEDC #x91DF +#xEEDD #x91E1 +#xEEDE #x91DB +#xEEDF #x91FC +#xEEE0 #x91F5 +#xEEE1 #x91F6 +#xEEE2 #x921E +#xEEE3 #x91FF +#xEEE4 #x9214 +#xEEE5 #x922C +#xEEE6 #x9215 +#xEEE7 #x9211 +#xEEE8 #x925E +#xEEE9 #x9257 +#xEEEA #x9245 +#xEEEB #x9249 +#xEEEC #x9264 +#xEEED #x9248 +#xEEEE #x9295 +#xEEEF #x923F +#xEEF0 #x924B +#xEEF1 #x9250 +#xEEF2 #x929C +#xEEF3 #x9296 +#xEEF4 #x9293 +#xEEF5 #x929B +#xEEF6 #x925A +#xEEF7 #x92CF +#xEEF8 #x92B9 +#xEEF9 #x92B7 +#xEEFA #x92E9 +#xEEFB #x930F +#xEEFC #x92FA +#xEEFD #x9344 +#xEEFE #x932E +#xEFA1 #x9319 +#xEFA2 #x9322 +#xEFA3 #x931A +#xEFA4 #x9323 +#xEFA5 #x933A +#xEFA6 #x9335 +#xEFA7 #x933B +#xEFA8 #x935C +#xEFA9 #x9360 +#xEFAA #x937C +#xEFAB #x936E +#xEFAC #x9356 +#xEFAD #x93B0 +#xEFAE #x93AC +#xEFAF #x93AD +#xEFB0 #x9394 +#xEFB1 #x93B9 +#xEFB2 #x93D6 +#xEFB3 #x93D7 +#xEFB4 #x93E8 +#xEFB5 #x93E5 +#xEFB6 #x93D8 +#xEFB7 #x93C3 +#xEFB8 #x93DD +#xEFB9 #x93D0 +#xEFBA #x93C8 +#xEFBB #x93E4 +#xEFBC #x941A +#xEFBD #x9414 +#xEFBE #x9413 +#xEFBF #x9403 +#xEFC0 #x9407 +#xEFC1 #x9410 +#xEFC2 #x9436 +#xEFC3 #x942B +#xEFC4 #x9435 +#xEFC5 #x9421 +#xEFC6 #x943A +#xEFC7 #x9441 +#xEFC8 #x9452 +#xEFC9 #x9444 +#xEFCA #x945B +#xEFCB #x9460 +#xEFCC #x9462 +#xEFCD #x945E +#xEFCE #x946A +#xEFCF #x9229 +#xEFD0 #x9470 +#xEFD1 #x9475 +#xEFD2 #x9477 +#xEFD3 #x947D +#xEFD4 #x945A +#xEFD5 #x947C +#xEFD6 #x947E +#xEFD7 #x9481 +#xEFD8 #x947F +#xEFD9 #x9582 +#xEFDA #x9587 +#xEFDB #x958A +#xEFDC #x9594 +#xEFDD #x9596 +#xEFDE #x9598 +#xEFDF #x9599 +#xEFE0 #x95A0 +#xEFE1 #x95A8 +#xEFE2 #x95A7 +#xEFE3 #x95AD +#xEFE4 #x95BC +#xEFE5 #x95BB +#xEFE6 #x95B9 +#xEFE7 #x95BE +#xEFE8 #x95CA +#xEFE9 #x6FF6 +#xEFEA #x95C3 +#xEFEB #x95CD +#xEFEC #x95CC +#xEFED #x95D5 +#xEFEE #x95D4 +#xEFEF #x95D6 +#xEFF0 #x95DC +#xEFF1 #x95E1 +#xEFF2 #x95E5 +#xEFF3 #x95E2 +#xEFF4 #x9621 +#xEFF5 #x9628 +#xEFF6 #x962E +#xEFF7 #x962F +#xEFF8 #x9642 +#xEFF9 #x964C +#xEFFA #x964F +#xEFFB #x964B +#xEFFC #x9677 +#xEFFD #x965C +#xEFFE #x965E +#xF0A1 #x965D +#xF0A2 #x965F +#xF0A3 #x9666 +#xF0A4 #x9672 +#xF0A5 #x966C +#xF0A6 #x968D +#xF0A7 #x9698 +#xF0A8 #x9695 +#xF0A9 #x9697 +#xF0AA #x96AA +#xF0AB #x96A7 +#xF0AC #x96B1 +#xF0AD #x96B2 +#xF0AE #x96B0 +#xF0AF #x96B4 +#xF0B0 #x96B6 +#xF0B1 #x96B8 +#xF0B2 #x96B9 +#xF0B3 #x96CE +#xF0B4 #x96CB +#xF0B5 #x96C9 +#xF0B6 #x96CD +#xF0B7 #x894D +#xF0B8 #x96DC +#xF0B9 #x970D +#xF0BA #x96D5 +#xF0BB #x96F9 +#xF0BC #x9704 +#xF0BD #x9706 +#xF0BE #x9708 +#xF0BF #x9713 +#xF0C0 #x970E +#xF0C1 #x9711 +#xF0C2 #x970F +#xF0C3 #x9716 +#xF0C4 #x9719 +#xF0C5 #x9724 +#xF0C6 #x972A +#xF0C7 #x9730 +#xF0C8 #x9739 +#xF0C9 #x973D +#xF0CA #x973E +#xF0CB #x9744 +#xF0CC #x9746 +#xF0CD #x9748 +#xF0CE #x9742 +#xF0CF #x9749 +#xF0D0 #x975C +#xF0D1 #x9760 +#xF0D2 #x9764 +#xF0D3 #x9766 +#xF0D4 #x9768 +#xF0D5 #x52D2 +#xF0D6 #x976B +#xF0D7 #x9771 +#xF0D8 #x9779 +#xF0D9 #x9785 +#xF0DA #x977C +#xF0DB #x9781 +#xF0DC #x977A +#xF0DD #x9786 +#xF0DE #x978B +#xF0DF #x978F +#xF0E0 #x9790 +#xF0E1 #x979C +#xF0E2 #x97A8 +#xF0E3 #x97A6 +#xF0E4 #x97A3 +#xF0E5 #x97B3 +#xF0E6 #x97B4 +#xF0E7 #x97C3 +#xF0E8 #x97C6 +#xF0E9 #x97C8 +#xF0EA #x97CB +#xF0EB #x97DC +#xF0EC #x97ED +#xF0ED #x9F4F +#xF0EE #x97F2 +#xF0EF #x7ADF +#xF0F0 #x97F6 +#xF0F1 #x97F5 +#xF0F2 #x980F +#xF0F3 #x980C +#xF0F4 #x9838 +#xF0F5 #x9824 +#xF0F6 #x9821 +#xF0F7 #x9837 +#xF0F8 #x983D +#xF0F9 #x9846 +#xF0FA #x984F +#xF0FB #x984B +#xF0FC #x986B +#xF0FD #x986F +#xF0FE #x9870 +#xF1A1 #x9871 +#xF1A2 #x9874 +#xF1A3 #x9873 +#xF1A4 #x98AA +#xF1A5 #x98AF +#xF1A6 #x98B1 +#xF1A7 #x98B6 +#xF1A8 #x98C4 +#xF1A9 #x98C3 +#xF1AA #x98C6 +#xF1AB #x98E9 +#xF1AC #x98EB +#xF1AD #x9903 +#xF1AE #x9909 +#xF1AF #x9912 +#xF1B0 #x9914 +#xF1B1 #x9918 +#xF1B2 #x9921 +#xF1B3 #x991D +#xF1B4 #x991E +#xF1B5 #x9924 +#xF1B6 #x9920 +#xF1B7 #x992C +#xF1B8 #x992E +#xF1B9 #x993D +#xF1BA #x993E +#xF1BB #x9942 +#xF1BC #x9949 +#xF1BD #x9945 +#xF1BE #x9950 +#xF1BF #x994B +#xF1C0 #x9951 +#xF1C1 #x9952 +#xF1C2 #x994C +#xF1C3 #x9955 +#xF1C4 #x9997 +#xF1C5 #x9998 +#xF1C6 #x99A5 +#xF1C7 #x99AD +#xF1C8 #x99AE +#xF1C9 #x99BC +#xF1CA #x99DF +#xF1CB #x99DB +#xF1CC #x99DD +#xF1CD #x99D8 +#xF1CE #x99D1 +#xF1CF #x99ED +#xF1D0 #x99EE +#xF1D1 #x99F1 +#xF1D2 #x99F2 +#xF1D3 #x99FB +#xF1D4 #x99F8 +#xF1D5 #x9A01 +#xF1D6 #x9A0F +#xF1D7 #x9A05 +#xF1D8 #x99E2 +#xF1D9 #x9A19 +#xF1DA #x9A2B +#xF1DB #x9A37 +#xF1DC #x9A45 +#xF1DD #x9A42 +#xF1DE #x9A40 +#xF1DF #x9A43 +#xF1E0 #x9A3E +#xF1E1 #x9A55 +#xF1E2 #x9A4D +#xF1E3 #x9A5B +#xF1E4 #x9A57 +#xF1E5 #x9A5F +#xF1E6 #x9A62 +#xF1E7 #x9A65 +#xF1E8 #x9A64 +#xF1E9 #x9A69 +#xF1EA #x9A6B +#xF1EB #x9A6A +#xF1EC #x9AAD +#xF1ED #x9AB0 +#xF1EE #x9ABC +#xF1EF #x9AC0 +#xF1F0 #x9ACF +#xF1F1 #x9AD1 +#xF1F2 #x9AD3 +#xF1F3 #x9AD4 +#xF1F4 #x9ADE +#xF1F5 #x9ADF +#xF1F6 #x9AE2 +#xF1F7 #x9AE3 +#xF1F8 #x9AE6 +#xF1F9 #x9AEF +#xF1FA #x9AEB +#xF1FB #x9AEE +#xF1FC #x9AF4 +#xF1FD #x9AF1 +#xF1FE #x9AF7 +#xF2A1 #x9AFB +#xF2A2 #x9B06 +#xF2A3 #x9B18 +#xF2A4 #x9B1A +#xF2A5 #x9B1F +#xF2A6 #x9B22 +#xF2A7 #x9B23 +#xF2A8 #x9B25 +#xF2A9 #x9B27 +#xF2AA #x9B28 +#xF2AB #x9B29 +#xF2AC #x9B2A +#xF2AD #x9B2E +#xF2AE #x9B2F +#xF2AF #x9B32 +#xF2B0 #x9B44 +#xF2B1 #x9B43 +#xF2B2 #x9B4F +#xF2B3 #x9B4D +#xF2B4 #x9B4E +#xF2B5 #x9B51 +#xF2B6 #x9B58 +#xF2B7 #x9B74 +#xF2B8 #x9B93 +#xF2B9 #x9B83 +#xF2BA #x9B91 +#xF2BB #x9B96 +#xF2BC #x9B97 +#xF2BD #x9B9F +#xF2BE #x9BA0 +#xF2BF #x9BA8 +#xF2C0 #x9BB4 +#xF2C1 #x9BC0 +#xF2C2 #x9BCA +#xF2C3 #x9BB9 +#xF2C4 #x9BC6 +#xF2C5 #x9BCF +#xF2C6 #x9BD1 +#xF2C7 #x9BD2 +#xF2C8 #x9BE3 +#xF2C9 #x9BE2 +#xF2CA #x9BE4 +#xF2CB #x9BD4 +#xF2CC #x9BE1 +#xF2CD #x9C3A +#xF2CE #x9BF2 +#xF2CF #x9BF1 +#xF2D0 #x9BF0 +#xF2D1 #x9C15 +#xF2D2 #x9C14 +#xF2D3 #x9C09 +#xF2D4 #x9C13 +#xF2D5 #x9C0C +#xF2D6 #x9C06 +#xF2D7 #x9C08 +#xF2D8 #x9C12 +#xF2D9 #x9C0A +#xF2DA #x9C04 +#xF2DB #x9C2E +#xF2DC #x9C1B +#xF2DD #x9C25 +#xF2DE #x9C24 +#xF2DF #x9C21 +#xF2E0 #x9C30 +#xF2E1 #x9C47 +#xF2E2 #x9C32 +#xF2E3 #x9C46 +#xF2E4 #x9C3E +#xF2E5 #x9C5A +#xF2E6 #x9C60 +#xF2E7 #x9C67 +#xF2E8 #x9C76 +#xF2E9 #x9C78 +#xF2EA #x9CE7 +#xF2EB #x9CEC +#xF2EC #x9CF0 +#xF2ED #x9D09 +#xF2EE #x9D08 +#xF2EF #x9CEB +#xF2F0 #x9D03 +#xF2F1 #x9D06 +#xF2F2 #x9D2A +#xF2F3 #x9D26 +#xF2F4 #x9DAF +#xF2F5 #x9D23 +#xF2F6 #x9D1F +#xF2F7 #x9D44 +#xF2F8 #x9D15 +#xF2F9 #x9D12 +#xF2FA #x9D41 +#xF2FB #x9D3F +#xF2FC #x9D3E +#xF2FD #x9D46 +#xF2FE #x9D48 +#xF3A1 #x9D5D +#xF3A2 #x9D5E +#xF3A3 #x9D64 +#xF3A4 #x9D51 +#xF3A5 #x9D50 +#xF3A6 #x9D59 +#xF3A7 #x9D72 +#xF3A8 #x9D89 +#xF3A9 #x9D87 +#xF3AA #x9DAB +#xF3AB #x9D6F +#xF3AC #x9D7A +#xF3AD #x9D9A +#xF3AE #x9DA4 +#xF3AF #x9DA9 +#xF3B0 #x9DB2 +#xF3B1 #x9DC4 +#xF3B2 #x9DC1 +#xF3B3 #x9DBB +#xF3B4 #x9DB8 +#xF3B5 #x9DBA +#xF3B6 #x9DC6 +#xF3B7 #x9DCF +#xF3B8 #x9DC2 +#xF3B9 #x9DD9 +#xF3BA #x9DD3 +#xF3BB #x9DF8 +#xF3BC #x9DE6 +#xF3BD #x9DED +#xF3BE #x9DEF +#xF3BF #x9DFD +#xF3C0 #x9E1A +#xF3C1 #x9E1B +#xF3C2 #x9E1E +#xF3C3 #x9E75 +#xF3C4 #x9E79 +#xF3C5 #x9E7D +#xF3C6 #x9E81 +#xF3C7 #x9E88 +#xF3C8 #x9E8B +#xF3C9 #x9E8C +#xF3CA #x9E92 +#xF3CB #x9E95 +#xF3CC #x9E91 +#xF3CD #x9E9D +#xF3CE #x9EA5 +#xF3CF #x9EA9 +#xF3D0 #x9EB8 +#xF3D1 #x9EAA +#xF3D2 #x9EAD +#xF3D3 #x9761 +#xF3D4 #x9ECC +#xF3D5 #x9ECE +#xF3D6 #x9ECF +#xF3D7 #x9ED0 +#xF3D8 #x9ED4 +#xF3D9 #x9EDC +#xF3DA #x9EDE +#xF3DB #x9EDD +#xF3DC #x9EE0 +#xF3DD #x9EE5 +#xF3DE #x9EE8 +#xF3DF #x9EEF +#xF3E0 #x9EF4 +#xF3E1 #x9EF6 +#xF3E2 #x9EF7 +#xF3E3 #x9EF9 +#xF3E4 #x9EFB +#xF3E5 #x9EFC +#xF3E6 #x9EFD +#xF3E7 #x9F07 +#xF3E8 #x9F08 +#xF3E9 #x76B7 +#xF3EA #x9F15 +#xF3EB #x9F21 +#xF3EC #x9F2C +#xF3ED #x9F3E +#xF3EE #x9F4A +#xF3EF #x9F52 +#xF3F0 #x9F54 +#xF3F1 #x9F63 +#xF3F2 #x9F5F +#xF3F3 #x9F60 +#xF3F4 #x9F61 +#xF3F5 #x9F66 +#xF3F6 #x9F67 +#xF3F7 #x9F6C +#xF3F8 #x9F6A +#xF3F9 #x9F77 +#xF3FA #x9F72 +#xF3FB #x9F76 +#xF3FC #x9F95 +#xF3FD #x9F9C +#xF3FE #x9FA0 +#xF4A1 #x582F +#xF4A2 #x69C7 +#xF4A3 #x9059 +#xF4A4 #x7464 +#xF4A5 #x51DC +#xF4A6 #x7199 +#x8FA2AF #x02D8 +#x8FA2B0 #x02C7 +#x8FA2B1 #x00B8 +#x8FA2B2 #x02D9 +#x8FA2B3 #x02DD +#x8FA2B4 #x00AF +#x8FA2B5 #x02DB +#x8FA2B6 #x02DA +#x8FA2B7 #xFF5E +#x8FA2B8 #x0384 +#x8FA2B9 #x0385 +#x8FA2C2 #x00A1 +#x8FA2C3 #x00A6 +#x8FA2C4 #x00BF +#x8FA2EB #x00BA +#x8FA2EC #x00AA +#x8FA2ED #x00A9 +#x8FA2EE #x00AE +#x8FA2EF #x2122 +#x8FA2F0 #x00A4 +#x8FA2F1 #x2116 +#x8FA6E1 #x0386 +#x8FA6E2 #x0388 +#x8FA6E3 #x0389 +#x8FA6E4 #x038A +#x8FA6E5 #x03AA +#x8FA6E7 #x038C +#x8FA6E9 #x038E +#x8FA6EA #x03AB +#x8FA6EC #x038F +#x8FA6F1 #x03AC +#x8FA6F2 #x03AD +#x8FA6F3 #x03AE +#x8FA6F4 #x03AF +#x8FA6F5 #x03CA +#x8FA6F6 #x0390 +#x8FA6F7 #x03CC +#x8FA6F8 #x03C2 +#x8FA6F9 #x03CD +#x8FA6FA #x03CB +#x8FA6FB #x03B0 +#x8FA6FC #x03CE +#x8FA7C2 #x0402 +#x8FA7C3 #x0403 +#x8FA7C4 #x0404 +#x8FA7C5 #x0405 +#x8FA7C6 #x0406 +#x8FA7C7 #x0407 +#x8FA7C8 #x0408 +#x8FA7C9 #x0409 +#x8FA7CA #x040A +#x8FA7CB #x040B +#x8FA7CC #x040C +#x8FA7CD #x040E +#x8FA7CE #x040F +#x8FA7F2 #x0452 +#x8FA7F3 #x0453 +#x8FA7F4 #x0454 +#x8FA7F5 #x0455 +#x8FA7F6 #x0456 +#x8FA7F7 #x0457 +#x8FA7F8 #x0458 +#x8FA7F9 #x0459 +#x8FA7FA #x045A +#x8FA7FB #x045B +#x8FA7FC #x045C +#x8FA7FD #x045E +#x8FA7FE #x045F +#x8FA9A1 #x00C6 +#x8FA9A2 #x0110 +#x8FA9A4 #x0126 +#x8FA9A6 #x0132 +#x8FA9A8 #x0141 +#x8FA9A9 #x013F +#x8FA9AB #x014A +#x8FA9AC #x00D8 +#x8FA9AD #x0152 +#x8FA9AF #x0166 +#x8FA9B0 #x00DE +#x8FA9C1 #x00E6 +#x8FA9C2 #x0111 +#x8FA9C3 #x00F0 +#x8FA9C4 #x0127 +#x8FA9C5 #x0131 +#x8FA9C6 #x0133 +#x8FA9C7 #x0138 +#x8FA9C8 #x0142 +#x8FA9C9 #x0140 +#x8FA9CA #x0149 +#x8FA9CB #x014B +#x8FA9CC #x00F8 +#x8FA9CD #x0153 +#x8FA9CE #x00DF +#x8FA9CF #x0167 +#x8FA9D0 #x00FE +#x8FAAA1 #x00C1 +#x8FAAA2 #x00C0 +#x8FAAA3 #x00C4 +#x8FAAA4 #x00C2 +#x8FAAA5 #x0102 +#x8FAAA6 #x01CD +#x8FAAA7 #x0100 +#x8FAAA8 #x0104 +#x8FAAA9 #x00C5 +#x8FAAAA #x00C3 +#x8FAAAB #x0106 +#x8FAAAC #x0108 +#x8FAAAD #x010C +#x8FAAAE #x00C7 +#x8FAAAF #x010A +#x8FAAB0 #x010E +#x8FAAB1 #x00C9 +#x8FAAB2 #x00C8 +#x8FAAB3 #x00CB +#x8FAAB4 #x00CA +#x8FAAB5 #x011A +#x8FAAB6 #x0116 +#x8FAAB7 #x0112 +#x8FAAB8 #x0118 +#x8FAABA #x011C +#x8FAABB #x011E +#x8FAABC #x0122 +#x8FAABD #x0120 +#x8FAABE #x0124 +#x8FAABF #x00CD +#x8FAAC0 #x00CC +#x8FAAC1 #x00CF +#x8FAAC2 #x00CE +#x8FAAC3 #x01CF +#x8FAAC4 #x0130 +#x8FAAC5 #x012A +#x8FAAC6 #x012E +#x8FAAC7 #x0128 +#x8FAAC8 #x0134 +#x8FAAC9 #x0136 +#x8FAACA #x0139 +#x8FAACB #x013D +#x8FAACC #x013B +#x8FAACD #x0143 +#x8FAACE #x0147 +#x8FAACF #x0145 +#x8FAAD0 #x00D1 +#x8FAAD1 #x00D3 +#x8FAAD2 #x00D2 +#x8FAAD3 #x00D6 +#x8FAAD4 #x00D4 +#x8FAAD5 #x01D1 +#x8FAAD6 #x0150 +#x8FAAD7 #x014C +#x8FAAD8 #x00D5 +#x8FAAD9 #x0154 +#x8FAADA #x0158 +#x8FAADB #x0156 +#x8FAADC #x015A +#x8FAADD #x015C +#x8FAADE #x0160 +#x8FAADF #x015E +#x8FAAE0 #x0164 +#x8FAAE1 #x0162 +#x8FAAE2 #x00DA +#x8FAAE3 #x00D9 +#x8FAAE4 #x00DC +#x8FAAE5 #x00DB +#x8FAAE6 #x016C +#x8FAAE7 #x01D3 +#x8FAAE8 #x0170 +#x8FAAE9 #x016A +#x8FAAEA #x0172 +#x8FAAEB #x016E +#x8FAAEC #x0168 +#x8FAAED #x01D7 +#x8FAAEE #x01DB +#x8FAAEF #x01D9 +#x8FAAF0 #x01D5 +#x8FAAF1 #x0174 +#x8FAAF2 #x00DD +#x8FAAF3 #x0178 +#x8FAAF4 #x0176 +#x8FAAF5 #x0179 +#x8FAAF6 #x017D +#x8FAAF7 #x017B +#x8FABA1 #x00E1 +#x8FABA2 #x00E0 +#x8FABA3 #x00E4 +#x8FABA4 #x00E2 +#x8FABA5 #x0103 +#x8FABA6 #x01CE +#x8FABA7 #x0101 +#x8FABA8 #x0105 +#x8FABA9 #x00E5 +#x8FABAA #x00E3 +#x8FABAB #x0107 +#x8FABAC #x0109 +#x8FABAD #x010D +#x8FABAE #x00E7 +#x8FABAF #x010B +#x8FABB0 #x010F +#x8FABB1 #x00E9 +#x8FABB2 #x00E8 +#x8FABB3 #x00EB +#x8FABB4 #x00EA +#x8FABB5 #x011B +#x8FABB6 #x0117 +#x8FABB7 #x0113 +#x8FABB8 #x0119 +#x8FABB9 #x01F5 +#x8FABBA #x011D +#x8FABBB #x011F +#x8FABBD #x0121 +#x8FABBE #x0125 +#x8FABBF #x00ED +#x8FABC0 #x00EC +#x8FABC1 #x00EF +#x8FABC2 #x00EE +#x8FABC3 #x01D0 +#x8FABC5 #x012B +#x8FABC6 #x012F +#x8FABC7 #x0129 +#x8FABC8 #x0135 +#x8FABC9 #x0137 +#x8FABCA #x013A +#x8FABCB #x013E +#x8FABCC #x013C +#x8FABCD #x0144 +#x8FABCE #x0148 +#x8FABCF #x0146 +#x8FABD0 #x00F1 +#x8FABD1 #x00F3 +#x8FABD2 #x00F2 +#x8FABD3 #x00F6 +#x8FABD4 #x00F4 +#x8FABD5 #x01D2 +#x8FABD6 #x0151 +#x8FABD7 #x014D +#x8FABD8 #x00F5 +#x8FABD9 #x0155 +#x8FABDA #x0159 +#x8FABDB #x0157 +#x8FABDC #x015B +#x8FABDD #x015D +#x8FABDE #x0161 +#x8FABDF #x015F +#x8FABE0 #x0165 +#x8FABE1 #x0163 +#x8FABE2 #x00FA +#x8FABE3 #x00F9 +#x8FABE4 #x00FC +#x8FABE5 #x00FB +#x8FABE6 #x016D +#x8FABE7 #x01D4 +#x8FABE8 #x0171 +#x8FABE9 #x016B +#x8FABEA #x0173 +#x8FABEB #x016F +#x8FABEC #x0169 +#x8FABED #x01D8 +#x8FABEE #x01DC +#x8FABEF #x01DA +#x8FABF0 #x01D6 +#x8FABF1 #x0175 +#x8FABF2 #x00FD +#x8FABF3 #x00FF +#x8FABF4 #x0177 +#x8FABF5 #x017A +#x8FABF6 #x017E +#x8FABF7 #x017C +#x8FB0A1 #x4E02 +#x8FB0A2 #x4E04 +#x8FB0A3 #x4E05 +#x8FB0A4 #x4E0C +#x8FB0A5 #x4E12 +#x8FB0A6 #x4E1F +#x8FB0A7 #x4E23 +#x8FB0A8 #x4E24 +#x8FB0A9 #x4E28 +#x8FB0AA #x4E2B +#x8FB0AB #x4E2E +#x8FB0AC #x4E2F +#x8FB0AD #x4E30 +#x8FB0AE #x4E35 +#x8FB0AF #x4E40 +#x8FB0B0 #x4E41 +#x8FB0B1 #x4E44 +#x8FB0B2 #x4E47 +#x8FB0B3 #x4E51 +#x8FB0B4 #x4E5A +#x8FB0B5 #x4E5C +#x8FB0B6 #x4E63 +#x8FB0B7 #x4E68 +#x8FB0B8 #x4E69 +#x8FB0B9 #x4E74 +#x8FB0BA #x4E75 +#x8FB0BB #x4E79 +#x8FB0BC #x4E7F +#x8FB0BD #x4E8D +#x8FB0BE #x4E96 +#x8FB0BF #x4E97 +#x8FB0C0 #x4E9D +#x8FB0C1 #x4EAF +#x8FB0C2 #x4EB9 +#x8FB0C3 #x4EC3 +#x8FB0C4 #x4ED0 +#x8FB0C5 #x4EDA +#x8FB0C6 #x4EDB +#x8FB0C7 #x4EE0 +#x8FB0C8 #x4EE1 +#x8FB0C9 #x4EE2 +#x8FB0CA #x4EE8 +#x8FB0CB #x4EEF +#x8FB0CC #x4EF1 +#x8FB0CD #x4EF3 +#x8FB0CE #x4EF5 +#x8FB0CF #x4EFD +#x8FB0D0 #x4EFE +#x8FB0D1 #x4EFF +#x8FB0D2 #x4F00 +#x8FB0D3 #x4F02 +#x8FB0D4 #x4F03 +#x8FB0D5 #x4F08 +#x8FB0D6 #x4F0B +#x8FB0D7 #x4F0C +#x8FB0D8 #x4F12 +#x8FB0D9 #x4F15 +#x8FB0DA #x4F16 +#x8FB0DB #x4F17 +#x8FB0DC #x4F19 +#x8FB0DD #x4F2E +#x8FB0DE #x4F31 +#x8FB0DF #x4F60 +#x8FB0E0 #x4F33 +#x8FB0E1 #x4F35 +#x8FB0E2 #x4F37 +#x8FB0E3 #x4F39 +#x8FB0E4 #x4F3B +#x8FB0E5 #x4F3E +#x8FB0E6 #x4F40 +#x8FB0E7 #x4F42 +#x8FB0E8 #x4F48 +#x8FB0E9 #x4F49 +#x8FB0EA #x4F4B +#x8FB0EB #x4F4C +#x8FB0EC #x4F52 +#x8FB0ED #x4F54 +#x8FB0EE #x4F56 +#x8FB0EF #x4F58 +#x8FB0F0 #x4F5F +#x8FB0F1 #x4F63 +#x8FB0F2 #x4F6A +#x8FB0F3 #x4F6C +#x8FB0F4 #x4F6E +#x8FB0F5 #x4F71 +#x8FB0F6 #x4F77 +#x8FB0F7 #x4F78 +#x8FB0F8 #x4F79 +#x8FB0F9 #x4F7A +#x8FB0FA #x4F7D +#x8FB0FB #x4F7E +#x8FB0FC #x4F81 +#x8FB0FD #x4F82 +#x8FB0FE #x4F84 +#x8FB1A1 #x4F85 +#x8FB1A2 #x4F89 +#x8FB1A3 #x4F8A +#x8FB1A4 #x4F8C +#x8FB1A5 #x4F8E +#x8FB1A6 #x4F90 +#x8FB1A7 #x4F92 +#x8FB1A8 #x4F93 +#x8FB1A9 #x4F94 +#x8FB1AA #x4F97 +#x8FB1AB #x4F99 +#x8FB1AC #x4F9A +#x8FB1AD #x4F9E +#x8FB1AE #x4F9F +#x8FB1AF #x4FB2 +#x8FB1B0 #x4FB7 +#x8FB1B1 #x4FB9 +#x8FB1B2 #x4FBB +#x8FB1B3 #x4FBC +#x8FB1B4 #x4FBD +#x8FB1B5 #x4FBE +#x8FB1B6 #x4FC0 +#x8FB1B7 #x4FC1 +#x8FB1B8 #x4FC5 +#x8FB1B9 #x4FC6 +#x8FB1BA #x4FC8 +#x8FB1BB #x4FC9 +#x8FB1BC #x4FCB +#x8FB1BD #x4FCC +#x8FB1BE #x4FCD +#x8FB1BF #x4FCF +#x8FB1C0 #x4FD2 +#x8FB1C1 #x4FDC +#x8FB1C2 #x4FE0 +#x8FB1C3 #x4FE2 +#x8FB1C4 #x4FF0 +#x8FB1C5 #x4FF2 +#x8FB1C6 #x4FFC +#x8FB1C7 #x4FFD +#x8FB1C8 #x4FFF +#x8FB1C9 #x5000 +#x8FB1CA #x5001 +#x8FB1CB #x5004 +#x8FB1CC #x5007 +#x8FB1CD #x500A +#x8FB1CE #x500C +#x8FB1CF #x500E +#x8FB1D0 #x5010 +#x8FB1D1 #x5013 +#x8FB1D2 #x5017 +#x8FB1D3 #x5018 +#x8FB1D4 #x501B +#x8FB1D5 #x501C +#x8FB1D6 #x501D +#x8FB1D7 #x501E +#x8FB1D8 #x5022 +#x8FB1D9 #x5027 +#x8FB1DA #x502E +#x8FB1DB #x5030 +#x8FB1DC #x5032 +#x8FB1DD #x5033 +#x8FB1DE #x5035 +#x8FB1DF #x5040 +#x8FB1E0 #x5041 +#x8FB1E1 #x5042 +#x8FB1E2 #x5045 +#x8FB1E3 #x5046 +#x8FB1E4 #x504A +#x8FB1E5 #x504C +#x8FB1E6 #x504E +#x8FB1E7 #x5051 +#x8FB1E8 #x5052 +#x8FB1E9 #x5053 +#x8FB1EA #x5057 +#x8FB1EB #x5059 +#x8FB1EC #x505F +#x8FB1ED #x5060 +#x8FB1EE #x5062 +#x8FB1EF #x5063 +#x8FB1F0 #x5066 +#x8FB1F1 #x5067 +#x8FB1F2 #x506A +#x8FB1F3 #x506D +#x8FB1F4 #x5070 +#x8FB1F5 #x5071 +#x8FB1F6 #x503B +#x8FB1F7 #x5081 +#x8FB1F8 #x5083 +#x8FB1F9 #x5084 +#x8FB1FA #x5086 +#x8FB1FB #x508A +#x8FB1FC #x508E +#x8FB1FD #x508F +#x8FB1FE #x5090 +#x8FB2A1 #x5092 +#x8FB2A2 #x5093 +#x8FB2A3 #x5094 +#x8FB2A4 #x5096 +#x8FB2A5 #x509B +#x8FB2A6 #x509C +#x8FB2A7 #x509E +#x8FB2A8 #x509F +#x8FB2A9 #x50A0 +#x8FB2AA #x50A1 +#x8FB2AB #x50A2 +#x8FB2AC #x50AA +#x8FB2AD #x50AF +#x8FB2AE #x50B0 +#x8FB2AF #x50B9 +#x8FB2B0 #x50BA +#x8FB2B1 #x50BD +#x8FB2B2 #x50C0 +#x8FB2B3 #x50C3 +#x8FB2B4 #x50C4 +#x8FB2B5 #x50C7 +#x8FB2B6 #x50CC +#x8FB2B7 #x50CE +#x8FB2B8 #x50D0 +#x8FB2B9 #x50D3 +#x8FB2BA #x50D4 +#x8FB2BB #x50D8 +#x8FB2BC #x50DC +#x8FB2BD #x50DD +#x8FB2BE #x50DF +#x8FB2BF #x50E2 +#x8FB2C0 #x50E4 +#x8FB2C1 #x50E6 +#x8FB2C2 #x50E8 +#x8FB2C3 #x50E9 +#x8FB2C4 #x50EF +#x8FB2C5 #x50F1 +#x8FB2C6 #x50F6 +#x8FB2C7 #x50FA +#x8FB2C8 #x50FE +#x8FB2C9 #x5103 +#x8FB2CA #x5106 +#x8FB2CB #x5107 +#x8FB2CC #x5108 +#x8FB2CD #x510B +#x8FB2CE #x510C +#x8FB2CF #x510D +#x8FB2D0 #x510E +#x8FB2D1 #x50F2 +#x8FB2D2 #x5110 +#x8FB2D3 #x5117 +#x8FB2D4 #x5119 +#x8FB2D5 #x511B +#x8FB2D6 #x511C +#x8FB2D7 #x511D +#x8FB2D8 #x511E +#x8FB2D9 #x5123 +#x8FB2DA #x5127 +#x8FB2DB #x5128 +#x8FB2DC #x512C +#x8FB2DD #x512D +#x8FB2DE #x512F +#x8FB2DF #x5131 +#x8FB2E0 #x5133 +#x8FB2E1 #x5134 +#x8FB2E2 #x5135 +#x8FB2E3 #x5138 +#x8FB2E4 #x5139 +#x8FB2E5 #x5142 +#x8FB2E6 #x514A +#x8FB2E7 #x514F +#x8FB2E8 #x5153 +#x8FB2E9 #x5155 +#x8FB2EA #x5157 +#x8FB2EB #x5158 +#x8FB2EC #x515F +#x8FB2ED #x5164 +#x8FB2EE #x5166 +#x8FB2EF #x517E +#x8FB2F0 #x5183 +#x8FB2F1 #x5184 +#x8FB2F2 #x518B +#x8FB2F3 #x518E +#x8FB2F4 #x5198 +#x8FB2F5 #x519D +#x8FB2F6 #x51A1 +#x8FB2F7 #x51A3 +#x8FB2F8 #x51AD +#x8FB2F9 #x51B8 +#x8FB2FA #x51BA +#x8FB2FB #x51BC +#x8FB2FC #x51BE +#x8FB2FD #x51BF +#x8FB2FE #x51C2 +#x8FB3A1 #x51C8 +#x8FB3A2 #x51CF +#x8FB3A3 #x51D1 +#x8FB3A4 #x51D2 +#x8FB3A5 #x51D3 +#x8FB3A6 #x51D5 +#x8FB3A7 #x51D8 +#x8FB3A8 #x51DE +#x8FB3A9 #x51E2 +#x8FB3AA #x51E5 +#x8FB3AB #x51EE +#x8FB3AC #x51F2 +#x8FB3AD #x51F3 +#x8FB3AE #x51F4 +#x8FB3AF #x51F7 +#x8FB3B0 #x5201 +#x8FB3B1 #x5202 +#x8FB3B2 #x5205 +#x8FB3B3 #x5212 +#x8FB3B4 #x5213 +#x8FB3B5 #x5215 +#x8FB3B6 #x5216 +#x8FB3B7 #x5218 +#x8FB3B8 #x5222 +#x8FB3B9 #x5228 +#x8FB3BA #x5231 +#x8FB3BB #x5232 +#x8FB3BC #x5235 +#x8FB3BD #x523C +#x8FB3BE #x5245 +#x8FB3BF #x5249 +#x8FB3C0 #x5255 +#x8FB3C1 #x5257 +#x8FB3C2 #x5258 +#x8FB3C3 #x525A +#x8FB3C4 #x525C +#x8FB3C5 #x525F +#x8FB3C6 #x5260 +#x8FB3C7 #x5261 +#x8FB3C8 #x5266 +#x8FB3C9 #x526E +#x8FB3CA #x5277 +#x8FB3CB #x5278 +#x8FB3CC #x5279 +#x8FB3CD #x5280 +#x8FB3CE #x5282 +#x8FB3CF #x5285 +#x8FB3D0 #x528A +#x8FB3D1 #x528C +#x8FB3D2 #x5293 +#x8FB3D3 #x5295 +#x8FB3D4 #x5296 +#x8FB3D5 #x5297 +#x8FB3D6 #x5298 +#x8FB3D7 #x529A +#x8FB3D8 #x529C +#x8FB3D9 #x52A4 +#x8FB3DA #x52A5 +#x8FB3DB #x52A6 +#x8FB3DC #x52A7 +#x8FB3DD #x52AF +#x8FB3DE #x52B0 +#x8FB3DF #x52B6 +#x8FB3E0 #x52B7 +#x8FB3E1 #x52B8 +#x8FB3E2 #x52BA +#x8FB3E3 #x52BB +#x8FB3E4 #x52BD +#x8FB3E5 #x52C0 +#x8FB3E6 #x52C4 +#x8FB3E7 #x52C6 +#x8FB3E8 #x52C8 +#x8FB3E9 #x52CC +#x8FB3EA #x52CF +#x8FB3EB #x52D1 +#x8FB3EC #x52D4 +#x8FB3ED #x52D6 +#x8FB3EE #x52DB +#x8FB3EF #x52DC +#x8FB3F0 #x52E1 +#x8FB3F1 #x52E5 +#x8FB3F2 #x52E8 +#x8FB3F3 #x52E9 +#x8FB3F4 #x52EA +#x8FB3F5 #x52EC +#x8FB3F6 #x52F0 +#x8FB3F7 #x52F1 +#x8FB3F8 #x52F4 +#x8FB3F9 #x52F6 +#x8FB3FA #x52F7 +#x8FB3FB #x5300 +#x8FB3FC #x5303 +#x8FB3FD #x530A +#x8FB3FE #x530B +#x8FB4A1 #x530C +#x8FB4A2 #x5311 +#x8FB4A3 #x5313 +#x8FB4A4 #x5318 +#x8FB4A5 #x531B +#x8FB4A6 #x531C +#x8FB4A7 #x531E +#x8FB4A8 #x531F +#x8FB4A9 #x5325 +#x8FB4AA #x5327 +#x8FB4AB #x5328 +#x8FB4AC #x5329 +#x8FB4AD #x532B +#x8FB4AE #x532C +#x8FB4AF #x532D +#x8FB4B0 #x5330 +#x8FB4B1 #x5332 +#x8FB4B2 #x5335 +#x8FB4B3 #x533C +#x8FB4B4 #x533D +#x8FB4B5 #x533E +#x8FB4B6 #x5342 +#x8FB4B7 #x534C +#x8FB4B8 #x534B +#x8FB4B9 #x5359 +#x8FB4BA #x535B +#x8FB4BB #x5361 +#x8FB4BC #x5363 +#x8FB4BD #x5365 +#x8FB4BE #x536C +#x8FB4BF #x536D +#x8FB4C0 #x5372 +#x8FB4C1 #x5379 +#x8FB4C2 #x537E +#x8FB4C3 #x5383 +#x8FB4C4 #x5387 +#x8FB4C5 #x5388 +#x8FB4C6 #x538E +#x8FB4C7 #x5393 +#x8FB4C8 #x5394 +#x8FB4C9 #x5399 +#x8FB4CA #x539D +#x8FB4CB #x53A1 +#x8FB4CC #x53A4 +#x8FB4CD #x53AA +#x8FB4CE #x53AB +#x8FB4CF #x53AF +#x8FB4D0 #x53B2 +#x8FB4D1 #x53B4 +#x8FB4D2 #x53B5 +#x8FB4D3 #x53B7 +#x8FB4D4 #x53B8 +#x8FB4D5 #x53BA +#x8FB4D6 #x53BD +#x8FB4D7 #x53C0 +#x8FB4D8 #x53C5 +#x8FB4D9 #x53CF +#x8FB4DA #x53D2 +#x8FB4DB #x53D3 +#x8FB4DC #x53D5 +#x8FB4DD #x53DA +#x8FB4DE #x53DD +#x8FB4DF #x53DE +#x8FB4E0 #x53E0 +#x8FB4E1 #x53E6 +#x8FB4E2 #x53E7 +#x8FB4E3 #x53F5 +#x8FB4E4 #x5402 +#x8FB4E5 #x5413 +#x8FB4E6 #x541A +#x8FB4E7 #x5421 +#x8FB4E8 #x5427 +#x8FB4E9 #x5428 +#x8FB4EA #x542A +#x8FB4EB #x542F +#x8FB4EC #x5431 +#x8FB4ED #x5434 +#x8FB4EE #x5435 +#x8FB4EF #x5443 +#x8FB4F0 #x5444 +#x8FB4F1 #x5447 +#x8FB4F2 #x544D +#x8FB4F3 #x544F +#x8FB4F4 #x545E +#x8FB4F5 #x5462 +#x8FB4F6 #x5464 +#x8FB4F7 #x5466 +#x8FB4F8 #x5467 +#x8FB4F9 #x5469 +#x8FB4FA #x546B +#x8FB4FB #x546D +#x8FB4FC #x546E +#x8FB4FD #x5474 +#x8FB4FE #x547F +#x8FB5A1 #x5481 +#x8FB5A2 #x5483 +#x8FB5A3 #x5485 +#x8FB5A4 #x5488 +#x8FB5A5 #x5489 +#x8FB5A6 #x548D +#x8FB5A7 #x5491 +#x8FB5A8 #x5495 +#x8FB5A9 #x5496 +#x8FB5AA #x549C +#x8FB5AB #x549F +#x8FB5AC #x54A1 +#x8FB5AD #x54A6 +#x8FB5AE #x54A7 +#x8FB5AF #x54A9 +#x8FB5B0 #x54AA +#x8FB5B1 #x54AD +#x8FB5B2 #x54AE +#x8FB5B3 #x54B1 +#x8FB5B4 #x54B7 +#x8FB5B5 #x54B9 +#x8FB5B6 #x54BA +#x8FB5B7 #x54BB +#x8FB5B8 #x54BF +#x8FB5B9 #x54C6 +#x8FB5BA #x54CA +#x8FB5BB #x54CD +#x8FB5BC #x54CE +#x8FB5BD #x54E0 +#x8FB5BE #x54EA +#x8FB5BF #x54EC +#x8FB5C0 #x54EF +#x8FB5C1 #x54F6 +#x8FB5C2 #x54FC +#x8FB5C3 #x54FE +#x8FB5C4 #x54FF +#x8FB5C5 #x5500 +#x8FB5C6 #x5501 +#x8FB5C7 #x5505 +#x8FB5C8 #x5508 +#x8FB5C9 #x5509 +#x8FB5CA #x550C +#x8FB5CB #x550D +#x8FB5CC #x550E +#x8FB5CD #x5515 +#x8FB5CE #x552A +#x8FB5CF #x552B +#x8FB5D0 #x5532 +#x8FB5D1 #x5535 +#x8FB5D2 #x5536 +#x8FB5D3 #x553B +#x8FB5D4 #x553C +#x8FB5D5 #x553D +#x8FB5D6 #x5541 +#x8FB5D7 #x5547 +#x8FB5D8 #x5549 +#x8FB5D9 #x554A +#x8FB5DA #x554D +#x8FB5DB #x5550 +#x8FB5DC #x5551 +#x8FB5DD #x5558 +#x8FB5DE #x555A +#x8FB5DF #x555B +#x8FB5E0 #x555E +#x8FB5E1 #x5560 +#x8FB5E2 #x5561 +#x8FB5E3 #x5564 +#x8FB5E4 #x5566 +#x8FB5E5 #x557F +#x8FB5E6 #x5581 +#x8FB5E7 #x5582 +#x8FB5E8 #x5586 +#x8FB5E9 #x5588 +#x8FB5EA #x558E +#x8FB5EB #x558F +#x8FB5EC #x5591 +#x8FB5ED #x5592 +#x8FB5EE #x5593 +#x8FB5EF #x5594 +#x8FB5F0 #x5597 +#x8FB5F1 #x55A3 +#x8FB5F2 #x55A4 +#x8FB5F3 #x55AD +#x8FB5F4 #x55B2 +#x8FB5F5 #x55BF +#x8FB5F6 #x55C1 +#x8FB5F7 #x55C3 +#x8FB5F8 #x55C6 +#x8FB5F9 #x55C9 +#x8FB5FA #x55CB +#x8FB5FB #x55CC +#x8FB5FC #x55CE +#x8FB5FD #x55D1 +#x8FB5FE #x55D2 +#x8FB6A1 #x55D3 +#x8FB6A2 #x55D7 +#x8FB6A3 #x55D8 +#x8FB6A4 #x55DB +#x8FB6A5 #x55DE +#x8FB6A6 #x55E2 +#x8FB6A7 #x55E9 +#x8FB6A8 #x55F6 +#x8FB6A9 #x55FF +#x8FB6AA #x5605 +#x8FB6AB #x5608 +#x8FB6AC #x560A +#x8FB6AD #x560D +#x8FB6AE #x560E +#x8FB6AF #x560F +#x8FB6B0 #x5610 +#x8FB6B1 #x5611 +#x8FB6B2 #x5612 +#x8FB6B3 #x5619 +#x8FB6B4 #x562C +#x8FB6B5 #x5630 +#x8FB6B6 #x5633 +#x8FB6B7 #x5635 +#x8FB6B8 #x5637 +#x8FB6B9 #x5639 +#x8FB6BA #x563B +#x8FB6BB #x563C +#x8FB6BC #x563D +#x8FB6BD #x563F +#x8FB6BE #x5640 +#x8FB6BF #x5641 +#x8FB6C0 #x5643 +#x8FB6C1 #x5644 +#x8FB6C2 #x5646 +#x8FB6C3 #x5649 +#x8FB6C4 #x564B +#x8FB6C5 #x564D +#x8FB6C6 #x564F +#x8FB6C7 #x5654 +#x8FB6C8 #x565E +#x8FB6C9 #x5660 +#x8FB6CA #x5661 +#x8FB6CB #x5662 +#x8FB6CC #x5663 +#x8FB6CD #x5666 +#x8FB6CE #x5669 +#x8FB6CF #x566D +#x8FB6D0 #x566F +#x8FB6D1 #x5671 +#x8FB6D2 #x5672 +#x8FB6D3 #x5675 +#x8FB6D4 #x5684 +#x8FB6D5 #x5685 +#x8FB6D6 #x5688 +#x8FB6D7 #x568B +#x8FB6D8 #x568C +#x8FB6D9 #x5695 +#x8FB6DA #x5699 +#x8FB6DB #x569A +#x8FB6DC #x569D +#x8FB6DD #x569E +#x8FB6DE #x569F +#x8FB6DF #x56A6 +#x8FB6E0 #x56A7 +#x8FB6E1 #x56A8 +#x8FB6E2 #x56A9 +#x8FB6E3 #x56AB +#x8FB6E4 #x56AC +#x8FB6E5 #x56AD +#x8FB6E6 #x56B1 +#x8FB6E7 #x56B3 +#x8FB6E8 #x56B7 +#x8FB6E9 #x56BE +#x8FB6EA #x56C5 +#x8FB6EB #x56C9 +#x8FB6EC #x56CA +#x8FB6ED #x56CB +#x8FB6EE #x56CF +#x8FB6EF #x56D0 +#x8FB6F0 #x56CC +#x8FB6F1 #x56CD +#x8FB6F2 #x56D9 +#x8FB6F3 #x56DC +#x8FB6F4 #x56DD +#x8FB6F5 #x56DF +#x8FB6F6 #x56E1 +#x8FB6F7 #x56E4 +#x8FB6F8 #x56E5 +#x8FB6F9 #x56E6 +#x8FB6FA #x56E7 +#x8FB6FB #x56E8 +#x8FB6FC #x56F1 +#x8FB6FD #x56EB +#x8FB6FE #x56ED +#x8FB7A1 #x56F6 +#x8FB7A2 #x56F7 +#x8FB7A3 #x5701 +#x8FB7A4 #x5702 +#x8FB7A5 #x5707 +#x8FB7A6 #x570A +#x8FB7A7 #x570C +#x8FB7A8 #x5711 +#x8FB7A9 #x5715 +#x8FB7AA #x571A +#x8FB7AB #x571B +#x8FB7AC #x571D +#x8FB7AD #x5720 +#x8FB7AE #x5722 +#x8FB7AF #x5723 +#x8FB7B0 #x5724 +#x8FB7B1 #x5725 +#x8FB7B2 #x5729 +#x8FB7B3 #x572A +#x8FB7B4 #x572C +#x8FB7B5 #x572E +#x8FB7B6 #x572F +#x8FB7B7 #x5733 +#x8FB7B8 #x5734 +#x8FB7B9 #x573D +#x8FB7BA #x573E +#x8FB7BB #x573F +#x8FB7BC #x5745 +#x8FB7BD #x5746 +#x8FB7BE #x574C +#x8FB7BF #x574D +#x8FB7C0 #x5752 +#x8FB7C1 #x5762 +#x8FB7C2 #x5765 +#x8FB7C3 #x5767 +#x8FB7C4 #x5768 +#x8FB7C5 #x576B +#x8FB7C6 #x576D +#x8FB7C7 #x576E +#x8FB7C8 #x576F +#x8FB7C9 #x5770 +#x8FB7CA #x5771 +#x8FB7CB #x5773 +#x8FB7CC #x5774 +#x8FB7CD #x5775 +#x8FB7CE #x5777 +#x8FB7CF #x5779 +#x8FB7D0 #x577A +#x8FB7D1 #x577B +#x8FB7D2 #x577C +#x8FB7D3 #x577E +#x8FB7D4 #x5781 +#x8FB7D5 #x5783 +#x8FB7D6 #x578C +#x8FB7D7 #x5794 +#x8FB7D8 #x5797 +#x8FB7D9 #x5799 +#x8FB7DA #x579A +#x8FB7DB #x579C +#x8FB7DC #x579D +#x8FB7DD #x579E +#x8FB7DE #x579F +#x8FB7DF #x57A1 +#x8FB7E0 #x5795 +#x8FB7E1 #x57A7 +#x8FB7E2 #x57A8 +#x8FB7E3 #x57A9 +#x8FB7E4 #x57AC +#x8FB7E5 #x57B8 +#x8FB7E6 #x57BD +#x8FB7E7 #x57C7 +#x8FB7E8 #x57C8 +#x8FB7E9 #x57CC +#x8FB7EA #x57CF +#x8FB7EB #x57D5 +#x8FB7EC #x57DD +#x8FB7ED #x57DE +#x8FB7EE #x57E4 +#x8FB7EF #x57E6 +#x8FB7F0 #x57E7 +#x8FB7F1 #x57E9 +#x8FB7F2 #x57ED +#x8FB7F3 #x57F0 +#x8FB7F4 #x57F5 +#x8FB7F5 #x57F6 +#x8FB7F6 #x57F8 +#x8FB7F7 #x57FD +#x8FB7F8 #x57FE +#x8FB7F9 #x57FF +#x8FB7FA #x5803 +#x8FB7FB #x5804 +#x8FB7FC #x5808 +#x8FB7FD #x5809 +#x8FB7FE #x57E1 +#x8FB8A1 #x580C +#x8FB8A2 #x580D +#x8FB8A3 #x581B +#x8FB8A4 #x581E +#x8FB8A5 #x581F +#x8FB8A6 #x5820 +#x8FB8A7 #x5826 +#x8FB8A8 #x5827 +#x8FB8A9 #x582D +#x8FB8AA #x5832 +#x8FB8AB #x5839 +#x8FB8AC #x583F +#x8FB8AD #x5849 +#x8FB8AE #x584C +#x8FB8AF #x584D +#x8FB8B0 #x584F +#x8FB8B1 #x5850 +#x8FB8B2 #x5855 +#x8FB8B3 #x585F +#x8FB8B4 #x5861 +#x8FB8B5 #x5864 +#x8FB8B6 #x5867 +#x8FB8B7 #x5868 +#x8FB8B8 #x5878 +#x8FB8B9 #x587C +#x8FB8BA #x587F +#x8FB8BB #x5880 +#x8FB8BC #x5881 +#x8FB8BD #x5887 +#x8FB8BE #x5888 +#x8FB8BF #x5889 +#x8FB8C0 #x588A +#x8FB8C1 #x588C +#x8FB8C2 #x588D +#x8FB8C3 #x588F +#x8FB8C4 #x5890 +#x8FB8C5 #x5894 +#x8FB8C6 #x5896 +#x8FB8C7 #x589D +#x8FB8C8 #x58A0 +#x8FB8C9 #x58A1 +#x8FB8CA #x58A2 +#x8FB8CB #x58A6 +#x8FB8CC #x58A9 +#x8FB8CD #x58B1 +#x8FB8CE #x58B2 +#x8FB8CF #x58C4 +#x8FB8D0 #x58BC +#x8FB8D1 #x58C2 +#x8FB8D2 #x58C8 +#x8FB8D3 #x58CD +#x8FB8D4 #x58CE +#x8FB8D5 #x58D0 +#x8FB8D6 #x58D2 +#x8FB8D7 #x58D4 +#x8FB8D8 #x58D6 +#x8FB8D9 #x58DA +#x8FB8DA #x58DD +#x8FB8DB #x58E1 +#x8FB8DC #x58E2 +#x8FB8DD #x58E9 +#x8FB8DE #x58F3 +#x8FB8DF #x5905 +#x8FB8E0 #x5906 +#x8FB8E1 #x590B +#x8FB8E2 #x590C +#x8FB8E3 #x5912 +#x8FB8E4 #x5913 +#x8FB8E5 #x5914 +#x8FB8E6 #x8641 +#x8FB8E7 #x591D +#x8FB8E8 #x5921 +#x8FB8E9 #x5923 +#x8FB8EA #x5924 +#x8FB8EB #x5928 +#x8FB8EC #x592F +#x8FB8ED #x5930 +#x8FB8EE #x5933 +#x8FB8EF #x5935 +#x8FB8F0 #x5936 +#x8FB8F1 #x593F +#x8FB8F2 #x5943 +#x8FB8F3 #x5946 +#x8FB8F4 #x5952 +#x8FB8F5 #x5953 +#x8FB8F6 #x5959 +#x8FB8F7 #x595B +#x8FB8F8 #x595D +#x8FB8F9 #x595E +#x8FB8FA #x595F +#x8FB8FB #x5961 +#x8FB8FC #x5963 +#x8FB8FD #x596B +#x8FB8FE #x596D +#x8FB9A1 #x596F +#x8FB9A2 #x5972 +#x8FB9A3 #x5975 +#x8FB9A4 #x5976 +#x8FB9A5 #x5979 +#x8FB9A6 #x597B +#x8FB9A7 #x597C +#x8FB9A8 #x598B +#x8FB9A9 #x598C +#x8FB9AA #x598E +#x8FB9AB #x5992 +#x8FB9AC #x5995 +#x8FB9AD #x5997 +#x8FB9AE #x599F +#x8FB9AF #x59A4 +#x8FB9B0 #x59A7 +#x8FB9B1 #x59AD +#x8FB9B2 #x59AE +#x8FB9B3 #x59AF +#x8FB9B4 #x59B0 +#x8FB9B5 #x59B3 +#x8FB9B6 #x59B7 +#x8FB9B7 #x59BA +#x8FB9B8 #x59BC +#x8FB9B9 #x59C1 +#x8FB9BA #x59C3 +#x8FB9BB #x59C4 +#x8FB9BC #x59C8 +#x8FB9BD #x59CA +#x8FB9BE #x59CD +#x8FB9BF #x59D2 +#x8FB9C0 #x59DD +#x8FB9C1 #x59DE +#x8FB9C2 #x59DF +#x8FB9C3 #x59E3 +#x8FB9C4 #x59E4 +#x8FB9C5 #x59E7 +#x8FB9C6 #x59EE +#x8FB9C7 #x59EF +#x8FB9C8 #x59F1 +#x8FB9C9 #x59F2 +#x8FB9CA #x59F4 +#x8FB9CB #x59F7 +#x8FB9CC #x5A00 +#x8FB9CD #x5A04 +#x8FB9CE #x5A0C +#x8FB9CF #x5A0D +#x8FB9D0 #x5A0E +#x8FB9D1 #x5A12 +#x8FB9D2 #x5A13 +#x8FB9D3 #x5A1E +#x8FB9D4 #x5A23 +#x8FB9D5 #x5A24 +#x8FB9D6 #x5A27 +#x8FB9D7 #x5A28 +#x8FB9D8 #x5A2A +#x8FB9D9 #x5A2D +#x8FB9DA #x5A30 +#x8FB9DB #x5A44 +#x8FB9DC #x5A45 +#x8FB9DD #x5A47 +#x8FB9DE #x5A48 +#x8FB9DF #x5A4C +#x8FB9E0 #x5A50 +#x8FB9E1 #x5A55 +#x8FB9E2 #x5A5E +#x8FB9E3 #x5A63 +#x8FB9E4 #x5A65 +#x8FB9E5 #x5A67 +#x8FB9E6 #x5A6D +#x8FB9E7 #x5A77 +#x8FB9E8 #x5A7A +#x8FB9E9 #x5A7B +#x8FB9EA #x5A7E +#x8FB9EB #x5A8B +#x8FB9EC #x5A90 +#x8FB9ED #x5A93 +#x8FB9EE #x5A96 +#x8FB9EF #x5A99 +#x8FB9F0 #x5A9C +#x8FB9F1 #x5A9E +#x8FB9F2 #x5A9F +#x8FB9F3 #x5AA0 +#x8FB9F4 #x5AA2 +#x8FB9F5 #x5AA7 +#x8FB9F6 #x5AAC +#x8FB9F7 #x5AB1 +#x8FB9F8 #x5AB2 +#x8FB9F9 #x5AB3 +#x8FB9FA #x5AB5 +#x8FB9FB #x5AB8 +#x8FB9FC #x5ABA +#x8FB9FD #x5ABB +#x8FB9FE #x5ABF +#x8FBAA1 #x5AC4 +#x8FBAA2 #x5AC6 +#x8FBAA3 #x5AC8 +#x8FBAA4 #x5ACF +#x8FBAA5 #x5ADA +#x8FBAA6 #x5ADC +#x8FBAA7 #x5AE0 +#x8FBAA8 #x5AE5 +#x8FBAA9 #x5AEA +#x8FBAAA #x5AEE +#x8FBAAB #x5AF5 +#x8FBAAC #x5AF6 +#x8FBAAD #x5AFD +#x8FBAAE #x5B00 +#x8FBAAF #x5B01 +#x8FBAB0 #x5B08 +#x8FBAB1 #x5B17 +#x8FBAB2 #x5B34 +#x8FBAB3 #x5B19 +#x8FBAB4 #x5B1B +#x8FBAB5 #x5B1D +#x8FBAB6 #x5B21 +#x8FBAB7 #x5B25 +#x8FBAB8 #x5B2D +#x8FBAB9 #x5B38 +#x8FBABA #x5B41 +#x8FBABB #x5B4B +#x8FBABC #x5B4C +#x8FBABD #x5B52 +#x8FBABE #x5B56 +#x8FBABF #x5B5E +#x8FBAC0 #x5B68 +#x8FBAC1 #x5B6E +#x8FBAC2 #x5B6F +#x8FBAC3 #x5B7C +#x8FBAC4 #x5B7D +#x8FBAC5 #x5B7E +#x8FBAC6 #x5B7F +#x8FBAC7 #x5B81 +#x8FBAC8 #x5B84 +#x8FBAC9 #x5B86 +#x8FBACA #x5B8A +#x8FBACB #x5B8E +#x8FBACC #x5B90 +#x8FBACD #x5B91 +#x8FBACE #x5B93 +#x8FBACF #x5B94 +#x8FBAD0 #x5B96 +#x8FBAD1 #x5BA8 +#x8FBAD2 #x5BA9 +#x8FBAD3 #x5BAC +#x8FBAD4 #x5BAD +#x8FBAD5 #x5BAF +#x8FBAD6 #x5BB1 +#x8FBAD7 #x5BB2 +#x8FBAD8 #x5BB7 +#x8FBAD9 #x5BBA +#x8FBADA #x5BBC +#x8FBADB #x5BC0 +#x8FBADC #x5BC1 +#x8FBADD #x5BCD +#x8FBADE #x5BCF +#x8FBADF #x5BD6 +#x8FBAE0 #x5BD7 +#x8FBAE1 #x5BD8 +#x8FBAE2 #x5BD9 +#x8FBAE3 #x5BDA +#x8FBAE4 #x5BE0 +#x8FBAE5 #x5BEF +#x8FBAE6 #x5BF1 +#x8FBAE7 #x5BF4 +#x8FBAE8 #x5BFD +#x8FBAE9 #x5C0C +#x8FBAEA #x5C17 +#x8FBAEB #x5C1E +#x8FBAEC #x5C1F +#x8FBAED #x5C23 +#x8FBAEE #x5C26 +#x8FBAEF #x5C29 +#x8FBAF0 #x5C2B +#x8FBAF1 #x5C2C +#x8FBAF2 #x5C2E +#x8FBAF3 #x5C30 +#x8FBAF4 #x5C32 +#x8FBAF5 #x5C35 +#x8FBAF6 #x5C36 +#x8FBAF7 #x5C59 +#x8FBAF8 #x5C5A +#x8FBAF9 #x5C5C +#x8FBAFA #x5C62 +#x8FBAFB #x5C63 +#x8FBAFC #x5C67 +#x8FBAFD #x5C68 +#x8FBAFE #x5C69 +#x8FBBA1 #x5C6D +#x8FBBA2 #x5C70 +#x8FBBA3 #x5C74 +#x8FBBA4 #x5C75 +#x8FBBA5 #x5C7A +#x8FBBA6 #x5C7B +#x8FBBA7 #x5C7C +#x8FBBA8 #x5C7D +#x8FBBA9 #x5C87 +#x8FBBAA #x5C88 +#x8FBBAB #x5C8A +#x8FBBAC #x5C8F +#x8FBBAD #x5C92 +#x8FBBAE #x5C9D +#x8FBBAF #x5C9F +#x8FBBB0 #x5CA0 +#x8FBBB1 #x5CA2 +#x8FBBB2 #x5CA3 +#x8FBBB3 #x5CA6 +#x8FBBB4 #x5CAA +#x8FBBB5 #x5CB2 +#x8FBBB6 #x5CB4 +#x8FBBB7 #x5CB5 +#x8FBBB8 #x5CBA +#x8FBBB9 #x5CC9 +#x8FBBBA #x5CCB +#x8FBBBB #x5CD2 +#x8FBBBC #x5CDD +#x8FBBBD #x5CD7 +#x8FBBBE #x5CEE +#x8FBBBF #x5CF1 +#x8FBBC0 #x5CF2 +#x8FBBC1 #x5CF4 +#x8FBBC2 #x5D01 +#x8FBBC3 #x5D06 +#x8FBBC4 #x5D0D +#x8FBBC5 #x5D12 +#x8FBBC6 #x5D2B +#x8FBBC7 #x5D23 +#x8FBBC8 #x5D24 +#x8FBBC9 #x5D26 +#x8FBBCA #x5D27 +#x8FBBCB #x5D31 +#x8FBBCC #x5D34 +#x8FBBCD #x5D39 +#x8FBBCE #x5D3D +#x8FBBCF #x5D3F +#x8FBBD0 #x5D42 +#x8FBBD1 #x5D43 +#x8FBBD2 #x5D46 +#x8FBBD3 #x5D48 +#x8FBBD4 #x5D55 +#x8FBBD5 #x5D51 +#x8FBBD6 #x5D59 +#x8FBBD7 #x5D4A +#x8FBBD8 #x5D5F +#x8FBBD9 #x5D60 +#x8FBBDA #x5D61 +#x8FBBDB #x5D62 +#x8FBBDC #x5D64 +#x8FBBDD #x5D6A +#x8FBBDE #x5D6D +#x8FBBDF #x5D70 +#x8FBBE0 #x5D79 +#x8FBBE1 #x5D7A +#x8FBBE2 #x5D7E +#x8FBBE3 #x5D7F +#x8FBBE4 #x5D81 +#x8FBBE5 #x5D83 +#x8FBBE6 #x5D88 +#x8FBBE7 #x5D8A +#x8FBBE8 #x5D92 +#x8FBBE9 #x5D93 +#x8FBBEA #x5D94 +#x8FBBEB #x5D95 +#x8FBBEC #x5D99 +#x8FBBED #x5D9B +#x8FBBEE #x5D9F +#x8FBBEF #x5DA0 +#x8FBBF0 #x5DA7 +#x8FBBF1 #x5DAB +#x8FBBF2 #x5DB0 +#x8FBBF3 #x5DB4 +#x8FBBF4 #x5DB8 +#x8FBBF5 #x5DB9 +#x8FBBF6 #x5DC3 +#x8FBBF7 #x5DC7 +#x8FBBF8 #x5DCB +#x8FBBF9 #x5DD0 +#x8FBBFA #x5DCE +#x8FBBFB #x5DD8 +#x8FBBFC #x5DD9 +#x8FBBFD #x5DE0 +#x8FBBFE #x5DE4 +#x8FBCA1 #x5DE9 +#x8FBCA2 #x5DF8 +#x8FBCA3 #x5DF9 +#x8FBCA4 #x5E00 +#x8FBCA5 #x5E07 +#x8FBCA6 #x5E0D +#x8FBCA7 #x5E12 +#x8FBCA8 #x5E14 +#x8FBCA9 #x5E15 +#x8FBCAA #x5E18 +#x8FBCAB #x5E1F +#x8FBCAC #x5E20 +#x8FBCAD #x5E2E +#x8FBCAE #x5E28 +#x8FBCAF #x5E32 +#x8FBCB0 #x5E35 +#x8FBCB1 #x5E3E +#x8FBCB2 #x5E4B +#x8FBCB3 #x5E50 +#x8FBCB4 #x5E49 +#x8FBCB5 #x5E51 +#x8FBCB6 #x5E56 +#x8FBCB7 #x5E58 +#x8FBCB8 #x5E5B +#x8FBCB9 #x5E5C +#x8FBCBA #x5E5E +#x8FBCBB #x5E68 +#x8FBCBC #x5E6A +#x8FBCBD #x5E6B +#x8FBCBE #x5E6C +#x8FBCBF #x5E6D +#x8FBCC0 #x5E6E +#x8FBCC1 #x5E70 +#x8FBCC2 #x5E80 +#x8FBCC3 #x5E8B +#x8FBCC4 #x5E8E +#x8FBCC5 #x5EA2 +#x8FBCC6 #x5EA4 +#x8FBCC7 #x5EA5 +#x8FBCC8 #x5EA8 +#x8FBCC9 #x5EAA +#x8FBCCA #x5EAC +#x8FBCCB #x5EB1 +#x8FBCCC #x5EB3 +#x8FBCCD #x5EBD +#x8FBCCE #x5EBE +#x8FBCCF #x5EBF +#x8FBCD0 #x5EC6 +#x8FBCD1 #x5ECC +#x8FBCD2 #x5ECB +#x8FBCD3 #x5ECE +#x8FBCD4 #x5ED1 +#x8FBCD5 #x5ED2 +#x8FBCD6 #x5ED4 +#x8FBCD7 #x5ED5 +#x8FBCD8 #x5EDC +#x8FBCD9 #x5EDE +#x8FBCDA #x5EE5 +#x8FBCDB #x5EEB +#x8FBCDC #x5F02 +#x8FBCDD #x5F06 +#x8FBCDE #x5F07 +#x8FBCDF #x5F08 +#x8FBCE0 #x5F0E +#x8FBCE1 #x5F19 +#x8FBCE2 #x5F1C +#x8FBCE3 #x5F1D +#x8FBCE4 #x5F21 +#x8FBCE5 #x5F22 +#x8FBCE6 #x5F23 +#x8FBCE7 #x5F24 +#x8FBCE8 #x5F28 +#x8FBCE9 #x5F2B +#x8FBCEA #x5F2C +#x8FBCEB #x5F2E +#x8FBCEC #x5F30 +#x8FBCED #x5F34 +#x8FBCEE #x5F36 +#x8FBCEF #x5F3B +#x8FBCF0 #x5F3D +#x8FBCF1 #x5F3F +#x8FBCF2 #x5F40 +#x8FBCF3 #x5F44 +#x8FBCF4 #x5F45 +#x8FBCF5 #x5F47 +#x8FBCF6 #x5F4D +#x8FBCF7 #x5F50 +#x8FBCF8 #x5F54 +#x8FBCF9 #x5F58 +#x8FBCFA #x5F5B +#x8FBCFB #x5F60 +#x8FBCFC #x5F63 +#x8FBCFD #x5F64 +#x8FBCFE #x5F67 +#x8FBDA1 #x5F6F +#x8FBDA2 #x5F72 +#x8FBDA3 #x5F74 +#x8FBDA4 #x5F75 +#x8FBDA5 #x5F78 +#x8FBDA6 #x5F7A +#x8FBDA7 #x5F7D +#x8FBDA8 #x5F7E +#x8FBDA9 #x5F89 +#x8FBDAA #x5F8D +#x8FBDAB #x5F8F +#x8FBDAC #x5F96 +#x8FBDAD #x5F9C +#x8FBDAE #x5F9D +#x8FBDAF #x5FA2 +#x8FBDB0 #x5FA7 +#x8FBDB1 #x5FAB +#x8FBDB2 #x5FA4 +#x8FBDB3 #x5FAC +#x8FBDB4 #x5FAF +#x8FBDB5 #x5FB0 +#x8FBDB6 #x5FB1 +#x8FBDB7 #x5FB8 +#x8FBDB8 #x5FC4 +#x8FBDB9 #x5FC7 +#x8FBDBA #x5FC8 +#x8FBDBB #x5FC9 +#x8FBDBC #x5FCB +#x8FBDBD #x5FD0 +#x8FBDBE #x5FD1 +#x8FBDBF #x5FD2 +#x8FBDC0 #x5FD3 +#x8FBDC1 #x5FD4 +#x8FBDC2 #x5FDE +#x8FBDC3 #x5FE1 +#x8FBDC4 #x5FE2 +#x8FBDC5 #x5FE8 +#x8FBDC6 #x5FE9 +#x8FBDC7 #x5FEA +#x8FBDC8 #x5FEC +#x8FBDC9 #x5FED +#x8FBDCA #x5FEE +#x8FBDCB #x5FEF +#x8FBDCC #x5FF2 +#x8FBDCD #x5FF3 +#x8FBDCE #x5FF6 +#x8FBDCF #x5FFA +#x8FBDD0 #x5FFC +#x8FBDD1 #x6007 +#x8FBDD2 #x600A +#x8FBDD3 #x600D +#x8FBDD4 #x6013 +#x8FBDD5 #x6014 +#x8FBDD6 #x6017 +#x8FBDD7 #x6018 +#x8FBDD8 #x601A +#x8FBDD9 #x601F +#x8FBDDA #x6024 +#x8FBDDB #x602D +#x8FBDDC #x6033 +#x8FBDDD #x6035 +#x8FBDDE #x6040 +#x8FBDDF #x6047 +#x8FBDE0 #x6048 +#x8FBDE1 #x6049 +#x8FBDE2 #x604C +#x8FBDE3 #x6051 +#x8FBDE4 #x6054 +#x8FBDE5 #x6056 +#x8FBDE6 #x6057 +#x8FBDE7 #x605D +#x8FBDE8 #x6061 +#x8FBDE9 #x6067 +#x8FBDEA #x6071 +#x8FBDEB #x607E +#x8FBDEC #x607F +#x8FBDED #x6082 +#x8FBDEE #x6086 +#x8FBDEF #x6088 +#x8FBDF0 #x608A +#x8FBDF1 #x608E +#x8FBDF2 #x6091 +#x8FBDF3 #x6093 +#x8FBDF4 #x6095 +#x8FBDF5 #x6098 +#x8FBDF6 #x609D +#x8FBDF7 #x609E +#x8FBDF8 #x60A2 +#x8FBDF9 #x60A4 +#x8FBDFA #x60A5 +#x8FBDFB #x60A8 +#x8FBDFC #x60B0 +#x8FBDFD #x60B1 +#x8FBDFE #x60B7 +#x8FBEA1 #x60BB +#x8FBEA2 #x60BE +#x8FBEA3 #x60C2 +#x8FBEA4 #x60C4 +#x8FBEA5 #x60C8 +#x8FBEA6 #x60C9 +#x8FBEA7 #x60CA +#x8FBEA8 #x60CB +#x8FBEA9 #x60CE +#x8FBEAA #x60CF +#x8FBEAB #x60D4 +#x8FBEAC #x60D5 +#x8FBEAD #x60D9 +#x8FBEAE #x60DB +#x8FBEAF #x60DD +#x8FBEB0 #x60DE +#x8FBEB1 #x60E2 +#x8FBEB2 #x60E5 +#x8FBEB3 #x60F2 +#x8FBEB4 #x60F5 +#x8FBEB5 #x60F8 +#x8FBEB6 #x60FC +#x8FBEB7 #x60FD +#x8FBEB8 #x6102 +#x8FBEB9 #x6107 +#x8FBEBA #x610A +#x8FBEBB #x610C +#x8FBEBC #x6110 +#x8FBEBD #x6111 +#x8FBEBE #x6112 +#x8FBEBF #x6113 +#x8FBEC0 #x6114 +#x8FBEC1 #x6116 +#x8FBEC2 #x6117 +#x8FBEC3 #x6119 +#x8FBEC4 #x611C +#x8FBEC5 #x611E +#x8FBEC6 #x6122 +#x8FBEC7 #x612A +#x8FBEC8 #x612B +#x8FBEC9 #x6130 +#x8FBECA #x6131 +#x8FBECB #x6135 +#x8FBECC #x6136 +#x8FBECD #x6137 +#x8FBECE #x6139 +#x8FBECF #x6141 +#x8FBED0 #x6145 +#x8FBED1 #x6146 +#x8FBED2 #x6149 +#x8FBED3 #x615E +#x8FBED4 #x6160 +#x8FBED5 #x616C +#x8FBED6 #x6172 +#x8FBED7 #x6178 +#x8FBED8 #x617B +#x8FBED9 #x617C +#x8FBEDA #x617F +#x8FBEDB #x6180 +#x8FBEDC #x6181 +#x8FBEDD #x6183 +#x8FBEDE #x6184 +#x8FBEDF #x618B +#x8FBEE0 #x618D +#x8FBEE1 #x6192 +#x8FBEE2 #x6193 +#x8FBEE3 #x6197 +#x8FBEE4 #x6198 +#x8FBEE5 #x619C +#x8FBEE6 #x619D +#x8FBEE7 #x619F +#x8FBEE8 #x61A0 +#x8FBEE9 #x61A5 +#x8FBEEA #x61A8 +#x8FBEEB #x61AA +#x8FBEEC #x61AD +#x8FBEED #x61B8 +#x8FBEEE #x61B9 +#x8FBEEF #x61BC +#x8FBEF0 #x61C0 +#x8FBEF1 #x61C1 +#x8FBEF2 #x61C2 +#x8FBEF3 #x61CE +#x8FBEF4 #x61CF +#x8FBEF5 #x61D5 +#x8FBEF6 #x61DC +#x8FBEF7 #x61DD +#x8FBEF8 #x61DE +#x8FBEF9 #x61DF +#x8FBEFA #x61E1 +#x8FBEFB #x61E2 +#x8FBEFC #x61E7 +#x8FBEFD #x61E9 +#x8FBEFE #x61E5 +#x8FBFA1 #x61EC +#x8FBFA2 #x61ED +#x8FBFA3 #x61EF +#x8FBFA4 #x6201 +#x8FBFA5 #x6203 +#x8FBFA6 #x6204 +#x8FBFA7 #x6207 +#x8FBFA8 #x6213 +#x8FBFA9 #x6215 +#x8FBFAA #x621C +#x8FBFAB #x6220 +#x8FBFAC #x6222 +#x8FBFAD #x6223 +#x8FBFAE #x6227 +#x8FBFAF #x6229 +#x8FBFB0 #x622B +#x8FBFB1 #x6239 +#x8FBFB2 #x623D +#x8FBFB3 #x6242 +#x8FBFB4 #x6243 +#x8FBFB5 #x6244 +#x8FBFB6 #x6246 +#x8FBFB7 #x624C +#x8FBFB8 #x6250 +#x8FBFB9 #x6251 +#x8FBFBA #x6252 +#x8FBFBB #x6254 +#x8FBFBC #x6256 +#x8FBFBD #x625A +#x8FBFBE #x625C +#x8FBFBF #x6264 +#x8FBFC0 #x626D +#x8FBFC1 #x626F +#x8FBFC2 #x6273 +#x8FBFC3 #x627A +#x8FBFC4 #x627D +#x8FBFC5 #x628D +#x8FBFC6 #x628E +#x8FBFC7 #x628F +#x8FBFC8 #x6290 +#x8FBFC9 #x62A6 +#x8FBFCA #x62A8 +#x8FBFCB #x62B3 +#x8FBFCC #x62B6 +#x8FBFCD #x62B7 +#x8FBFCE #x62BA +#x8FBFCF #x62BE +#x8FBFD0 #x62BF +#x8FBFD1 #x62C4 +#x8FBFD2 #x62CE +#x8FBFD3 #x62D5 +#x8FBFD4 #x62D6 +#x8FBFD5 #x62DA +#x8FBFD6 #x62EA +#x8FBFD7 #x62F2 +#x8FBFD8 #x62F4 +#x8FBFD9 #x62FC +#x8FBFDA #x62FD +#x8FBFDB #x6303 +#x8FBFDC #x6304 +#x8FBFDD #x630A +#x8FBFDE #x630B +#x8FBFDF #x630D +#x8FBFE0 #x6310 +#x8FBFE1 #x6313 +#x8FBFE2 #x6316 +#x8FBFE3 #x6318 +#x8FBFE4 #x6329 +#x8FBFE5 #x632A +#x8FBFE6 #x632D +#x8FBFE7 #x6335 +#x8FBFE8 #x6336 +#x8FBFE9 #x6339 +#x8FBFEA #x633C +#x8FBFEB #x6341 +#x8FBFEC #x6342 +#x8FBFED #x6343 +#x8FBFEE #x6344 +#x8FBFEF #x6346 +#x8FBFF0 #x634A +#x8FBFF1 #x634B +#x8FBFF2 #x634E +#x8FBFF3 #x6352 +#x8FBFF4 #x6353 +#x8FBFF5 #x6354 +#x8FBFF6 #x6358 +#x8FBFF7 #x635B +#x8FBFF8 #x6365 +#x8FBFF9 #x6366 +#x8FBFFA #x636C +#x8FBFFB #x636D +#x8FBFFC #x6371 +#x8FBFFD #x6374 +#x8FBFFE #x6375 +#x8FC0A1 #x6378 +#x8FC0A2 #x637C +#x8FC0A3 #x637D +#x8FC0A4 #x637F +#x8FC0A5 #x6382 +#x8FC0A6 #x6384 +#x8FC0A7 #x6387 +#x8FC0A8 #x638A +#x8FC0A9 #x6390 +#x8FC0AA #x6394 +#x8FC0AB #x6395 +#x8FC0AC #x6399 +#x8FC0AD #x639A +#x8FC0AE #x639E +#x8FC0AF #x63A4 +#x8FC0B0 #x63A6 +#x8FC0B1 #x63AD +#x8FC0B2 #x63AE +#x8FC0B3 #x63AF +#x8FC0B4 #x63BD +#x8FC0B5 #x63C1 +#x8FC0B6 #x63C5 +#x8FC0B7 #x63C8 +#x8FC0B8 #x63CE +#x8FC0B9 #x63D1 +#x8FC0BA #x63D3 +#x8FC0BB #x63D4 +#x8FC0BC #x63D5 +#x8FC0BD #x63DC +#x8FC0BE #x63E0 +#x8FC0BF #x63E5 +#x8FC0C0 #x63EA +#x8FC0C1 #x63EC +#x8FC0C2 #x63F2 +#x8FC0C3 #x63F3 +#x8FC0C4 #x63F5 +#x8FC0C5 #x63F8 +#x8FC0C6 #x63F9 +#x8FC0C7 #x6409 +#x8FC0C8 #x640A +#x8FC0C9 #x6410 +#x8FC0CA #x6412 +#x8FC0CB #x6414 +#x8FC0CC #x6418 +#x8FC0CD #x641E +#x8FC0CE #x6420 +#x8FC0CF #x6422 +#x8FC0D0 #x6424 +#x8FC0D1 #x6425 +#x8FC0D2 #x6429 +#x8FC0D3 #x642A +#x8FC0D4 #x642F +#x8FC0D5 #x6430 +#x8FC0D6 #x6435 +#x8FC0D7 #x643D +#x8FC0D8 #x643F +#x8FC0D9 #x644B +#x8FC0DA #x644F +#x8FC0DB #x6451 +#x8FC0DC #x6452 +#x8FC0DD #x6453 +#x8FC0DE #x6454 +#x8FC0DF #x645A +#x8FC0E0 #x645B +#x8FC0E1 #x645C +#x8FC0E2 #x645D +#x8FC0E3 #x645F +#x8FC0E4 #x6460 +#x8FC0E5 #x6461 +#x8FC0E6 #x6463 +#x8FC0E7 #x646D +#x8FC0E8 #x6473 +#x8FC0E9 #x6474 +#x8FC0EA #x647B +#x8FC0EB #x647D +#x8FC0EC #x6485 +#x8FC0ED #x6487 +#x8FC0EE #x648F +#x8FC0EF #x6490 +#x8FC0F0 #x6491 +#x8FC0F1 #x6498 +#x8FC0F2 #x6499 +#x8FC0F3 #x649B +#x8FC0F4 #x649D +#x8FC0F5 #x649F +#x8FC0F6 #x64A1 +#x8FC0F7 #x64A3 +#x8FC0F8 #x64A6 +#x8FC0F9 #x64A8 +#x8FC0FA #x64AC +#x8FC0FB #x64B3 +#x8FC0FC #x64BD +#x8FC0FD #x64BE +#x8FC0FE #x64BF +#x8FC1A1 #x64C4 +#x8FC1A2 #x64C9 +#x8FC1A3 #x64CA +#x8FC1A4 #x64CB +#x8FC1A5 #x64CC +#x8FC1A6 #x64CE +#x8FC1A7 #x64D0 +#x8FC1A8 #x64D1 +#x8FC1A9 #x64D5 +#x8FC1AA #x64D7 +#x8FC1AB #x64E4 +#x8FC1AC #x64E5 +#x8FC1AD #x64E9 +#x8FC1AE #x64EA +#x8FC1AF #x64ED +#x8FC1B0 #x64F0 +#x8FC1B1 #x64F5 +#x8FC1B2 #x64F7 +#x8FC1B3 #x64FB +#x8FC1B4 #x64FF +#x8FC1B5 #x6501 +#x8FC1B6 #x6504 +#x8FC1B7 #x6508 +#x8FC1B8 #x6509 +#x8FC1B9 #x650A +#x8FC1BA #x650F +#x8FC1BB #x6513 +#x8FC1BC #x6514 +#x8FC1BD #x6516 +#x8FC1BE #x6519 +#x8FC1BF #x651B +#x8FC1C0 #x651E +#x8FC1C1 #x651F +#x8FC1C2 #x6522 +#x8FC1C3 #x6526 +#x8FC1C4 #x6529 +#x8FC1C5 #x652E +#x8FC1C6 #x6531 +#x8FC1C7 #x653A +#x8FC1C8 #x653C +#x8FC1C9 #x653D +#x8FC1CA #x6543 +#x8FC1CB #x6547 +#x8FC1CC #x6549 +#x8FC1CD #x6550 +#x8FC1CE #x6552 +#x8FC1CF #x6554 +#x8FC1D0 #x655F +#x8FC1D1 #x6560 +#x8FC1D2 #x6567 +#x8FC1D3 #x656B +#x8FC1D4 #x657A +#x8FC1D5 #x657D +#x8FC1D6 #x6581 +#x8FC1D7 #x6585 +#x8FC1D8 #x658A +#x8FC1D9 #x6592 +#x8FC1DA #x6595 +#x8FC1DB #x6598 +#x8FC1DC #x659D +#x8FC1DD #x65A0 +#x8FC1DE #x65A3 +#x8FC1DF #x65A6 +#x8FC1E0 #x65AE +#x8FC1E1 #x65B2 +#x8FC1E2 #x65B3 +#x8FC1E3 #x65B4 +#x8FC1E4 #x65BF +#x8FC1E5 #x65C2 +#x8FC1E6 #x65C8 +#x8FC1E7 #x65C9 +#x8FC1E8 #x65CE +#x8FC1E9 #x65D0 +#x8FC1EA #x65D4 +#x8FC1EB #x65D6 +#x8FC1EC #x65D8 +#x8FC1ED #x65DF +#x8FC1EE #x65F0 +#x8FC1EF #x65F2 +#x8FC1F0 #x65F4 +#x8FC1F1 #x65F5 +#x8FC1F2 #x65F9 +#x8FC1F3 #x65FE +#x8FC1F4 #x65FF +#x8FC1F5 #x6600 +#x8FC1F6 #x6604 +#x8FC1F7 #x6608 +#x8FC1F8 #x6609 +#x8FC1F9 #x660D +#x8FC1FA #x6611 +#x8FC1FB #x6612 +#x8FC1FC #x6615 +#x8FC1FD #x6616 +#x8FC1FE #x661D +#x8FC2A1 #x661E +#x8FC2A2 #x6621 +#x8FC2A3 #x6622 +#x8FC2A4 #x6623 +#x8FC2A5 #x6624 +#x8FC2A6 #x6626 +#x8FC2A7 #x6629 +#x8FC2A8 #x662A +#x8FC2A9 #x662B +#x8FC2AA #x662C +#x8FC2AB #x662E +#x8FC2AC #x6630 +#x8FC2AD #x6631 +#x8FC2AE #x6633 +#x8FC2AF #x6639 +#x8FC2B0 #x6637 +#x8FC2B1 #x6640 +#x8FC2B2 #x6645 +#x8FC2B3 #x6646 +#x8FC2B4 #x664A +#x8FC2B5 #x664C +#x8FC2B6 #x6651 +#x8FC2B7 #x664E +#x8FC2B8 #x6657 +#x8FC2B9 #x6658 +#x8FC2BA #x6659 +#x8FC2BB #x665B +#x8FC2BC #x665C +#x8FC2BD #x6660 +#x8FC2BE #x6661 +#x8FC2BF #x66FB +#x8FC2C0 #x666A +#x8FC2C1 #x666B +#x8FC2C2 #x666C +#x8FC2C3 #x667E +#x8FC2C4 #x6673 +#x8FC2C5 #x6675 +#x8FC2C6 #x667F +#x8FC2C7 #x6677 +#x8FC2C8 #x6678 +#x8FC2C9 #x6679 +#x8FC2CA #x667B +#x8FC2CB #x6680 +#x8FC2CC #x667C +#x8FC2CD #x668B +#x8FC2CE #x668C +#x8FC2CF #x668D +#x8FC2D0 #x6690 +#x8FC2D1 #x6692 +#x8FC2D2 #x6699 +#x8FC2D3 #x669A +#x8FC2D4 #x669B +#x8FC2D5 #x669C +#x8FC2D6 #x669F +#x8FC2D7 #x66A0 +#x8FC2D8 #x66A4 +#x8FC2D9 #x66AD +#x8FC2DA #x66B1 +#x8FC2DB #x66B2 +#x8FC2DC #x66B5 +#x8FC2DD #x66BB +#x8FC2DE #x66BF +#x8FC2DF #x66C0 +#x8FC2E0 #x66C2 +#x8FC2E1 #x66C3 +#x8FC2E2 #x66C8 +#x8FC2E3 #x66CC +#x8FC2E4 #x66CE +#x8FC2E5 #x66CF +#x8FC2E6 #x66D4 +#x8FC2E7 #x66DB +#x8FC2E8 #x66DF +#x8FC2E9 #x66E8 +#x8FC2EA #x66EB +#x8FC2EB #x66EC +#x8FC2EC #x66EE +#x8FC2ED #x66FA +#x8FC2EE #x6705 +#x8FC2EF #x6707 +#x8FC2F0 #x670E +#x8FC2F1 #x6713 +#x8FC2F2 #x6719 +#x8FC2F3 #x671C +#x8FC2F4 #x6720 +#x8FC2F5 #x6722 +#x8FC2F6 #x6733 +#x8FC2F7 #x673E +#x8FC2F8 #x6745 +#x8FC2F9 #x6747 +#x8FC2FA #x6748 +#x8FC2FB #x674C +#x8FC2FC #x6754 +#x8FC2FD #x6755 +#x8FC2FE #x675D +#x8FC3A1 #x6766 +#x8FC3A2 #x676C +#x8FC3A3 #x676E +#x8FC3A4 #x6774 +#x8FC3A5 #x6776 +#x8FC3A6 #x677B +#x8FC3A7 #x6781 +#x8FC3A8 #x6784 +#x8FC3A9 #x678E +#x8FC3AA #x678F +#x8FC3AB #x6791 +#x8FC3AC #x6793 +#x8FC3AD #x6796 +#x8FC3AE #x6798 +#x8FC3AF #x6799 +#x8FC3B0 #x679B +#x8FC3B1 #x67B0 +#x8FC3B2 #x67B1 +#x8FC3B3 #x67B2 +#x8FC3B4 #x67B5 +#x8FC3B5 #x67BB +#x8FC3B6 #x67BC +#x8FC3B7 #x67BD +#x8FC3B8 #x67F9 +#x8FC3B9 #x67C0 +#x8FC3BA #x67C2 +#x8FC3BB #x67C3 +#x8FC3BC #x67C5 +#x8FC3BD #x67C8 +#x8FC3BE #x67C9 +#x8FC3BF #x67D2 +#x8FC3C0 #x67D7 +#x8FC3C1 #x67D9 +#x8FC3C2 #x67DC +#x8FC3C3 #x67E1 +#x8FC3C4 #x67E6 +#x8FC3C5 #x67F0 +#x8FC3C6 #x67F2 +#x8FC3C7 #x67F6 +#x8FC3C8 #x67F7 +#x8FC3C9 #x6852 +#x8FC3CA #x6814 +#x8FC3CB #x6819 +#x8FC3CC #x681D +#x8FC3CD #x681F +#x8FC3CE #x6828 +#x8FC3CF #x6827 +#x8FC3D0 #x682C +#x8FC3D1 #x682D +#x8FC3D2 #x682F +#x8FC3D3 #x6830 +#x8FC3D4 #x6831 +#x8FC3D5 #x6833 +#x8FC3D6 #x683B +#x8FC3D7 #x683F +#x8FC3D8 #x6844 +#x8FC3D9 #x6845 +#x8FC3DA #x684A +#x8FC3DB #x684C +#x8FC3DC #x6855 +#x8FC3DD #x6857 +#x8FC3DE #x6858 +#x8FC3DF #x685B +#x8FC3E0 #x686B +#x8FC3E1 #x686E +#x8FC3E2 #x686F +#x8FC3E3 #x6870 +#x8FC3E4 #x6871 +#x8FC3E5 #x6872 +#x8FC3E6 #x6875 +#x8FC3E7 #x6879 +#x8FC3E8 #x687A +#x8FC3E9 #x687B +#x8FC3EA #x687C +#x8FC3EB #x6882 +#x8FC3EC #x6884 +#x8FC3ED #x6886 +#x8FC3EE #x6888 +#x8FC3EF #x6896 +#x8FC3F0 #x6898 +#x8FC3F1 #x689A +#x8FC3F2 #x689C +#x8FC3F3 #x68A1 +#x8FC3F4 #x68A3 +#x8FC3F5 #x68A5 +#x8FC3F6 #x68A9 +#x8FC3F7 #x68AA +#x8FC3F8 #x68AE +#x8FC3F9 #x68B2 +#x8FC3FA #x68BB +#x8FC3FB #x68C5 +#x8FC3FC #x68C8 +#x8FC3FD #x68CC +#x8FC3FE #x68CF +#x8FC4A1 #x68D0 +#x8FC4A2 #x68D1 +#x8FC4A3 #x68D3 +#x8FC4A4 #x68D6 +#x8FC4A5 #x68D9 +#x8FC4A6 #x68DC +#x8FC4A7 #x68DD +#x8FC4A8 #x68E5 +#x8FC4A9 #x68E8 +#x8FC4AA #x68EA +#x8FC4AB #x68EB +#x8FC4AC #x68EC +#x8FC4AD #x68ED +#x8FC4AE #x68F0 +#x8FC4AF #x68F1 +#x8FC4B0 #x68F5 +#x8FC4B1 #x68F6 +#x8FC4B2 #x68FB +#x8FC4B3 #x68FC +#x8FC4B4 #x68FD +#x8FC4B5 #x6906 +#x8FC4B6 #x6909 +#x8FC4B7 #x690A +#x8FC4B8 #x6910 +#x8FC4B9 #x6911 +#x8FC4BA #x6913 +#x8FC4BB #x6916 +#x8FC4BC #x6917 +#x8FC4BD #x6931 +#x8FC4BE #x6933 +#x8FC4BF #x6935 +#x8FC4C0 #x6938 +#x8FC4C1 #x693B +#x8FC4C2 #x6942 +#x8FC4C3 #x6945 +#x8FC4C4 #x6949 +#x8FC4C5 #x694E +#x8FC4C6 #x6957 +#x8FC4C7 #x695B +#x8FC4C8 #x6963 +#x8FC4C9 #x6964 +#x8FC4CA #x6965 +#x8FC4CB #x6966 +#x8FC4CC #x6968 +#x8FC4CD #x6969 +#x8FC4CE #x696C +#x8FC4CF #x6970 +#x8FC4D0 #x6971 +#x8FC4D1 #x6972 +#x8FC4D2 #x697A +#x8FC4D3 #x697B +#x8FC4D4 #x697F +#x8FC4D5 #x6980 +#x8FC4D6 #x698D +#x8FC4D7 #x6992 +#x8FC4D8 #x6996 +#x8FC4D9 #x6998 +#x8FC4DA #x69A1 +#x8FC4DB #x69A5 +#x8FC4DC #x69A6 +#x8FC4DD #x69A8 +#x8FC4DE #x69AB +#x8FC4DF #x69AD +#x8FC4E0 #x69AF +#x8FC4E1 #x69B7 +#x8FC4E2 #x69B8 +#x8FC4E3 #x69BA +#x8FC4E4 #x69BC +#x8FC4E5 #x69C5 +#x8FC4E6 #x69C8 +#x8FC4E7 #x69D1 +#x8FC4E8 #x69D6 +#x8FC4E9 #x69D7 +#x8FC4EA #x69E2 +#x8FC4EB #x69E5 +#x8FC4EC #x69EE +#x8FC4ED #x69EF +#x8FC4EE #x69F1 +#x8FC4EF #x69F3 +#x8FC4F0 #x69F5 +#x8FC4F1 #x69FE +#x8FC4F2 #x6A00 +#x8FC4F3 #x6A01 +#x8FC4F4 #x6A03 +#x8FC4F5 #x6A0F +#x8FC4F6 #x6A11 +#x8FC4F7 #x6A15 +#x8FC4F8 #x6A1A +#x8FC4F9 #x6A1D +#x8FC4FA #x6A20 +#x8FC4FB #x6A24 +#x8FC4FC #x6A28 +#x8FC4FD #x6A30 +#x8FC4FE #x6A32 +#x8FC5A1 #x6A34 +#x8FC5A2 #x6A37 +#x8FC5A3 #x6A3B +#x8FC5A4 #x6A3E +#x8FC5A5 #x6A3F +#x8FC5A6 #x6A45 +#x8FC5A7 #x6A46 +#x8FC5A8 #x6A49 +#x8FC5A9 #x6A4A +#x8FC5AA #x6A4E +#x8FC5AB #x6A50 +#x8FC5AC #x6A51 +#x8FC5AD #x6A52 +#x8FC5AE #x6A55 +#x8FC5AF #x6A56 +#x8FC5B0 #x6A5B +#x8FC5B1 #x6A64 +#x8FC5B2 #x6A67 +#x8FC5B3 #x6A6A +#x8FC5B4 #x6A71 +#x8FC5B5 #x6A73 +#x8FC5B6 #x6A7E +#x8FC5B7 #x6A81 +#x8FC5B8 #x6A83 +#x8FC5B9 #x6A86 +#x8FC5BA #x6A87 +#x8FC5BB #x6A89 +#x8FC5BC #x6A8B +#x8FC5BD #x6A91 +#x8FC5BE #x6A9B +#x8FC5BF #x6A9D +#x8FC5C0 #x6A9E +#x8FC5C1 #x6A9F +#x8FC5C2 #x6AA5 +#x8FC5C3 #x6AAB +#x8FC5C4 #x6AAF +#x8FC5C5 #x6AB0 +#x8FC5C6 #x6AB1 +#x8FC5C7 #x6AB4 +#x8FC5C8 #x6ABD +#x8FC5C9 #x6ABE +#x8FC5CA #x6ABF +#x8FC5CB #x6AC6 +#x8FC5CC #x6AC9 +#x8FC5CD #x6AC8 +#x8FC5CE #x6ACC +#x8FC5CF #x6AD0 +#x8FC5D0 #x6AD4 +#x8FC5D1 #x6AD5 +#x8FC5D2 #x6AD6 +#x8FC5D3 #x6ADC +#x8FC5D4 #x6ADD +#x8FC5D5 #x6AE4 +#x8FC5D6 #x6AE7 +#x8FC5D7 #x6AEC +#x8FC5D8 #x6AF0 +#x8FC5D9 #x6AF1 +#x8FC5DA #x6AF2 +#x8FC5DB #x6AFC +#x8FC5DC #x6AFD +#x8FC5DD #x6B02 +#x8FC5DE #x6B03 +#x8FC5DF #x6B06 +#x8FC5E0 #x6B07 +#x8FC5E1 #x6B09 +#x8FC5E2 #x6B0F +#x8FC5E3 #x6B10 +#x8FC5E4 #x6B11 +#x8FC5E5 #x6B17 +#x8FC5E6 #x6B1B +#x8FC5E7 #x6B1E +#x8FC5E8 #x6B24 +#x8FC5E9 #x6B28 +#x8FC5EA #x6B2B +#x8FC5EB #x6B2C +#x8FC5EC #x6B2F +#x8FC5ED #x6B35 +#x8FC5EE #x6B36 +#x8FC5EF #x6B3B +#x8FC5F0 #x6B3F +#x8FC5F1 #x6B46 +#x8FC5F2 #x6B4A +#x8FC5F3 #x6B4D +#x8FC5F4 #x6B52 +#x8FC5F5 #x6B56 +#x8FC5F6 #x6B58 +#x8FC5F7 #x6B5D +#x8FC5F8 #x6B60 +#x8FC5F9 #x6B67 +#x8FC5FA #x6B6B +#x8FC5FB #x6B6E +#x8FC5FC #x6B70 +#x8FC5FD #x6B75 +#x8FC5FE #x6B7D +#x8FC6A1 #x6B7E +#x8FC6A2 #x6B82 +#x8FC6A3 #x6B85 +#x8FC6A4 #x6B97 +#x8FC6A5 #x6B9B +#x8FC6A6 #x6B9F +#x8FC6A7 #x6BA0 +#x8FC6A8 #x6BA2 +#x8FC6A9 #x6BA3 +#x8FC6AA #x6BA8 +#x8FC6AB #x6BA9 +#x8FC6AC #x6BAC +#x8FC6AD #x6BAD +#x8FC6AE #x6BAE +#x8FC6AF #x6BB0 +#x8FC6B0 #x6BB8 +#x8FC6B1 #x6BB9 +#x8FC6B2 #x6BBD +#x8FC6B3 #x6BBE +#x8FC6B4 #x6BC3 +#x8FC6B5 #x6BC4 +#x8FC6B6 #x6BC9 +#x8FC6B7 #x6BCC +#x8FC6B8 #x6BD6 +#x8FC6B9 #x6BDA +#x8FC6BA #x6BE1 +#x8FC6BB #x6BE3 +#x8FC6BC #x6BE6 +#x8FC6BD #x6BE7 +#x8FC6BE #x6BEE +#x8FC6BF #x6BF1 +#x8FC6C0 #x6BF7 +#x8FC6C1 #x6BF9 +#x8FC6C2 #x6BFF +#x8FC6C3 #x6C02 +#x8FC6C4 #x6C04 +#x8FC6C5 #x6C05 +#x8FC6C6 #x6C09 +#x8FC6C7 #x6C0D +#x8FC6C8 #x6C0E +#x8FC6C9 #x6C10 +#x8FC6CA #x6C12 +#x8FC6CB #x6C19 +#x8FC6CC #x6C1F +#x8FC6CD #x6C26 +#x8FC6CE #x6C27 +#x8FC6CF #x6C28 +#x8FC6D0 #x6C2C +#x8FC6D1 #x6C2E +#x8FC6D2 #x6C33 +#x8FC6D3 #x6C35 +#x8FC6D4 #x6C36 +#x8FC6D5 #x6C3A +#x8FC6D6 #x6C3B +#x8FC6D7 #x6C3F +#x8FC6D8 #x6C4A +#x8FC6D9 #x6C4B +#x8FC6DA #x6C4D +#x8FC6DB #x6C4F +#x8FC6DC #x6C52 +#x8FC6DD #x6C54 +#x8FC6DE #x6C59 +#x8FC6DF #x6C5B +#x8FC6E0 #x6C5C +#x8FC6E1 #x6C6B +#x8FC6E2 #x6C6D +#x8FC6E3 #x6C6F +#x8FC6E4 #x6C74 +#x8FC6E5 #x6C76 +#x8FC6E6 #x6C78 +#x8FC6E7 #x6C79 +#x8FC6E8 #x6C7B +#x8FC6E9 #x6C85 +#x8FC6EA #x6C86 +#x8FC6EB #x6C87 +#x8FC6EC #x6C89 +#x8FC6ED #x6C94 +#x8FC6EE #x6C95 +#x8FC6EF #x6C97 +#x8FC6F0 #x6C98 +#x8FC6F1 #x6C9C +#x8FC6F2 #x6C9F +#x8FC6F3 #x6CB0 +#x8FC6F4 #x6CB2 +#x8FC6F5 #x6CB4 +#x8FC6F6 #x6CC2 +#x8FC6F7 #x6CC6 +#x8FC6F8 #x6CCD +#x8FC6F9 #x6CCF +#x8FC6FA #x6CD0 +#x8FC6FB #x6CD1 +#x8FC6FC #x6CD2 +#x8FC6FD #x6CD4 +#x8FC6FE #x6CD6 +#x8FC7A1 #x6CDA +#x8FC7A2 #x6CDC +#x8FC7A3 #x6CE0 +#x8FC7A4 #x6CE7 +#x8FC7A5 #x6CE9 +#x8FC7A6 #x6CEB +#x8FC7A7 #x6CEC +#x8FC7A8 #x6CEE +#x8FC7A9 #x6CF2 +#x8FC7AA #x6CF4 +#x8FC7AB #x6D04 +#x8FC7AC #x6D07 +#x8FC7AD #x6D0A +#x8FC7AE #x6D0E +#x8FC7AF #x6D0F +#x8FC7B0 #x6D11 +#x8FC7B1 #x6D13 +#x8FC7B2 #x6D1A +#x8FC7B3 #x6D26 +#x8FC7B4 #x6D27 +#x8FC7B5 #x6D28 +#x8FC7B6 #x6C67 +#x8FC7B7 #x6D2E +#x8FC7B8 #x6D2F +#x8FC7B9 #x6D31 +#x8FC7BA #x6D39 +#x8FC7BB #x6D3C +#x8FC7BC #x6D3F +#x8FC7BD #x6D57 +#x8FC7BE #x6D5E +#x8FC7BF #x6D5F +#x8FC7C0 #x6D61 +#x8FC7C1 #x6D65 +#x8FC7C2 #x6D67 +#x8FC7C3 #x6D6F +#x8FC7C4 #x6D70 +#x8FC7C5 #x6D7C +#x8FC7C6 #x6D82 +#x8FC7C7 #x6D87 +#x8FC7C8 #x6D91 +#x8FC7C9 #x6D92 +#x8FC7CA #x6D94 +#x8FC7CB #x6D96 +#x8FC7CC #x6D97 +#x8FC7CD #x6D98 +#x8FC7CE #x6DAA +#x8FC7CF #x6DAC +#x8FC7D0 #x6DB4 +#x8FC7D1 #x6DB7 +#x8FC7D2 #x6DB9 +#x8FC7D3 #x6DBD +#x8FC7D4 #x6DBF +#x8FC7D5 #x6DC4 +#x8FC7D6 #x6DC8 +#x8FC7D7 #x6DCA +#x8FC7D8 #x6DCE +#x8FC7D9 #x6DCF +#x8FC7DA #x6DD6 +#x8FC7DB #x6DDB +#x8FC7DC #x6DDD +#x8FC7DD #x6DDF +#x8FC7DE #x6DE0 +#x8FC7DF #x6DE2 +#x8FC7E0 #x6DE5 +#x8FC7E1 #x6DE9 +#x8FC7E2 #x6DEF +#x8FC7E3 #x6DF0 +#x8FC7E4 #x6DF4 +#x8FC7E5 #x6DF6 +#x8FC7E6 #x6DFC +#x8FC7E7 #x6E00 +#x8FC7E8 #x6E04 +#x8FC7E9 #x6E1E +#x8FC7EA #x6E22 +#x8FC7EB #x6E27 +#x8FC7EC #x6E32 +#x8FC7ED #x6E36 +#x8FC7EE #x6E39 +#x8FC7EF #x6E3B +#x8FC7F0 #x6E3C +#x8FC7F1 #x6E44 +#x8FC7F2 #x6E45 +#x8FC7F3 #x6E48 +#x8FC7F4 #x6E49 +#x8FC7F5 #x6E4B +#x8FC7F6 #x6E4F +#x8FC7F7 #x6E51 +#x8FC7F8 #x6E52 +#x8FC7F9 #x6E53 +#x8FC7FA #x6E54 +#x8FC7FB #x6E57 +#x8FC7FC #x6E5C +#x8FC7FD #x6E5D +#x8FC7FE #x6E5E +#x8FC8A1 #x6E62 +#x8FC8A2 #x6E63 +#x8FC8A3 #x6E68 +#x8FC8A4 #x6E73 +#x8FC8A5 #x6E7B +#x8FC8A6 #x6E7D +#x8FC8A7 #x6E8D +#x8FC8A8 #x6E93 +#x8FC8A9 #x6E99 +#x8FC8AA #x6EA0 +#x8FC8AB #x6EA7 +#x8FC8AC #x6EAD +#x8FC8AD #x6EAE +#x8FC8AE #x6EB1 +#x8FC8AF #x6EB3 +#x8FC8B0 #x6EBB +#x8FC8B1 #x6EBF +#x8FC8B2 #x6EC0 +#x8FC8B3 #x6EC1 +#x8FC8B4 #x6EC3 +#x8FC8B5 #x6EC7 +#x8FC8B6 #x6EC8 +#x8FC8B7 #x6ECA +#x8FC8B8 #x6ECD +#x8FC8B9 #x6ECE +#x8FC8BA #x6ECF +#x8FC8BB #x6EEB +#x8FC8BC #x6EED +#x8FC8BD #x6EEE +#x8FC8BE #x6EF9 +#x8FC8BF #x6EFB +#x8FC8C0 #x6EFD +#x8FC8C1 #x6F04 +#x8FC8C2 #x6F08 +#x8FC8C3 #x6F0A +#x8FC8C4 #x6F0C +#x8FC8C5 #x6F0D +#x8FC8C6 #x6F16 +#x8FC8C7 #x6F18 +#x8FC8C8 #x6F1A +#x8FC8C9 #x6F1B +#x8FC8CA #x6F26 +#x8FC8CB #x6F29 +#x8FC8CC #x6F2A +#x8FC8CD #x6F2F +#x8FC8CE #x6F30 +#x8FC8CF #x6F33 +#x8FC8D0 #x6F36 +#x8FC8D1 #x6F3B +#x8FC8D2 #x6F3C +#x8FC8D3 #x6F2D +#x8FC8D4 #x6F4F +#x8FC8D5 #x6F51 +#x8FC8D6 #x6F52 +#x8FC8D7 #x6F53 +#x8FC8D8 #x6F57 +#x8FC8D9 #x6F59 +#x8FC8DA #x6F5A +#x8FC8DB #x6F5D +#x8FC8DC #x6F5E +#x8FC8DD #x6F61 +#x8FC8DE #x6F62 +#x8FC8DF #x6F68 +#x8FC8E0 #x6F6C +#x8FC8E1 #x6F7D +#x8FC8E2 #x6F7E +#x8FC8E3 #x6F83 +#x8FC8E4 #x6F87 +#x8FC8E5 #x6F88 +#x8FC8E6 #x6F8B +#x8FC8E7 #x6F8C +#x8FC8E8 #x6F8D +#x8FC8E9 #x6F90 +#x8FC8EA #x6F92 +#x8FC8EB #x6F93 +#x8FC8EC #x6F94 +#x8FC8ED #x6F96 +#x8FC8EE #x6F9A +#x8FC8EF #x6F9F +#x8FC8F0 #x6FA0 +#x8FC8F1 #x6FA5 +#x8FC8F2 #x6FA6 +#x8FC8F3 #x6FA7 +#x8FC8F4 #x6FA8 +#x8FC8F5 #x6FAE +#x8FC8F6 #x6FAF +#x8FC8F7 #x6FB0 +#x8FC8F8 #x6FB5 +#x8FC8F9 #x6FB6 +#x8FC8FA #x6FBC +#x8FC8FB #x6FC5 +#x8FC8FC #x6FC7 +#x8FC8FD #x6FC8 +#x8FC8FE #x6FCA +#x8FC9A1 #x6FDA +#x8FC9A2 #x6FDE +#x8FC9A3 #x6FE8 +#x8FC9A4 #x6FE9 +#x8FC9A5 #x6FF0 +#x8FC9A6 #x6FF5 +#x8FC9A7 #x6FF9 +#x8FC9A8 #x6FFC +#x8FC9A9 #x6FFD +#x8FC9AA #x7000 +#x8FC9AB #x7005 +#x8FC9AC #x7006 +#x8FC9AD #x7007 +#x8FC9AE #x700D +#x8FC9AF #x7017 +#x8FC9B0 #x7020 +#x8FC9B1 #x7023 +#x8FC9B2 #x702F +#x8FC9B3 #x7034 +#x8FC9B4 #x7037 +#x8FC9B5 #x7039 +#x8FC9B6 #x703C +#x8FC9B7 #x7043 +#x8FC9B8 #x7044 +#x8FC9B9 #x7048 +#x8FC9BA #x7049 +#x8FC9BB #x704A +#x8FC9BC #x704B +#x8FC9BD #x7054 +#x8FC9BE #x7055 +#x8FC9BF #x705D +#x8FC9C0 #x705E +#x8FC9C1 #x704E +#x8FC9C2 #x7064 +#x8FC9C3 #x7065 +#x8FC9C4 #x706C +#x8FC9C5 #x706E +#x8FC9C6 #x7075 +#x8FC9C7 #x7076 +#x8FC9C8 #x707E +#x8FC9C9 #x7081 +#x8FC9CA #x7085 +#x8FC9CB #x7086 +#x8FC9CC #x7094 +#x8FC9CD #x7095 +#x8FC9CE #x7096 +#x8FC9CF #x7097 +#x8FC9D0 #x7098 +#x8FC9D1 #x709B +#x8FC9D2 #x70A4 +#x8FC9D3 #x70AB +#x8FC9D4 #x70B0 +#x8FC9D5 #x70B1 +#x8FC9D6 #x70B4 +#x8FC9D7 #x70B7 +#x8FC9D8 #x70CA +#x8FC9D9 #x70D1 +#x8FC9DA #x70D3 +#x8FC9DB #x70D4 +#x8FC9DC #x70D5 +#x8FC9DD #x70D6 +#x8FC9DE #x70D8 +#x8FC9DF #x70DC +#x8FC9E0 #x70E4 +#x8FC9E1 #x70FA +#x8FC9E2 #x7103 +#x8FC9E3 #x7104 +#x8FC9E4 #x7105 +#x8FC9E5 #x7106 +#x8FC9E6 #x7107 +#x8FC9E7 #x710B +#x8FC9E8 #x710C +#x8FC9E9 #x710F +#x8FC9EA #x711E +#x8FC9EB #x7120 +#x8FC9EC #x712B +#x8FC9ED #x712D +#x8FC9EE #x712F +#x8FC9EF #x7130 +#x8FC9F0 #x7131 +#x8FC9F1 #x7138 +#x8FC9F2 #x7141 +#x8FC9F3 #x7145 +#x8FC9F4 #x7146 +#x8FC9F5 #x7147 +#x8FC9F6 #x714A +#x8FC9F7 #x714B +#x8FC9F8 #x7150 +#x8FC9F9 #x7152 +#x8FC9FA #x7157 +#x8FC9FB #x715A +#x8FC9FC #x715C +#x8FC9FD #x715E +#x8FC9FE #x7160 +#x8FCAA1 #x7168 +#x8FCAA2 #x7179 +#x8FCAA3 #x7180 +#x8FCAA4 #x7185 +#x8FCAA5 #x7187 +#x8FCAA6 #x718C +#x8FCAA7 #x7192 +#x8FCAA8 #x719A +#x8FCAA9 #x719B +#x8FCAAA #x71A0 +#x8FCAAB #x71A2 +#x8FCAAC #x71AF +#x8FCAAD #x71B0 +#x8FCAAE #x71B2 +#x8FCAAF #x71B3 +#x8FCAB0 #x71BA +#x8FCAB1 #x71BF +#x8FCAB2 #x71C0 +#x8FCAB3 #x71C1 +#x8FCAB4 #x71C4 +#x8FCAB5 #x71CB +#x8FCAB6 #x71CC +#x8FCAB7 #x71D3 +#x8FCAB8 #x71D6 +#x8FCAB9 #x71D9 +#x8FCABA #x71DA +#x8FCABB #x71DC +#x8FCABC #x71F8 +#x8FCABD #x71FE +#x8FCABE #x7200 +#x8FCABF #x7207 +#x8FCAC0 #x7208 +#x8FCAC1 #x7209 +#x8FCAC2 #x7213 +#x8FCAC3 #x7217 +#x8FCAC4 #x721A +#x8FCAC5 #x721D +#x8FCAC6 #x721F +#x8FCAC7 #x7224 +#x8FCAC8 #x722B +#x8FCAC9 #x722F +#x8FCACA #x7234 +#x8FCACB #x7238 +#x8FCACC #x7239 +#x8FCACD #x7241 +#x8FCACE #x7242 +#x8FCACF #x7243 +#x8FCAD0 #x7245 +#x8FCAD1 #x724E +#x8FCAD2 #x724F +#x8FCAD3 #x7250 +#x8FCAD4 #x7253 +#x8FCAD5 #x7255 +#x8FCAD6 #x7256 +#x8FCAD7 #x725A +#x8FCAD8 #x725C +#x8FCAD9 #x725E +#x8FCADA #x7260 +#x8FCADB #x7263 +#x8FCADC #x7268 +#x8FCADD #x726B +#x8FCADE #x726E +#x8FCADF #x726F +#x8FCAE0 #x7271 +#x8FCAE1 #x7277 +#x8FCAE2 #x7278 +#x8FCAE3 #x727B +#x8FCAE4 #x727C +#x8FCAE5 #x727F +#x8FCAE6 #x7284 +#x8FCAE7 #x7289 +#x8FCAE8 #x728D +#x8FCAE9 #x728E +#x8FCAEA #x7293 +#x8FCAEB #x729B +#x8FCAEC #x72A8 +#x8FCAED #x72AD +#x8FCAEE #x72AE +#x8FCAEF #x72B1 +#x8FCAF0 #x72B4 +#x8FCAF1 #x72BE +#x8FCAF2 #x72C1 +#x8FCAF3 #x72C7 +#x8FCAF4 #x72C9 +#x8FCAF5 #x72CC +#x8FCAF6 #x72D5 +#x8FCAF7 #x72D6 +#x8FCAF8 #x72D8 +#x8FCAF9 #x72DF +#x8FCAFA #x72E5 +#x8FCAFB #x72F3 +#x8FCAFC #x72F4 +#x8FCAFD #x72FA +#x8FCAFE #x72FB +#x8FCBA1 #x72FE +#x8FCBA2 #x7302 +#x8FCBA3 #x7304 +#x8FCBA4 #x7305 +#x8FCBA5 #x7307 +#x8FCBA6 #x730B +#x8FCBA7 #x730D +#x8FCBA8 #x7312 +#x8FCBA9 #x7313 +#x8FCBAA #x7318 +#x8FCBAB #x7319 +#x8FCBAC #x731E +#x8FCBAD #x7322 +#x8FCBAE #x7324 +#x8FCBAF #x7327 +#x8FCBB0 #x7328 +#x8FCBB1 #x732C +#x8FCBB2 #x7331 +#x8FCBB3 #x7332 +#x8FCBB4 #x7335 +#x8FCBB5 #x733A +#x8FCBB6 #x733B +#x8FCBB7 #x733D +#x8FCBB8 #x7343 +#x8FCBB9 #x734D +#x8FCBBA #x7350 +#x8FCBBB #x7352 +#x8FCBBC #x7356 +#x8FCBBD #x7358 +#x8FCBBE #x735D +#x8FCBBF #x735E +#x8FCBC0 #x735F +#x8FCBC1 #x7360 +#x8FCBC2 #x7366 +#x8FCBC3 #x7367 +#x8FCBC4 #x7369 +#x8FCBC5 #x736B +#x8FCBC6 #x736C +#x8FCBC7 #x736E +#x8FCBC8 #x736F +#x8FCBC9 #x7371 +#x8FCBCA #x7377 +#x8FCBCB #x7379 +#x8FCBCC #x737C +#x8FCBCD #x7380 +#x8FCBCE #x7381 +#x8FCBCF #x7383 +#x8FCBD0 #x7385 +#x8FCBD1 #x7386 +#x8FCBD2 #x738E +#x8FCBD3 #x7390 +#x8FCBD4 #x7393 +#x8FCBD5 #x7395 +#x8FCBD6 #x7397 +#x8FCBD7 #x7398 +#x8FCBD8 #x739C +#x8FCBD9 #x739E +#x8FCBDA #x739F +#x8FCBDB #x73A0 +#x8FCBDC #x73A2 +#x8FCBDD #x73A5 +#x8FCBDE #x73A6 +#x8FCBDF #x73AA +#x8FCBE0 #x73AB +#x8FCBE1 #x73AD +#x8FCBE2 #x73B5 +#x8FCBE3 #x73B7 +#x8FCBE4 #x73B9 +#x8FCBE5 #x73BC +#x8FCBE6 #x73BD +#x8FCBE7 #x73BF +#x8FCBE8 #x73C5 +#x8FCBE9 #x73C6 +#x8FCBEA #x73C9 +#x8FCBEB #x73CB +#x8FCBEC #x73CC +#x8FCBED #x73CF +#x8FCBEE #x73D2 +#x8FCBEF #x73D3 +#x8FCBF0 #x73D6 +#x8FCBF1 #x73D9 +#x8FCBF2 #x73DD +#x8FCBF3 #x73E1 +#x8FCBF4 #x73E3 +#x8FCBF5 #x73E6 +#x8FCBF6 #x73E7 +#x8FCBF7 #x73E9 +#x8FCBF8 #x73F4 +#x8FCBF9 #x73F5 +#x8FCBFA #x73F7 +#x8FCBFB #x73F9 +#x8FCBFC #x73FA +#x8FCBFD #x73FB +#x8FCBFE #x73FD +#x8FCCA1 #x73FF +#x8FCCA2 #x7400 +#x8FCCA3 #x7401 +#x8FCCA4 #x7404 +#x8FCCA5 #x7407 +#x8FCCA6 #x740A +#x8FCCA7 #x7411 +#x8FCCA8 #x741A +#x8FCCA9 #x741B +#x8FCCAA #x7424 +#x8FCCAB #x7426 +#x8FCCAC #x7428 +#x8FCCAD #x7429 +#x8FCCAE #x742A +#x8FCCAF #x742B +#x8FCCB0 #x742C +#x8FCCB1 #x742D +#x8FCCB2 #x742E +#x8FCCB3 #x742F +#x8FCCB4 #x7430 +#x8FCCB5 #x7431 +#x8FCCB6 #x7439 +#x8FCCB7 #x7440 +#x8FCCB8 #x7443 +#x8FCCB9 #x7444 +#x8FCCBA #x7446 +#x8FCCBB #x7447 +#x8FCCBC #x744B +#x8FCCBD #x744D +#x8FCCBE #x7451 +#x8FCCBF #x7452 +#x8FCCC0 #x7457 +#x8FCCC1 #x745D +#x8FCCC2 #x7462 +#x8FCCC3 #x7466 +#x8FCCC4 #x7467 +#x8FCCC5 #x7468 +#x8FCCC6 #x746B +#x8FCCC7 #x746D +#x8FCCC8 #x746E +#x8FCCC9 #x7471 +#x8FCCCA #x7472 +#x8FCCCB #x7480 +#x8FCCCC #x7481 +#x8FCCCD #x7485 +#x8FCCCE #x7486 +#x8FCCCF #x7487 +#x8FCCD0 #x7489 +#x8FCCD1 #x748F +#x8FCCD2 #x7490 +#x8FCCD3 #x7491 +#x8FCCD4 #x7492 +#x8FCCD5 #x7498 +#x8FCCD6 #x7499 +#x8FCCD7 #x749A +#x8FCCD8 #x749C +#x8FCCD9 #x749F +#x8FCCDA #x74A0 +#x8FCCDB #x74A1 +#x8FCCDC #x74A3 +#x8FCCDD #x74A6 +#x8FCCDE #x74A8 +#x8FCCDF #x74A9 +#x8FCCE0 #x74AA +#x8FCCE1 #x74AB +#x8FCCE2 #x74AE +#x8FCCE3 #x74AF +#x8FCCE4 #x74B1 +#x8FCCE5 #x74B2 +#x8FCCE6 #x74B5 +#x8FCCE7 #x74B9 +#x8FCCE8 #x74BB +#x8FCCE9 #x74BF +#x8FCCEA #x74C8 +#x8FCCEB #x74C9 +#x8FCCEC #x74CC +#x8FCCED #x74D0 +#x8FCCEE #x74D3 +#x8FCCEF #x74D8 +#x8FCCF0 #x74DA +#x8FCCF1 #x74DB +#x8FCCF2 #x74DE +#x8FCCF3 #x74DF +#x8FCCF4 #x74E4 +#x8FCCF5 #x74E8 +#x8FCCF6 #x74EA +#x8FCCF7 #x74EB +#x8FCCF8 #x74EF +#x8FCCF9 #x74F4 +#x8FCCFA #x74FA +#x8FCCFB #x74FB +#x8FCCFC #x74FC +#x8FCCFD #x74FF +#x8FCCFE #x7506 +#x8FCDA1 #x7512 +#x8FCDA2 #x7516 +#x8FCDA3 #x7517 +#x8FCDA4 #x7520 +#x8FCDA5 #x7521 +#x8FCDA6 #x7524 +#x8FCDA7 #x7527 +#x8FCDA8 #x7529 +#x8FCDA9 #x752A +#x8FCDAA #x752F +#x8FCDAB #x7536 +#x8FCDAC #x7539 +#x8FCDAD #x753D +#x8FCDAE #x753E +#x8FCDAF #x753F +#x8FCDB0 #x7540 +#x8FCDB1 #x7543 +#x8FCDB2 #x7547 +#x8FCDB3 #x7548 +#x8FCDB4 #x754E +#x8FCDB5 #x7550 +#x8FCDB6 #x7552 +#x8FCDB7 #x7557 +#x8FCDB8 #x755E +#x8FCDB9 #x755F +#x8FCDBA #x7561 +#x8FCDBB #x756F +#x8FCDBC #x7571 +#x8FCDBD #x7579 +#x8FCDBE #x757A +#x8FCDBF #x757B +#x8FCDC0 #x757C +#x8FCDC1 #x757D +#x8FCDC2 #x757E +#x8FCDC3 #x7581 +#x8FCDC4 #x7585 +#x8FCDC5 #x7590 +#x8FCDC6 #x7592 +#x8FCDC7 #x7593 +#x8FCDC8 #x7595 +#x8FCDC9 #x7599 +#x8FCDCA #x759C +#x8FCDCB #x75A2 +#x8FCDCC #x75A4 +#x8FCDCD #x75B4 +#x8FCDCE #x75BA +#x8FCDCF #x75BF +#x8FCDD0 #x75C0 +#x8FCDD1 #x75C1 +#x8FCDD2 #x75C4 +#x8FCDD3 #x75C6 +#x8FCDD4 #x75CC +#x8FCDD5 #x75CE +#x8FCDD6 #x75CF +#x8FCDD7 #x75D7 +#x8FCDD8 #x75DC +#x8FCDD9 #x75DF +#x8FCDDA #x75E0 +#x8FCDDB #x75E1 +#x8FCDDC #x75E4 +#x8FCDDD #x75E7 +#x8FCDDE #x75EC +#x8FCDDF #x75EE +#x8FCDE0 #x75EF +#x8FCDE1 #x75F1 +#x8FCDE2 #x75F9 +#x8FCDE3 #x7600 +#x8FCDE4 #x7602 +#x8FCDE5 #x7603 +#x8FCDE6 #x7604 +#x8FCDE7 #x7607 +#x8FCDE8 #x7608 +#x8FCDE9 #x760A +#x8FCDEA #x760C +#x8FCDEB #x760F +#x8FCDEC #x7612 +#x8FCDED #x7613 +#x8FCDEE #x7615 +#x8FCDEF #x7616 +#x8FCDF0 #x7619 +#x8FCDF1 #x761B +#x8FCDF2 #x761C +#x8FCDF3 #x761D +#x8FCDF4 #x761E +#x8FCDF5 #x7623 +#x8FCDF6 #x7625 +#x8FCDF7 #x7626 +#x8FCDF8 #x7629 +#x8FCDF9 #x762D +#x8FCDFA #x7632 +#x8FCDFB #x7633 +#x8FCDFC #x7635 +#x8FCDFD #x7638 +#x8FCDFE #x7639 +#x8FCEA1 #x763A +#x8FCEA2 #x763C +#x8FCEA3 #x764A +#x8FCEA4 #x7640 +#x8FCEA5 #x7641 +#x8FCEA6 #x7643 +#x8FCEA7 #x7644 +#x8FCEA8 #x7645 +#x8FCEA9 #x7649 +#x8FCEAA #x764B +#x8FCEAB #x7655 +#x8FCEAC #x7659 +#x8FCEAD #x765F +#x8FCEAE #x7664 +#x8FCEAF #x7665 +#x8FCEB0 #x766D +#x8FCEB1 #x766E +#x8FCEB2 #x766F +#x8FCEB3 #x7671 +#x8FCEB4 #x7674 +#x8FCEB5 #x7681 +#x8FCEB6 #x7685 +#x8FCEB7 #x768C +#x8FCEB8 #x768D +#x8FCEB9 #x7695 +#x8FCEBA #x769B +#x8FCEBB #x769C +#x8FCEBC #x769D +#x8FCEBD #x769F +#x8FCEBE #x76A0 +#x8FCEBF #x76A2 +#x8FCEC0 #x76A3 +#x8FCEC1 #x76A4 +#x8FCEC2 #x76A5 +#x8FCEC3 #x76A6 +#x8FCEC4 #x76A7 +#x8FCEC5 #x76A8 +#x8FCEC6 #x76AA +#x8FCEC7 #x76AD +#x8FCEC8 #x76BD +#x8FCEC9 #x76C1 +#x8FCECA #x76C5 +#x8FCECB #x76C9 +#x8FCECC #x76CB +#x8FCECD #x76CC +#x8FCECE #x76CE +#x8FCECF #x76D4 +#x8FCED0 #x76D9 +#x8FCED1 #x76E0 +#x8FCED2 #x76E6 +#x8FCED3 #x76E8 +#x8FCED4 #x76EC +#x8FCED5 #x76F0 +#x8FCED6 #x76F1 +#x8FCED7 #x76F6 +#x8FCED8 #x76F9 +#x8FCED9 #x76FC +#x8FCEDA #x7700 +#x8FCEDB #x7706 +#x8FCEDC #x770A +#x8FCEDD #x770E +#x8FCEDE #x7712 +#x8FCEDF #x7714 +#x8FCEE0 #x7715 +#x8FCEE1 #x7717 +#x8FCEE2 #x7719 +#x8FCEE3 #x771A +#x8FCEE4 #x771C +#x8FCEE5 #x7722 +#x8FCEE6 #x7728 +#x8FCEE7 #x772D +#x8FCEE8 #x772E +#x8FCEE9 #x772F +#x8FCEEA #x7734 +#x8FCEEB #x7735 +#x8FCEEC #x7736 +#x8FCEED #x7739 +#x8FCEEE #x773D +#x8FCEEF #x773E +#x8FCEF0 #x7742 +#x8FCEF1 #x7745 +#x8FCEF2 #x7746 +#x8FCEF3 #x774A +#x8FCEF4 #x774D +#x8FCEF5 #x774E +#x8FCEF6 #x774F +#x8FCEF7 #x7752 +#x8FCEF8 #x7756 +#x8FCEF9 #x7757 +#x8FCEFA #x775C +#x8FCEFB #x775E +#x8FCEFC #x775F +#x8FCEFD #x7760 +#x8FCEFE #x7762 +#x8FCFA1 #x7764 +#x8FCFA2 #x7767 +#x8FCFA3 #x776A +#x8FCFA4 #x776C +#x8FCFA5 #x7770 +#x8FCFA6 #x7772 +#x8FCFA7 #x7773 +#x8FCFA8 #x7774 +#x8FCFA9 #x777A +#x8FCFAA #x777D +#x8FCFAB #x7780 +#x8FCFAC #x7784 +#x8FCFAD #x778C +#x8FCFAE #x778D +#x8FCFAF #x7794 +#x8FCFB0 #x7795 +#x8FCFB1 #x7796 +#x8FCFB2 #x779A +#x8FCFB3 #x779F +#x8FCFB4 #x77A2 +#x8FCFB5 #x77A7 +#x8FCFB6 #x77AA +#x8FCFB7 #x77AE +#x8FCFB8 #x77AF +#x8FCFB9 #x77B1 +#x8FCFBA #x77B5 +#x8FCFBB #x77BE +#x8FCFBC #x77C3 +#x8FCFBD #x77C9 +#x8FCFBE #x77D1 +#x8FCFBF #x77D2 +#x8FCFC0 #x77D5 +#x8FCFC1 #x77D9 +#x8FCFC2 #x77DE +#x8FCFC3 #x77DF +#x8FCFC4 #x77E0 +#x8FCFC5 #x77E4 +#x8FCFC6 #x77E6 +#x8FCFC7 #x77EA +#x8FCFC8 #x77EC +#x8FCFC9 #x77F0 +#x8FCFCA #x77F1 +#x8FCFCB #x77F4 +#x8FCFCC #x77F8 +#x8FCFCD #x77FB +#x8FCFCE #x7805 +#x8FCFCF #x7806 +#x8FCFD0 #x7809 +#x8FCFD1 #x780D +#x8FCFD2 #x780E +#x8FCFD3 #x7811 +#x8FCFD4 #x781D +#x8FCFD5 #x7821 +#x8FCFD6 #x7822 +#x8FCFD7 #x7823 +#x8FCFD8 #x782D +#x8FCFD9 #x782E +#x8FCFDA #x7830 +#x8FCFDB #x7835 +#x8FCFDC #x7837 +#x8FCFDD #x7843 +#x8FCFDE #x7844 +#x8FCFDF #x7847 +#x8FCFE0 #x7848 +#x8FCFE1 #x784C +#x8FCFE2 #x784E +#x8FCFE3 #x7852 +#x8FCFE4 #x785C +#x8FCFE5 #x785E +#x8FCFE6 #x7860 +#x8FCFE7 #x7861 +#x8FCFE8 #x7863 +#x8FCFE9 #x7864 +#x8FCFEA #x7868 +#x8FCFEB #x786A +#x8FCFEC #x786E +#x8FCFED #x787A +#x8FCFEE #x787E +#x8FCFEF #x788A +#x8FCFF0 #x788F +#x8FCFF1 #x7894 +#x8FCFF2 #x7898 +#x8FCFF3 #x78A1 +#x8FCFF4 #x789D +#x8FCFF5 #x789E +#x8FCFF6 #x789F +#x8FCFF7 #x78A4 +#x8FCFF8 #x78A8 +#x8FCFF9 #x78AC +#x8FCFFA #x78AD +#x8FCFFB #x78B0 +#x8FCFFC #x78B1 +#x8FCFFD #x78B2 +#x8FCFFE #x78B3 +#x8FD0A1 #x78BB +#x8FD0A2 #x78BD +#x8FD0A3 #x78BF +#x8FD0A4 #x78C7 +#x8FD0A5 #x78C8 +#x8FD0A6 #x78C9 +#x8FD0A7 #x78CC +#x8FD0A8 #x78CE +#x8FD0A9 #x78D2 +#x8FD0AA #x78D3 +#x8FD0AB #x78D5 +#x8FD0AC #x78D6 +#x8FD0AD #x78E4 +#x8FD0AE #x78DB +#x8FD0AF #x78DF +#x8FD0B0 #x78E0 +#x8FD0B1 #x78E1 +#x8FD0B2 #x78E6 +#x8FD0B3 #x78EA +#x8FD0B4 #x78F2 +#x8FD0B5 #x78F3 +#x8FD0B6 #x7900 +#x8FD0B7 #x78F6 +#x8FD0B8 #x78F7 +#x8FD0B9 #x78FA +#x8FD0BA #x78FB +#x8FD0BB #x78FF +#x8FD0BC #x7906 +#x8FD0BD #x790C +#x8FD0BE #x7910 +#x8FD0BF #x791A +#x8FD0C0 #x791C +#x8FD0C1 #x791E +#x8FD0C2 #x791F +#x8FD0C3 #x7920 +#x8FD0C4 #x7925 +#x8FD0C5 #x7927 +#x8FD0C6 #x7929 +#x8FD0C7 #x792D +#x8FD0C8 #x7931 +#x8FD0C9 #x7934 +#x8FD0CA #x7935 +#x8FD0CB #x793B +#x8FD0CC #x793D +#x8FD0CD #x793F +#x8FD0CE #x7944 +#x8FD0CF #x7945 +#x8FD0D0 #x7946 +#x8FD0D1 #x794A +#x8FD0D2 #x794B +#x8FD0D3 #x794F +#x8FD0D4 #x7951 +#x8FD0D5 #x7954 +#x8FD0D6 #x7958 +#x8FD0D7 #x795B +#x8FD0D8 #x795C +#x8FD0D9 #x7967 +#x8FD0DA #x7969 +#x8FD0DB #x796B +#x8FD0DC #x7972 +#x8FD0DD #x7979 +#x8FD0DE #x797B +#x8FD0DF #x797C +#x8FD0E0 #x797E +#x8FD0E1 #x798B +#x8FD0E2 #x798C +#x8FD0E3 #x7991 +#x8FD0E4 #x7993 +#x8FD0E5 #x7994 +#x8FD0E6 #x7995 +#x8FD0E7 #x7996 +#x8FD0E8 #x7998 +#x8FD0E9 #x799B +#x8FD0EA #x799C +#x8FD0EB #x79A1 +#x8FD0EC #x79A8 +#x8FD0ED #x79A9 +#x8FD0EE #x79AB +#x8FD0EF #x79AF +#x8FD0F0 #x79B1 +#x8FD0F1 #x79B4 +#x8FD0F2 #x79B8 +#x8FD0F3 #x79BB +#x8FD0F4 #x79C2 +#x8FD0F5 #x79C4 +#x8FD0F6 #x79C7 +#x8FD0F7 #x79C8 +#x8FD0F8 #x79CA +#x8FD0F9 #x79CF +#x8FD0FA #x79D4 +#x8FD0FB #x79D6 +#x8FD0FC #x79DA +#x8FD0FD #x79DD +#x8FD0FE #x79DE +#x8FD1A1 #x79E0 +#x8FD1A2 #x79E2 +#x8FD1A3 #x79E5 +#x8FD1A4 #x79EA +#x8FD1A5 #x79EB +#x8FD1A6 #x79ED +#x8FD1A7 #x79F1 +#x8FD1A8 #x79F8 +#x8FD1A9 #x79FC +#x8FD1AA #x7A02 +#x8FD1AB #x7A03 +#x8FD1AC #x7A07 +#x8FD1AD #x7A09 +#x8FD1AE #x7A0A +#x8FD1AF #x7A0C +#x8FD1B0 #x7A11 +#x8FD1B1 #x7A15 +#x8FD1B2 #x7A1B +#x8FD1B3 #x7A1E +#x8FD1B4 #x7A21 +#x8FD1B5 #x7A27 +#x8FD1B6 #x7A2B +#x8FD1B7 #x7A2D +#x8FD1B8 #x7A2F +#x8FD1B9 #x7A30 +#x8FD1BA #x7A34 +#x8FD1BB #x7A35 +#x8FD1BC #x7A38 +#x8FD1BD #x7A39 +#x8FD1BE #x7A3A +#x8FD1BF #x7A44 +#x8FD1C0 #x7A45 +#x8FD1C1 #x7A47 +#x8FD1C2 #x7A48 +#x8FD1C3 #x7A4C +#x8FD1C4 #x7A55 +#x8FD1C5 #x7A56 +#x8FD1C6 #x7A59 +#x8FD1C7 #x7A5C +#x8FD1C8 #x7A5D +#x8FD1C9 #x7A5F +#x8FD1CA #x7A60 +#x8FD1CB #x7A65 +#x8FD1CC #x7A67 +#x8FD1CD #x7A6A +#x8FD1CE #x7A6D +#x8FD1CF #x7A75 +#x8FD1D0 #x7A78 +#x8FD1D1 #x7A7E +#x8FD1D2 #x7A80 +#x8FD1D3 #x7A82 +#x8FD1D4 #x7A85 +#x8FD1D5 #x7A86 +#x8FD1D6 #x7A8A +#x8FD1D7 #x7A8B +#x8FD1D8 #x7A90 +#x8FD1D9 #x7A91 +#x8FD1DA #x7A94 +#x8FD1DB #x7A9E +#x8FD1DC #x7AA0 +#x8FD1DD #x7AA3 +#x8FD1DE #x7AAC +#x8FD1DF #x7AB3 +#x8FD1E0 #x7AB5 +#x8FD1E1 #x7AB9 +#x8FD1E2 #x7ABB +#x8FD1E3 #x7ABC +#x8FD1E4 #x7AC6 +#x8FD1E5 #x7AC9 +#x8FD1E6 #x7ACC +#x8FD1E7 #x7ACE +#x8FD1E8 #x7AD1 +#x8FD1E9 #x7ADB +#x8FD1EA #x7AE8 +#x8FD1EB #x7AE9 +#x8FD1EC #x7AEB +#x8FD1ED #x7AEC +#x8FD1EE #x7AF1 +#x8FD1EF #x7AF4 +#x8FD1F0 #x7AFB +#x8FD1F1 #x7AFD +#x8FD1F2 #x7AFE +#x8FD1F3 #x7B07 +#x8FD1F4 #x7B14 +#x8FD1F5 #x7B1F +#x8FD1F6 #x7B23 +#x8FD1F7 #x7B27 +#x8FD1F8 #x7B29 +#x8FD1F9 #x7B2A +#x8FD1FA #x7B2B +#x8FD1FB #x7B2D +#x8FD1FC #x7B2E +#x8FD1FD #x7B2F +#x8FD1FE #x7B30 +#x8FD2A1 #x7B31 +#x8FD2A2 #x7B34 +#x8FD2A3 #x7B3D +#x8FD2A4 #x7B3F +#x8FD2A5 #x7B40 +#x8FD2A6 #x7B41 +#x8FD2A7 #x7B47 +#x8FD2A8 #x7B4E +#x8FD2A9 #x7B55 +#x8FD2AA #x7B60 +#x8FD2AB #x7B64 +#x8FD2AC #x7B66 +#x8FD2AD #x7B69 +#x8FD2AE #x7B6A +#x8FD2AF #x7B6D +#x8FD2B0 #x7B6F +#x8FD2B1 #x7B72 +#x8FD2B2 #x7B73 +#x8FD2B3 #x7B77 +#x8FD2B4 #x7B84 +#x8FD2B5 #x7B89 +#x8FD2B6 #x7B8E +#x8FD2B7 #x7B90 +#x8FD2B8 #x7B91 +#x8FD2B9 #x7B96 +#x8FD2BA #x7B9B +#x8FD2BB #x7B9E +#x8FD2BC #x7BA0 +#x8FD2BD #x7BA5 +#x8FD2BE #x7BAC +#x8FD2BF #x7BAF +#x8FD2C0 #x7BB0 +#x8FD2C1 #x7BB2 +#x8FD2C2 #x7BB5 +#x8FD2C3 #x7BB6 +#x8FD2C4 #x7BBA +#x8FD2C5 #x7BBB +#x8FD2C6 #x7BBC +#x8FD2C7 #x7BBD +#x8FD2C8 #x7BC2 +#x8FD2C9 #x7BC5 +#x8FD2CA #x7BC8 +#x8FD2CB #x7BCA +#x8FD2CC #x7BD4 +#x8FD2CD #x7BD6 +#x8FD2CE #x7BD7 +#x8FD2CF #x7BD9 +#x8FD2D0 #x7BDA +#x8FD2D1 #x7BDB +#x8FD2D2 #x7BE8 +#x8FD2D3 #x7BEA +#x8FD2D4 #x7BF2 +#x8FD2D5 #x7BF4 +#x8FD2D6 #x7BF5 +#x8FD2D7 #x7BF8 +#x8FD2D8 #x7BF9 +#x8FD2D9 #x7BFA +#x8FD2DA #x7BFC +#x8FD2DB #x7BFE +#x8FD2DC #x7C01 +#x8FD2DD #x7C02 +#x8FD2DE #x7C03 +#x8FD2DF #x7C04 +#x8FD2E0 #x7C06 +#x8FD2E1 #x7C09 +#x8FD2E2 #x7C0B +#x8FD2E3 #x7C0C +#x8FD2E4 #x7C0E +#x8FD2E5 #x7C0F +#x8FD2E6 #x7C19 +#x8FD2E7 #x7C1B +#x8FD2E8 #x7C20 +#x8FD2E9 #x7C25 +#x8FD2EA #x7C26 +#x8FD2EB #x7C28 +#x8FD2EC #x7C2C +#x8FD2ED #x7C31 +#x8FD2EE #x7C33 +#x8FD2EF #x7C34 +#x8FD2F0 #x7C36 +#x8FD2F1 #x7C39 +#x8FD2F2 #x7C3A +#x8FD2F3 #x7C46 +#x8FD2F4 #x7C4A +#x8FD2F5 #x7C55 +#x8FD2F6 #x7C51 +#x8FD2F7 #x7C52 +#x8FD2F8 #x7C53 +#x8FD2F9 #x7C59 +#x8FD2FA #x7C5A +#x8FD2FB #x7C5B +#x8FD2FC #x7C5C +#x8FD2FD #x7C5D +#x8FD2FE #x7C5E +#x8FD3A1 #x7C61 +#x8FD3A2 #x7C63 +#x8FD3A3 #x7C67 +#x8FD3A4 #x7C69 +#x8FD3A5 #x7C6D +#x8FD3A6 #x7C6E +#x8FD3A7 #x7C70 +#x8FD3A8 #x7C72 +#x8FD3A9 #x7C79 +#x8FD3AA #x7C7C +#x8FD3AB #x7C7D +#x8FD3AC #x7C86 +#x8FD3AD #x7C87 +#x8FD3AE #x7C8F +#x8FD3AF #x7C94 +#x8FD3B0 #x7C9E +#x8FD3B1 #x7CA0 +#x8FD3B2 #x7CA6 +#x8FD3B3 #x7CB0 +#x8FD3B4 #x7CB6 +#x8FD3B5 #x7CB7 +#x8FD3B6 #x7CBA +#x8FD3B7 #x7CBB +#x8FD3B8 #x7CBC +#x8FD3B9 #x7CBF +#x8FD3BA #x7CC4 +#x8FD3BB #x7CC7 +#x8FD3BC #x7CC8 +#x8FD3BD #x7CC9 +#x8FD3BE #x7CCD +#x8FD3BF #x7CCF +#x8FD3C0 #x7CD3 +#x8FD3C1 #x7CD4 +#x8FD3C2 #x7CD5 +#x8FD3C3 #x7CD7 +#x8FD3C4 #x7CD9 +#x8FD3C5 #x7CDA +#x8FD3C6 #x7CDD +#x8FD3C7 #x7CE6 +#x8FD3C8 #x7CE9 +#x8FD3C9 #x7CEB +#x8FD3CA #x7CF5 +#x8FD3CB #x7D03 +#x8FD3CC #x7D07 +#x8FD3CD #x7D08 +#x8FD3CE #x7D09 +#x8FD3CF #x7D0F +#x8FD3D0 #x7D11 +#x8FD3D1 #x7D12 +#x8FD3D2 #x7D13 +#x8FD3D3 #x7D16 +#x8FD3D4 #x7D1D +#x8FD3D5 #x7D1E +#x8FD3D6 #x7D23 +#x8FD3D7 #x7D26 +#x8FD3D8 #x7D2A +#x8FD3D9 #x7D2D +#x8FD3DA #x7D31 +#x8FD3DB #x7D3C +#x8FD3DC #x7D3D +#x8FD3DD #x7D3E +#x8FD3DE #x7D40 +#x8FD3DF #x7D41 +#x8FD3E0 #x7D47 +#x8FD3E1 #x7D48 +#x8FD3E2 #x7D4D +#x8FD3E3 #x7D51 +#x8FD3E4 #x7D53 +#x8FD3E5 #x7D57 +#x8FD3E6 #x7D59 +#x8FD3E7 #x7D5A +#x8FD3E8 #x7D5C +#x8FD3E9 #x7D5D +#x8FD3EA #x7D65 +#x8FD3EB #x7D67 +#x8FD3EC #x7D6A +#x8FD3ED #x7D70 +#x8FD3EE #x7D78 +#x8FD3EF #x7D7A +#x8FD3F0 #x7D7B +#x8FD3F1 #x7D7F +#x8FD3F2 #x7D81 +#x8FD3F3 #x7D82 +#x8FD3F4 #x7D83 +#x8FD3F5 #x7D85 +#x8FD3F6 #x7D86 +#x8FD3F7 #x7D88 +#x8FD3F8 #x7D8B +#x8FD3F9 #x7D8C +#x8FD3FA #x7D8D +#x8FD3FB #x7D91 +#x8FD3FC #x7D96 +#x8FD3FD #x7D97 +#x8FD3FE #x7D9D +#x8FD4A1 #x7D9E +#x8FD4A2 #x7DA6 +#x8FD4A3 #x7DA7 +#x8FD4A4 #x7DAA +#x8FD4A5 #x7DB3 +#x8FD4A6 #x7DB6 +#x8FD4A7 #x7DB7 +#x8FD4A8 #x7DB9 +#x8FD4A9 #x7DC2 +#x8FD4AA #x7DC3 +#x8FD4AB #x7DC4 +#x8FD4AC #x7DC5 +#x8FD4AD #x7DC6 +#x8FD4AE #x7DCC +#x8FD4AF #x7DCD +#x8FD4B0 #x7DCE +#x8FD4B1 #x7DD7 +#x8FD4B2 #x7DD9 +#x8FD4B3 #x7E00 +#x8FD4B4 #x7DE2 +#x8FD4B5 #x7DE5 +#x8FD4B6 #x7DE6 +#x8FD4B7 #x7DEA +#x8FD4B8 #x7DEB +#x8FD4B9 #x7DED +#x8FD4BA #x7DF1 +#x8FD4BB #x7DF5 +#x8FD4BC #x7DF6 +#x8FD4BD #x7DF9 +#x8FD4BE #x7DFA +#x8FD4BF #x7E08 +#x8FD4C0 #x7E10 +#x8FD4C1 #x7E11 +#x8FD4C2 #x7E15 +#x8FD4C3 #x7E17 +#x8FD4C4 #x7E1C +#x8FD4C5 #x7E1D +#x8FD4C6 #x7E20 +#x8FD4C7 #x7E27 +#x8FD4C8 #x7E28 +#x8FD4C9 #x7E2C +#x8FD4CA #x7E2D +#x8FD4CB #x7E2F +#x8FD4CC #x7E33 +#x8FD4CD #x7E36 +#x8FD4CE #x7E3F +#x8FD4CF #x7E44 +#x8FD4D0 #x7E45 +#x8FD4D1 #x7E47 +#x8FD4D2 #x7E4E +#x8FD4D3 #x7E50 +#x8FD4D4 #x7E52 +#x8FD4D5 #x7E58 +#x8FD4D6 #x7E5F +#x8FD4D7 #x7E61 +#x8FD4D8 #x7E62 +#x8FD4D9 #x7E65 +#x8FD4DA #x7E6B +#x8FD4DB #x7E6E +#x8FD4DC #x7E6F +#x8FD4DD #x7E73 +#x8FD4DE #x7E78 +#x8FD4DF #x7E7E +#x8FD4E0 #x7E81 +#x8FD4E1 #x7E86 +#x8FD4E2 #x7E87 +#x8FD4E3 #x7E8A +#x8FD4E4 #x7E8D +#x8FD4E5 #x7E91 +#x8FD4E6 #x7E95 +#x8FD4E7 #x7E98 +#x8FD4E8 #x7E9A +#x8FD4E9 #x7E9D +#x8FD4EA #x7E9E +#x8FD4EB #x7F3C +#x8FD4EC #x7F3B +#x8FD4ED #x7F3D +#x8FD4EE #x7F3E +#x8FD4EF #x7F3F +#x8FD4F0 #x7F43 +#x8FD4F1 #x7F44 +#x8FD4F2 #x7F47 +#x8FD4F3 #x7F4F +#x8FD4F4 #x7F52 +#x8FD4F5 #x7F53 +#x8FD4F6 #x7F5B +#x8FD4F7 #x7F5C +#x8FD4F8 #x7F5D +#x8FD4F9 #x7F61 +#x8FD4FA #x7F63 +#x8FD4FB #x7F64 +#x8FD4FC #x7F65 +#x8FD4FD #x7F66 +#x8FD4FE #x7F6D +#x8FD5A1 #x7F71 +#x8FD5A2 #x7F7D +#x8FD5A3 #x7F7E +#x8FD5A4 #x7F7F +#x8FD5A5 #x7F80 +#x8FD5A6 #x7F8B +#x8FD5A7 #x7F8D +#x8FD5A8 #x7F8F +#x8FD5A9 #x7F90 +#x8FD5AA #x7F91 +#x8FD5AB #x7F96 +#x8FD5AC #x7F97 +#x8FD5AD #x7F9C +#x8FD5AE #x7FA1 +#x8FD5AF #x7FA2 +#x8FD5B0 #x7FA6 +#x8FD5B1 #x7FAA +#x8FD5B2 #x7FAD +#x8FD5B3 #x7FB4 +#x8FD5B4 #x7FBC +#x8FD5B5 #x7FBF +#x8FD5B6 #x7FC0 +#x8FD5B7 #x7FC3 +#x8FD5B8 #x7FC8 +#x8FD5B9 #x7FCE +#x8FD5BA #x7FCF +#x8FD5BB #x7FDB +#x8FD5BC #x7FDF +#x8FD5BD #x7FE3 +#x8FD5BE #x7FE5 +#x8FD5BF #x7FE8 +#x8FD5C0 #x7FEC +#x8FD5C1 #x7FEE +#x8FD5C2 #x7FEF +#x8FD5C3 #x7FF2 +#x8FD5C4 #x7FFA +#x8FD5C5 #x7FFD +#x8FD5C6 #x7FFE +#x8FD5C7 #x7FFF +#x8FD5C8 #x8007 +#x8FD5C9 #x8008 +#x8FD5CA #x800A +#x8FD5CB #x800D +#x8FD5CC #x800E +#x8FD5CD #x800F +#x8FD5CE #x8011 +#x8FD5CF #x8013 +#x8FD5D0 #x8014 +#x8FD5D1 #x8016 +#x8FD5D2 #x801D +#x8FD5D3 #x801E +#x8FD5D4 #x801F +#x8FD5D5 #x8020 +#x8FD5D6 #x8024 +#x8FD5D7 #x8026 +#x8FD5D8 #x802C +#x8FD5D9 #x802E +#x8FD5DA #x8030 +#x8FD5DB #x8034 +#x8FD5DC #x8035 +#x8FD5DD #x8037 +#x8FD5DE #x8039 +#x8FD5DF #x803A +#x8FD5E0 #x803C +#x8FD5E1 #x803E +#x8FD5E2 #x8040 +#x8FD5E3 #x8044 +#x8FD5E4 #x8060 +#x8FD5E5 #x8064 +#x8FD5E6 #x8066 +#x8FD5E7 #x806D +#x8FD5E8 #x8071 +#x8FD5E9 #x8075 +#x8FD5EA #x8081 +#x8FD5EB #x8088 +#x8FD5EC #x808E +#x8FD5ED #x809C +#x8FD5EE #x809E +#x8FD5EF #x80A6 +#x8FD5F0 #x80A7 +#x8FD5F1 #x80AB +#x8FD5F2 #x80B8 +#x8FD5F3 #x80B9 +#x8FD5F4 #x80C8 +#x8FD5F5 #x80CD +#x8FD5F6 #x80CF +#x8FD5F7 #x80D2 +#x8FD5F8 #x80D4 +#x8FD5F9 #x80D5 +#x8FD5FA #x80D7 +#x8FD5FB #x80D8 +#x8FD5FC #x80E0 +#x8FD5FD #x80ED +#x8FD5FE #x80EE +#x8FD6A1 #x80F0 +#x8FD6A2 #x80F2 +#x8FD6A3 #x80F3 +#x8FD6A4 #x80F6 +#x8FD6A5 #x80F9 +#x8FD6A6 #x80FA +#x8FD6A7 #x80FE +#x8FD6A8 #x8103 +#x8FD6A9 #x810B +#x8FD6AA #x8116 +#x8FD6AB #x8117 +#x8FD6AC #x8118 +#x8FD6AD #x811C +#x8FD6AE #x811E +#x8FD6AF #x8120 +#x8FD6B0 #x8124 +#x8FD6B1 #x8127 +#x8FD6B2 #x812C +#x8FD6B3 #x8130 +#x8FD6B4 #x8135 +#x8FD6B5 #x813A +#x8FD6B6 #x813C +#x8FD6B7 #x8145 +#x8FD6B8 #x8147 +#x8FD6B9 #x814A +#x8FD6BA #x814C +#x8FD6BB #x8152 +#x8FD6BC #x8157 +#x8FD6BD #x8160 +#x8FD6BE #x8161 +#x8FD6BF #x8167 +#x8FD6C0 #x8168 +#x8FD6C1 #x8169 +#x8FD6C2 #x816D +#x8FD6C3 #x816F +#x8FD6C4 #x8177 +#x8FD6C5 #x8181 +#x8FD6C6 #x8190 +#x8FD6C7 #x8184 +#x8FD6C8 #x8185 +#x8FD6C9 #x8186 +#x8FD6CA #x818B +#x8FD6CB #x818E +#x8FD6CC #x8196 +#x8FD6CD #x8198 +#x8FD6CE #x819B +#x8FD6CF #x819E +#x8FD6D0 #x81A2 +#x8FD6D1 #x81AE +#x8FD6D2 #x81B2 +#x8FD6D3 #x81B4 +#x8FD6D4 #x81BB +#x8FD6D5 #x81CB +#x8FD6D6 #x81C3 +#x8FD6D7 #x81C5 +#x8FD6D8 #x81CA +#x8FD6D9 #x81CE +#x8FD6DA #x81CF +#x8FD6DB #x81D5 +#x8FD6DC #x81D7 +#x8FD6DD #x81DB +#x8FD6DE #x81DD +#x8FD6DF #x81DE +#x8FD6E0 #x81E1 +#x8FD6E1 #x81E4 +#x8FD6E2 #x81EB +#x8FD6E3 #x81EC +#x8FD6E4 #x81F0 +#x8FD6E5 #x81F1 +#x8FD6E6 #x81F2 +#x8FD6E7 #x81F5 +#x8FD6E8 #x81F6 +#x8FD6E9 #x81F8 +#x8FD6EA #x81F9 +#x8FD6EB #x81FD +#x8FD6EC #x81FF +#x8FD6ED #x8200 +#x8FD6EE #x8203 +#x8FD6EF #x820F +#x8FD6F0 #x8213 +#x8FD6F1 #x8214 +#x8FD6F2 #x8219 +#x8FD6F3 #x821A +#x8FD6F4 #x821D +#x8FD6F5 #x8221 +#x8FD6F6 #x8222 +#x8FD6F7 #x8228 +#x8FD6F8 #x8232 +#x8FD6F9 #x8234 +#x8FD6FA #x823A +#x8FD6FB #x8243 +#x8FD6FC #x8244 +#x8FD6FD #x8245 +#x8FD6FE #x8246 +#x8FD7A1 #x824B +#x8FD7A2 #x824E +#x8FD7A3 #x824F +#x8FD7A4 #x8251 +#x8FD7A5 #x8256 +#x8FD7A6 #x825C +#x8FD7A7 #x8260 +#x8FD7A8 #x8263 +#x8FD7A9 #x8267 +#x8FD7AA #x826D +#x8FD7AB #x8274 +#x8FD7AC #x827B +#x8FD7AD #x827D +#x8FD7AE #x827F +#x8FD7AF #x8280 +#x8FD7B0 #x8281 +#x8FD7B1 #x8283 +#x8FD7B2 #x8284 +#x8FD7B3 #x8287 +#x8FD7B4 #x8289 +#x8FD7B5 #x828A +#x8FD7B6 #x828E +#x8FD7B7 #x8291 +#x8FD7B8 #x8294 +#x8FD7B9 #x8296 +#x8FD7BA #x8298 +#x8FD7BB #x829A +#x8FD7BC #x829B +#x8FD7BD #x82A0 +#x8FD7BE #x82A1 +#x8FD7BF #x82A3 +#x8FD7C0 #x82A4 +#x8FD7C1 #x82A7 +#x8FD7C2 #x82A8 +#x8FD7C3 #x82A9 +#x8FD7C4 #x82AA +#x8FD7C5 #x82AE +#x8FD7C6 #x82B0 +#x8FD7C7 #x82B2 +#x8FD7C8 #x82B4 +#x8FD7C9 #x82B7 +#x8FD7CA #x82BA +#x8FD7CB #x82BC +#x8FD7CC #x82BE +#x8FD7CD #x82BF +#x8FD7CE #x82C6 +#x8FD7CF #x82D0 +#x8FD7D0 #x82D5 +#x8FD7D1 #x82DA +#x8FD7D2 #x82E0 +#x8FD7D3 #x82E2 +#x8FD7D4 #x82E4 +#x8FD7D5 #x82E8 +#x8FD7D6 #x82EA +#x8FD7D7 #x82ED +#x8FD7D8 #x82EF +#x8FD7D9 #x82F6 +#x8FD7DA #x82F7 +#x8FD7DB #x82FD +#x8FD7DC #x82FE +#x8FD7DD #x8300 +#x8FD7DE #x8301 +#x8FD7DF #x8307 +#x8FD7E0 #x8308 +#x8FD7E1 #x830A +#x8FD7E2 #x830B +#x8FD7E3 #x8354 +#x8FD7E4 #x831B +#x8FD7E5 #x831D +#x8FD7E6 #x831E +#x8FD7E7 #x831F +#x8FD7E8 #x8321 +#x8FD7E9 #x8322 +#x8FD7EA #x832C +#x8FD7EB #x832D +#x8FD7EC #x832E +#x8FD7ED #x8330 +#x8FD7EE #x8333 +#x8FD7EF #x8337 +#x8FD7F0 #x833A +#x8FD7F1 #x833C +#x8FD7F2 #x833D +#x8FD7F3 #x8342 +#x8FD7F4 #x8343 +#x8FD7F5 #x8344 +#x8FD7F6 #x8347 +#x8FD7F7 #x834D +#x8FD7F8 #x834E +#x8FD7F9 #x8351 +#x8FD7FA #x8355 +#x8FD7FB #x8356 +#x8FD7FC #x8357 +#x8FD7FD #x8370 +#x8FD7FE #x8378 +#x8FD8A1 #x837D +#x8FD8A2 #x837F +#x8FD8A3 #x8380 +#x8FD8A4 #x8382 +#x8FD8A5 #x8384 +#x8FD8A6 #x8386 +#x8FD8A7 #x838D +#x8FD8A8 #x8392 +#x8FD8A9 #x8394 +#x8FD8AA #x8395 +#x8FD8AB #x8398 +#x8FD8AC #x8399 +#x8FD8AD #x839B +#x8FD8AE #x839C +#x8FD8AF #x839D +#x8FD8B0 #x83A6 +#x8FD8B1 #x83A7 +#x8FD8B2 #x83A9 +#x8FD8B3 #x83AC +#x8FD8B4 #x83BE +#x8FD8B5 #x83BF +#x8FD8B6 #x83C0 +#x8FD8B7 #x83C7 +#x8FD8B8 #x83C9 +#x8FD8B9 #x83CF +#x8FD8BA #x83D0 +#x8FD8BB #x83D1 +#x8FD8BC #x83D4 +#x8FD8BD #x83DD +#x8FD8BE #x8353 +#x8FD8BF #x83E8 +#x8FD8C0 #x83EA +#x8FD8C1 #x83F6 +#x8FD8C2 #x83F8 +#x8FD8C3 #x83F9 +#x8FD8C4 #x83FC +#x8FD8C5 #x8401 +#x8FD8C6 #x8406 +#x8FD8C7 #x840A +#x8FD8C8 #x840F +#x8FD8C9 #x8411 +#x8FD8CA #x8415 +#x8FD8CB #x8419 +#x8FD8CC #x83AD +#x8FD8CD #x842F +#x8FD8CE #x8439 +#x8FD8CF #x8445 +#x8FD8D0 #x8447 +#x8FD8D1 #x8448 +#x8FD8D2 #x844A +#x8FD8D3 #x844D +#x8FD8D4 #x844F +#x8FD8D5 #x8451 +#x8FD8D6 #x8452 +#x8FD8D7 #x8456 +#x8FD8D8 #x8458 +#x8FD8D9 #x8459 +#x8FD8DA #x845A +#x8FD8DB #x845C +#x8FD8DC #x8460 +#x8FD8DD #x8464 +#x8FD8DE #x8465 +#x8FD8DF #x8467 +#x8FD8E0 #x846A +#x8FD8E1 #x8470 +#x8FD8E2 #x8473 +#x8FD8E3 #x8474 +#x8FD8E4 #x8476 +#x8FD8E5 #x8478 +#x8FD8E6 #x847C +#x8FD8E7 #x847D +#x8FD8E8 #x8481 +#x8FD8E9 #x8485 +#x8FD8EA #x8492 +#x8FD8EB #x8493 +#x8FD8EC #x8495 +#x8FD8ED #x849E +#x8FD8EE #x84A6 +#x8FD8EF #x84A8 +#x8FD8F0 #x84A9 +#x8FD8F1 #x84AA +#x8FD8F2 #x84AF +#x8FD8F3 #x84B1 +#x8FD8F4 #x84B4 +#x8FD8F5 #x84BA +#x8FD8F6 #x84BD +#x8FD8F7 #x84BE +#x8FD8F8 #x84C0 +#x8FD8F9 #x84C2 +#x8FD8FA #x84C7 +#x8FD8FB #x84C8 +#x8FD8FC #x84CC +#x8FD8FD #x84CF +#x8FD8FE #x84D3 +#x8FD9A1 #x84DC +#x8FD9A2 #x84E7 +#x8FD9A3 #x84EA +#x8FD9A4 #x84EF +#x8FD9A5 #x84F0 +#x8FD9A6 #x84F1 +#x8FD9A7 #x84F2 +#x8FD9A8 #x84F7 +#x8FD9A9 #x8532 +#x8FD9AA #x84FA +#x8FD9AB #x84FB +#x8FD9AC #x84FD +#x8FD9AD #x8502 +#x8FD9AE #x8503 +#x8FD9AF #x8507 +#x8FD9B0 #x850C +#x8FD9B1 #x850E +#x8FD9B2 #x8510 +#x8FD9B3 #x851C +#x8FD9B4 #x851E +#x8FD9B5 #x8522 +#x8FD9B6 #x8523 +#x8FD9B7 #x8524 +#x8FD9B8 #x8525 +#x8FD9B9 #x8527 +#x8FD9BA #x852A +#x8FD9BB #x852B +#x8FD9BC #x852F +#x8FD9BD #x8533 +#x8FD9BE #x8534 +#x8FD9BF #x8536 +#x8FD9C0 #x853F +#x8FD9C1 #x8546 +#x8FD9C2 #x854F +#x8FD9C3 #x8550 +#x8FD9C4 #x8551 +#x8FD9C5 #x8552 +#x8FD9C6 #x8553 +#x8FD9C7 #x8556 +#x8FD9C8 #x8559 +#x8FD9C9 #x855C +#x8FD9CA #x855D +#x8FD9CB #x855E +#x8FD9CC #x855F +#x8FD9CD #x8560 +#x8FD9CE #x8561 +#x8FD9CF #x8562 +#x8FD9D0 #x8564 +#x8FD9D1 #x856B +#x8FD9D2 #x856F +#x8FD9D3 #x8579 +#x8FD9D4 #x857A +#x8FD9D5 #x857B +#x8FD9D6 #x857D +#x8FD9D7 #x857F +#x8FD9D8 #x8581 +#x8FD9D9 #x8585 +#x8FD9DA #x8586 +#x8FD9DB #x8589 +#x8FD9DC #x858B +#x8FD9DD #x858C +#x8FD9DE #x858F +#x8FD9DF #x8593 +#x8FD9E0 #x8598 +#x8FD9E1 #x859D +#x8FD9E2 #x859F +#x8FD9E3 #x85A0 +#x8FD9E4 #x85A2 +#x8FD9E5 #x85A5 +#x8FD9E6 #x85A7 +#x8FD9E7 #x85B4 +#x8FD9E8 #x85B6 +#x8FD9E9 #x85B7 +#x8FD9EA #x85B8 +#x8FD9EB #x85BC +#x8FD9EC #x85BD +#x8FD9ED #x85BE +#x8FD9EE #x85BF +#x8FD9EF #x85C2 +#x8FD9F0 #x85C7 +#x8FD9F1 #x85CA +#x8FD9F2 #x85CB +#x8FD9F3 #x85CE +#x8FD9F4 #x85AD +#x8FD9F5 #x85D8 +#x8FD9F6 #x85DA +#x8FD9F7 #x85DF +#x8FD9F8 #x85E0 +#x8FD9F9 #x85E6 +#x8FD9FA #x85E8 +#x8FD9FB #x85ED +#x8FD9FC #x85F3 +#x8FD9FD #x85F6 +#x8FD9FE #x85FC +#x8FDAA1 #x85FF +#x8FDAA2 #x8600 +#x8FDAA3 #x8604 +#x8FDAA4 #x8605 +#x8FDAA5 #x860D +#x8FDAA6 #x860E +#x8FDAA7 #x8610 +#x8FDAA8 #x8611 +#x8FDAA9 #x8612 +#x8FDAAA #x8618 +#x8FDAAB #x8619 +#x8FDAAC #x861B +#x8FDAAD #x861E +#x8FDAAE #x8621 +#x8FDAAF #x8627 +#x8FDAB0 #x8629 +#x8FDAB1 #x8636 +#x8FDAB2 #x8638 +#x8FDAB3 #x863A +#x8FDAB4 #x863C +#x8FDAB5 #x863D +#x8FDAB6 #x8640 +#x8FDAB7 #x8642 +#x8FDAB8 #x8646 +#x8FDAB9 #x8652 +#x8FDABA #x8653 +#x8FDABB #x8656 +#x8FDABC #x8657 +#x8FDABD #x8658 +#x8FDABE #x8659 +#x8FDABF #x865D +#x8FDAC0 #x8660 +#x8FDAC1 #x8661 +#x8FDAC2 #x8662 +#x8FDAC3 #x8663 +#x8FDAC4 #x8664 +#x8FDAC5 #x8669 +#x8FDAC6 #x866C +#x8FDAC7 #x866F +#x8FDAC8 #x8675 +#x8FDAC9 #x8676 +#x8FDACA #x8677 +#x8FDACB #x867A +#x8FDACC #x868D +#x8FDACD #x8691 +#x8FDACE #x8696 +#x8FDACF #x8698 +#x8FDAD0 #x869A +#x8FDAD1 #x869C +#x8FDAD2 #x86A1 +#x8FDAD3 #x86A6 +#x8FDAD4 #x86A7 +#x8FDAD5 #x86A8 +#x8FDAD6 #x86AD +#x8FDAD7 #x86B1 +#x8FDAD8 #x86B3 +#x8FDAD9 #x86B4 +#x8FDADA #x86B5 +#x8FDADB #x86B7 +#x8FDADC #x86B8 +#x8FDADD #x86B9 +#x8FDADE #x86BF +#x8FDADF #x86C0 +#x8FDAE0 #x86C1 +#x8FDAE1 #x86C3 +#x8FDAE2 #x86C5 +#x8FDAE3 #x86D1 +#x8FDAE4 #x86D2 +#x8FDAE5 #x86D5 +#x8FDAE6 #x86D7 +#x8FDAE7 #x86DA +#x8FDAE8 #x86DC +#x8FDAE9 #x86E0 +#x8FDAEA #x86E3 +#x8FDAEB #x86E5 +#x8FDAEC #x86E7 +#x8FDAED #x8688 +#x8FDAEE #x86FA +#x8FDAEF #x86FC +#x8FDAF0 #x86FD +#x8FDAF1 #x8704 +#x8FDAF2 #x8705 +#x8FDAF3 #x8707 +#x8FDAF4 #x870B +#x8FDAF5 #x870E +#x8FDAF6 #x870F +#x8FDAF7 #x8710 +#x8FDAF8 #x8713 +#x8FDAF9 #x8714 +#x8FDAFA #x8719 +#x8FDAFB #x871E +#x8FDAFC #x871F +#x8FDAFD #x8721 +#x8FDAFE #x8723 +#x8FDBA1 #x8728 +#x8FDBA2 #x872E +#x8FDBA3 #x872F +#x8FDBA4 #x8731 +#x8FDBA5 #x8732 +#x8FDBA6 #x8739 +#x8FDBA7 #x873A +#x8FDBA8 #x873C +#x8FDBA9 #x873D +#x8FDBAA #x873E +#x8FDBAB #x8740 +#x8FDBAC #x8743 +#x8FDBAD #x8745 +#x8FDBAE #x874D +#x8FDBAF #x8758 +#x8FDBB0 #x875D +#x8FDBB1 #x8761 +#x8FDBB2 #x8764 +#x8FDBB3 #x8765 +#x8FDBB4 #x876F +#x8FDBB5 #x8771 +#x8FDBB6 #x8772 +#x8FDBB7 #x877B +#x8FDBB8 #x8783 +#x8FDBB9 #x8784 +#x8FDBBA #x8785 +#x8FDBBB #x8786 +#x8FDBBC #x8787 +#x8FDBBD #x8788 +#x8FDBBE #x8789 +#x8FDBBF #x878B +#x8FDBC0 #x878C +#x8FDBC1 #x8790 +#x8FDBC2 #x8793 +#x8FDBC3 #x8795 +#x8FDBC4 #x8797 +#x8FDBC5 #x8798 +#x8FDBC6 #x8799 +#x8FDBC7 #x879E +#x8FDBC8 #x87A0 +#x8FDBC9 #x87A3 +#x8FDBCA #x87A7 +#x8FDBCB #x87AC +#x8FDBCC #x87AD +#x8FDBCD #x87AE +#x8FDBCE #x87B1 +#x8FDBCF #x87B5 +#x8FDBD0 #x87BE +#x8FDBD1 #x87BF +#x8FDBD2 #x87C1 +#x8FDBD3 #x87C8 +#x8FDBD4 #x87C9 +#x8FDBD5 #x87CA +#x8FDBD6 #x87CE +#x8FDBD7 #x87D5 +#x8FDBD8 #x87D6 +#x8FDBD9 #x87D9 +#x8FDBDA #x87DA +#x8FDBDB #x87DC +#x8FDBDC #x87DF +#x8FDBDD #x87E2 +#x8FDBDE #x87E3 +#x8FDBDF #x87E4 +#x8FDBE0 #x87EA +#x8FDBE1 #x87EB +#x8FDBE2 #x87ED +#x8FDBE3 #x87F1 +#x8FDBE4 #x87F3 +#x8FDBE5 #x87F8 +#x8FDBE6 #x87FA +#x8FDBE7 #x87FF +#x8FDBE8 #x8801 +#x8FDBE9 #x8803 +#x8FDBEA #x8806 +#x8FDBEB #x8809 +#x8FDBEC #x880A +#x8FDBED #x880B +#x8FDBEE #x8810 +#x8FDBEF #x8819 +#x8FDBF0 #x8812 +#x8FDBF1 #x8813 +#x8FDBF2 #x8814 +#x8FDBF3 #x8818 +#x8FDBF4 #x881A +#x8FDBF5 #x881B +#x8FDBF6 #x881C +#x8FDBF7 #x881E +#x8FDBF8 #x881F +#x8FDBF9 #x8828 +#x8FDBFA #x882D +#x8FDBFB #x882E +#x8FDBFC #x8830 +#x8FDBFD #x8832 +#x8FDBFE #x8835 +#x8FDCA1 #x883A +#x8FDCA2 #x883C +#x8FDCA3 #x8841 +#x8FDCA4 #x8843 +#x8FDCA5 #x8845 +#x8FDCA6 #x8848 +#x8FDCA7 #x8849 +#x8FDCA8 #x884A +#x8FDCA9 #x884B +#x8FDCAA #x884E +#x8FDCAB #x8851 +#x8FDCAC #x8855 +#x8FDCAD #x8856 +#x8FDCAE #x8858 +#x8FDCAF #x885A +#x8FDCB0 #x885C +#x8FDCB1 #x885F +#x8FDCB2 #x8860 +#x8FDCB3 #x8864 +#x8FDCB4 #x8869 +#x8FDCB5 #x8871 +#x8FDCB6 #x8879 +#x8FDCB7 #x887B +#x8FDCB8 #x8880 +#x8FDCB9 #x8898 +#x8FDCBA #x889A +#x8FDCBB #x889B +#x8FDCBC #x889C +#x8FDCBD #x889F +#x8FDCBE #x88A0 +#x8FDCBF #x88A8 +#x8FDCC0 #x88AA +#x8FDCC1 #x88BA +#x8FDCC2 #x88BD +#x8FDCC3 #x88BE +#x8FDCC4 #x88C0 +#x8FDCC5 #x88CA +#x8FDCC6 #x88CB +#x8FDCC7 #x88CC +#x8FDCC8 #x88CD +#x8FDCC9 #x88CE +#x8FDCCA #x88D1 +#x8FDCCB #x88D2 +#x8FDCCC #x88D3 +#x8FDCCD #x88DB +#x8FDCCE #x88DE +#x8FDCCF #x88E7 +#x8FDCD0 #x88EF +#x8FDCD1 #x88F0 +#x8FDCD2 #x88F1 +#x8FDCD3 #x88F5 +#x8FDCD4 #x88F7 +#x8FDCD5 #x8901 +#x8FDCD6 #x8906 +#x8FDCD7 #x890D +#x8FDCD8 #x890E +#x8FDCD9 #x890F +#x8FDCDA #x8915 +#x8FDCDB #x8916 +#x8FDCDC #x8918 +#x8FDCDD #x8919 +#x8FDCDE #x891A +#x8FDCDF #x891C +#x8FDCE0 #x8920 +#x8FDCE1 #x8926 +#x8FDCE2 #x8927 +#x8FDCE3 #x8928 +#x8FDCE4 #x8930 +#x8FDCE5 #x8931 +#x8FDCE6 #x8932 +#x8FDCE7 #x8935 +#x8FDCE8 #x8939 +#x8FDCE9 #x893A +#x8FDCEA #x893E +#x8FDCEB #x8940 +#x8FDCEC #x8942 +#x8FDCED #x8945 +#x8FDCEE #x8946 +#x8FDCEF #x8949 +#x8FDCF0 #x894F +#x8FDCF1 #x8952 +#x8FDCF2 #x8957 +#x8FDCF3 #x895A +#x8FDCF4 #x895B +#x8FDCF5 #x895C +#x8FDCF6 #x8961 +#x8FDCF7 #x8962 +#x8FDCF8 #x8963 +#x8FDCF9 #x896B +#x8FDCFA #x896E +#x8FDCFB #x8970 +#x8FDCFC #x8973 +#x8FDCFD #x8975 +#x8FDCFE #x897A +#x8FDDA1 #x897B +#x8FDDA2 #x897C +#x8FDDA3 #x897D +#x8FDDA4 #x8989 +#x8FDDA5 #x898D +#x8FDDA6 #x8990 +#x8FDDA7 #x8994 +#x8FDDA8 #x8995 +#x8FDDA9 #x899B +#x8FDDAA #x899C +#x8FDDAB #x899F +#x8FDDAC #x89A0 +#x8FDDAD #x89A5 +#x8FDDAE #x89B0 +#x8FDDAF #x89B4 +#x8FDDB0 #x89B5 +#x8FDDB1 #x89B6 +#x8FDDB2 #x89B7 +#x8FDDB3 #x89BC +#x8FDDB4 #x89D4 +#x8FDDB5 #x89D5 +#x8FDDB6 #x89D6 +#x8FDDB7 #x89D7 +#x8FDDB8 #x89D8 +#x8FDDB9 #x89E5 +#x8FDDBA #x89E9 +#x8FDDBB #x89EB +#x8FDDBC #x89ED +#x8FDDBD #x89F1 +#x8FDDBE #x89F3 +#x8FDDBF #x89F6 +#x8FDDC0 #x89F9 +#x8FDDC1 #x89FD +#x8FDDC2 #x89FF +#x8FDDC3 #x8A04 +#x8FDDC4 #x8A05 +#x8FDDC5 #x8A07 +#x8FDDC6 #x8A0F +#x8FDDC7 #x8A11 +#x8FDDC8 #x8A12 +#x8FDDC9 #x8A14 +#x8FDDCA #x8A15 +#x8FDDCB #x8A1E +#x8FDDCC #x8A20 +#x8FDDCD #x8A22 +#x8FDDCE #x8A24 +#x8FDDCF #x8A26 +#x8FDDD0 #x8A2B +#x8FDDD1 #x8A2C +#x8FDDD2 #x8A2F +#x8FDDD3 #x8A35 +#x8FDDD4 #x8A37 +#x8FDDD5 #x8A3D +#x8FDDD6 #x8A3E +#x8FDDD7 #x8A40 +#x8FDDD8 #x8A43 +#x8FDDD9 #x8A45 +#x8FDDDA #x8A47 +#x8FDDDB #x8A49 +#x8FDDDC #x8A4D +#x8FDDDD #x8A4E +#x8FDDDE #x8A53 +#x8FDDDF #x8A56 +#x8FDDE0 #x8A57 +#x8FDDE1 #x8A58 +#x8FDDE2 #x8A5C +#x8FDDE3 #x8A5D +#x8FDDE4 #x8A61 +#x8FDDE5 #x8A65 +#x8FDDE6 #x8A67 +#x8FDDE7 #x8A75 +#x8FDDE8 #x8A76 +#x8FDDE9 #x8A77 +#x8FDDEA #x8A79 +#x8FDDEB #x8A7A +#x8FDDEC #x8A7B +#x8FDDED #x8A7E +#x8FDDEE #x8A7F +#x8FDDEF #x8A80 +#x8FDDF0 #x8A83 +#x8FDDF1 #x8A86 +#x8FDDF2 #x8A8B +#x8FDDF3 #x8A8F +#x8FDDF4 #x8A90 +#x8FDDF5 #x8A92 +#x8FDDF6 #x8A96 +#x8FDDF7 #x8A97 +#x8FDDF8 #x8A99 +#x8FDDF9 #x8A9F +#x8FDDFA #x8AA7 +#x8FDDFB #x8AA9 +#x8FDDFC #x8AAE +#x8FDDFD #x8AAF +#x8FDDFE #x8AB3 +#x8FDEA1 #x8AB6 +#x8FDEA2 #x8AB7 +#x8FDEA3 #x8ABB +#x8FDEA4 #x8ABE +#x8FDEA5 #x8AC3 +#x8FDEA6 #x8AC6 +#x8FDEA7 #x8AC8 +#x8FDEA8 #x8AC9 +#x8FDEA9 #x8ACA +#x8FDEAA #x8AD1 +#x8FDEAB #x8AD3 +#x8FDEAC #x8AD4 +#x8FDEAD #x8AD5 +#x8FDEAE #x8AD7 +#x8FDEAF #x8ADD +#x8FDEB0 #x8ADF +#x8FDEB1 #x8AEC +#x8FDEB2 #x8AF0 +#x8FDEB3 #x8AF4 +#x8FDEB4 #x8AF5 +#x8FDEB5 #x8AF6 +#x8FDEB6 #x8AFC +#x8FDEB7 #x8AFF +#x8FDEB8 #x8B05 +#x8FDEB9 #x8B06 +#x8FDEBA #x8B0B +#x8FDEBB #x8B11 +#x8FDEBC #x8B1C +#x8FDEBD #x8B1E +#x8FDEBE #x8B1F +#x8FDEBF #x8B0A +#x8FDEC0 #x8B2D +#x8FDEC1 #x8B30 +#x8FDEC2 #x8B37 +#x8FDEC3 #x8B3C +#x8FDEC4 #x8B42 +#x8FDEC5 #x8B43 +#x8FDEC6 #x8B44 +#x8FDEC7 #x8B45 +#x8FDEC8 #x8B46 +#x8FDEC9 #x8B48 +#x8FDECA #x8B52 +#x8FDECB #x8B53 +#x8FDECC #x8B54 +#x8FDECD #x8B59 +#x8FDECE #x8B4D +#x8FDECF #x8B5E +#x8FDED0 #x8B63 +#x8FDED1 #x8B6D +#x8FDED2 #x8B76 +#x8FDED3 #x8B78 +#x8FDED4 #x8B79 +#x8FDED5 #x8B7C +#x8FDED6 #x8B7E +#x8FDED7 #x8B81 +#x8FDED8 #x8B84 +#x8FDED9 #x8B85 +#x8FDEDA #x8B8B +#x8FDEDB #x8B8D +#x8FDEDC #x8B8F +#x8FDEDD #x8B94 +#x8FDEDE #x8B95 +#x8FDEDF #x8B9C +#x8FDEE0 #x8B9E +#x8FDEE1 #x8B9F +#x8FDEE2 #x8C38 +#x8FDEE3 #x8C39 +#x8FDEE4 #x8C3D +#x8FDEE5 #x8C3E +#x8FDEE6 #x8C45 +#x8FDEE7 #x8C47 +#x8FDEE8 #x8C49 +#x8FDEE9 #x8C4B +#x8FDEEA #x8C4F +#x8FDEEB #x8C51 +#x8FDEEC #x8C53 +#x8FDEED #x8C54 +#x8FDEEE #x8C57 +#x8FDEEF #x8C58 +#x8FDEF0 #x8C5B +#x8FDEF1 #x8C5D +#x8FDEF2 #x8C59 +#x8FDEF3 #x8C63 +#x8FDEF4 #x8C64 +#x8FDEF5 #x8C66 +#x8FDEF6 #x8C68 +#x8FDEF7 #x8C69 +#x8FDEF8 #x8C6D +#x8FDEF9 #x8C73 +#x8FDEFA #x8C75 +#x8FDEFB #x8C76 +#x8FDEFC #x8C7B +#x8FDEFD #x8C7E +#x8FDEFE #x8C86 +#x8FDFA1 #x8C87 +#x8FDFA2 #x8C8B +#x8FDFA3 #x8C90 +#x8FDFA4 #x8C92 +#x8FDFA5 #x8C93 +#x8FDFA6 #x8C99 +#x8FDFA7 #x8C9B +#x8FDFA8 #x8C9C +#x8FDFA9 #x8CA4 +#x8FDFAA #x8CB9 +#x8FDFAB #x8CBA +#x8FDFAC #x8CC5 +#x8FDFAD #x8CC6 +#x8FDFAE #x8CC9 +#x8FDFAF #x8CCB +#x8FDFB0 #x8CCF +#x8FDFB1 #x8CD6 +#x8FDFB2 #x8CD5 +#x8FDFB3 #x8CD9 +#x8FDFB4 #x8CDD +#x8FDFB5 #x8CE1 +#x8FDFB6 #x8CE8 +#x8FDFB7 #x8CEC +#x8FDFB8 #x8CEF +#x8FDFB9 #x8CF0 +#x8FDFBA #x8CF2 +#x8FDFBB #x8CF5 +#x8FDFBC #x8CF7 +#x8FDFBD #x8CF8 +#x8FDFBE #x8CFE +#x8FDFBF #x8CFF +#x8FDFC0 #x8D01 +#x8FDFC1 #x8D03 +#x8FDFC2 #x8D09 +#x8FDFC3 #x8D12 +#x8FDFC4 #x8D17 +#x8FDFC5 #x8D1B +#x8FDFC6 #x8D65 +#x8FDFC7 #x8D69 +#x8FDFC8 #x8D6C +#x8FDFC9 #x8D6E +#x8FDFCA #x8D7F +#x8FDFCB #x8D82 +#x8FDFCC #x8D84 +#x8FDFCD #x8D88 +#x8FDFCE #x8D8D +#x8FDFCF #x8D90 +#x8FDFD0 #x8D91 +#x8FDFD1 #x8D95 +#x8FDFD2 #x8D9E +#x8FDFD3 #x8D9F +#x8FDFD4 #x8DA0 +#x8FDFD5 #x8DA6 +#x8FDFD6 #x8DAB +#x8FDFD7 #x8DAC +#x8FDFD8 #x8DAF +#x8FDFD9 #x8DB2 +#x8FDFDA #x8DB5 +#x8FDFDB #x8DB7 +#x8FDFDC #x8DB9 +#x8FDFDD #x8DBB +#x8FDFDE #x8DC0 +#x8FDFDF #x8DC5 +#x8FDFE0 #x8DC6 +#x8FDFE1 #x8DC7 +#x8FDFE2 #x8DC8 +#x8FDFE3 #x8DCA +#x8FDFE4 #x8DCE +#x8FDFE5 #x8DD1 +#x8FDFE6 #x8DD4 +#x8FDFE7 #x8DD5 +#x8FDFE8 #x8DD7 +#x8FDFE9 #x8DD9 +#x8FDFEA #x8DE4 +#x8FDFEB #x8DE5 +#x8FDFEC #x8DE7 +#x8FDFED #x8DEC +#x8FDFEE #x8DF0 +#x8FDFEF #x8DBC +#x8FDFF0 #x8DF1 +#x8FDFF1 #x8DF2 +#x8FDFF2 #x8DF4 +#x8FDFF3 #x8DFD +#x8FDFF4 #x8E01 +#x8FDFF5 #x8E04 +#x8FDFF6 #x8E05 +#x8FDFF7 #x8E06 +#x8FDFF8 #x8E0B +#x8FDFF9 #x8E11 +#x8FDFFA #x8E14 +#x8FDFFB #x8E16 +#x8FDFFC #x8E20 +#x8FDFFD #x8E21 +#x8FDFFE #x8E22 +#x8FE0A1 #x8E23 +#x8FE0A2 #x8E26 +#x8FE0A3 #x8E27 +#x8FE0A4 #x8E31 +#x8FE0A5 #x8E33 +#x8FE0A6 #x8E36 +#x8FE0A7 #x8E37 +#x8FE0A8 #x8E38 +#x8FE0A9 #x8E39 +#x8FE0AA #x8E3D +#x8FE0AB #x8E40 +#x8FE0AC #x8E41 +#x8FE0AD #x8E4B +#x8FE0AE #x8E4D +#x8FE0AF #x8E4E +#x8FE0B0 #x8E4F +#x8FE0B1 #x8E54 +#x8FE0B2 #x8E5B +#x8FE0B3 #x8E5C +#x8FE0B4 #x8E5D +#x8FE0B5 #x8E5E +#x8FE0B6 #x8E61 +#x8FE0B7 #x8E62 +#x8FE0B8 #x8E69 +#x8FE0B9 #x8E6C +#x8FE0BA #x8E6D +#x8FE0BB #x8E6F +#x8FE0BC #x8E70 +#x8FE0BD #x8E71 +#x8FE0BE #x8E79 +#x8FE0BF #x8E7A +#x8FE0C0 #x8E7B +#x8FE0C1 #x8E82 +#x8FE0C2 #x8E83 +#x8FE0C3 #x8E89 +#x8FE0C4 #x8E90 +#x8FE0C5 #x8E92 +#x8FE0C6 #x8E95 +#x8FE0C7 #x8E9A +#x8FE0C8 #x8E9B +#x8FE0C9 #x8E9D +#x8FE0CA #x8E9E +#x8FE0CB #x8EA2 +#x8FE0CC #x8EA7 +#x8FE0CD #x8EA9 +#x8FE0CE #x8EAD +#x8FE0CF #x8EAE +#x8FE0D0 #x8EB3 +#x8FE0D1 #x8EB5 +#x8FE0D2 #x8EBA +#x8FE0D3 #x8EBB +#x8FE0D4 #x8EC0 +#x8FE0D5 #x8EC1 +#x8FE0D6 #x8EC3 +#x8FE0D7 #x8EC4 +#x8FE0D8 #x8EC7 +#x8FE0D9 #x8ECF +#x8FE0DA #x8ED1 +#x8FE0DB #x8ED4 +#x8FE0DC #x8EDC +#x8FE0DD #x8EE8 +#x8FE0DE #x8EEE +#x8FE0DF #x8EF0 +#x8FE0E0 #x8EF1 +#x8FE0E1 #x8EF7 +#x8FE0E2 #x8EF9 +#x8FE0E3 #x8EFA +#x8FE0E4 #x8EED +#x8FE0E5 #x8F00 +#x8FE0E6 #x8F02 +#x8FE0E7 #x8F07 +#x8FE0E8 #x8F08 +#x8FE0E9 #x8F0F +#x8FE0EA #x8F10 +#x8FE0EB #x8F16 +#x8FE0EC #x8F17 +#x8FE0ED #x8F18 +#x8FE0EE #x8F1E +#x8FE0EF #x8F20 +#x8FE0F0 #x8F21 +#x8FE0F1 #x8F23 +#x8FE0F2 #x8F25 +#x8FE0F3 #x8F27 +#x8FE0F4 #x8F28 +#x8FE0F5 #x8F2C +#x8FE0F6 #x8F2D +#x8FE0F7 #x8F2E +#x8FE0F8 #x8F34 +#x8FE0F9 #x8F35 +#x8FE0FA #x8F36 +#x8FE0FB #x8F37 +#x8FE0FC #x8F3A +#x8FE0FD #x8F40 +#x8FE0FE #x8F41 +#x8FE1A1 #x8F43 +#x8FE1A2 #x8F47 +#x8FE1A3 #x8F4F +#x8FE1A4 #x8F51 +#x8FE1A5 #x8F52 +#x8FE1A6 #x8F53 +#x8FE1A7 #x8F54 +#x8FE1A8 #x8F55 +#x8FE1A9 #x8F58 +#x8FE1AA #x8F5D +#x8FE1AB #x8F5E +#x8FE1AC #x8F65 +#x8FE1AD #x8F9D +#x8FE1AE #x8FA0 +#x8FE1AF #x8FA1 +#x8FE1B0 #x8FA4 +#x8FE1B1 #x8FA5 +#x8FE1B2 #x8FA6 +#x8FE1B3 #x8FB5 +#x8FE1B4 #x8FB6 +#x8FE1B5 #x8FB8 +#x8FE1B6 #x8FBE +#x8FE1B7 #x8FC0 +#x8FE1B8 #x8FC1 +#x8FE1B9 #x8FC6 +#x8FE1BA #x8FCA +#x8FE1BB #x8FCB +#x8FE1BC #x8FCD +#x8FE1BD #x8FD0 +#x8FE1BE #x8FD2 +#x8FE1BF #x8FD3 +#x8FE1C0 #x8FD5 +#x8FE1C1 #x8FE0 +#x8FE1C2 #x8FE3 +#x8FE1C3 #x8FE4 +#x8FE1C4 #x8FE8 +#x8FE1C5 #x8FEE +#x8FE1C6 #x8FF1 +#x8FE1C7 #x8FF5 +#x8FE1C8 #x8FF6 +#x8FE1C9 #x8FFB +#x8FE1CA #x8FFE +#x8FE1CB #x9002 +#x8FE1CC #x9004 +#x8FE1CD #x9008 +#x8FE1CE #x900C +#x8FE1CF #x9018 +#x8FE1D0 #x901B +#x8FE1D1 #x9028 +#x8FE1D2 #x9029 +#x8FE1D3 #x902F +#x8FE1D4 #x902A +#x8FE1D5 #x902C +#x8FE1D6 #x902D +#x8FE1D7 #x9033 +#x8FE1D8 #x9034 +#x8FE1D9 #x9037 +#x8FE1DA #x903F +#x8FE1DB #x9043 +#x8FE1DC #x9044 +#x8FE1DD #x904C +#x8FE1DE #x905B +#x8FE1DF #x905D +#x8FE1E0 #x9062 +#x8FE1E1 #x9066 +#x8FE1E2 #x9067 +#x8FE1E3 #x906C +#x8FE1E4 #x9070 +#x8FE1E5 #x9074 +#x8FE1E6 #x9079 +#x8FE1E7 #x9085 +#x8FE1E8 #x9088 +#x8FE1E9 #x908B +#x8FE1EA #x908C +#x8FE1EB #x908E +#x8FE1EC #x9090 +#x8FE1ED #x9095 +#x8FE1EE #x9097 +#x8FE1EF #x9098 +#x8FE1F0 #x9099 +#x8FE1F1 #x909B +#x8FE1F2 #x90A0 +#x8FE1F3 #x90A1 +#x8FE1F4 #x90A2 +#x8FE1F5 #x90A5 +#x8FE1F6 #x90B0 +#x8FE1F7 #x90B2 +#x8FE1F8 #x90B3 +#x8FE1F9 #x90B4 +#x8FE1FA #x90B6 +#x8FE1FB #x90BD +#x8FE1FC #x90CC +#x8FE1FD #x90BE +#x8FE1FE #x90C3 +#x8FE2A1 #x90C4 +#x8FE2A2 #x90C5 +#x8FE2A3 #x90C7 +#x8FE2A4 #x90C8 +#x8FE2A5 #x90D5 +#x8FE2A6 #x90D7 +#x8FE2A7 #x90D8 +#x8FE2A8 #x90D9 +#x8FE2A9 #x90DC +#x8FE2AA #x90DD +#x8FE2AB #x90DF +#x8FE2AC #x90E5 +#x8FE2AD #x90D2 +#x8FE2AE #x90F6 +#x8FE2AF #x90EB +#x8FE2B0 #x90EF +#x8FE2B1 #x90F0 +#x8FE2B2 #x90F4 +#x8FE2B3 #x90FE +#x8FE2B4 #x90FF +#x8FE2B5 #x9100 +#x8FE2B6 #x9104 +#x8FE2B7 #x9105 +#x8FE2B8 #x9106 +#x8FE2B9 #x9108 +#x8FE2BA #x910D +#x8FE2BB #x9110 +#x8FE2BC #x9114 +#x8FE2BD #x9116 +#x8FE2BE #x9117 +#x8FE2BF #x9118 +#x8FE2C0 #x911A +#x8FE2C1 #x911C +#x8FE2C2 #x911E +#x8FE2C3 #x9120 +#x8FE2C4 #x9125 +#x8FE2C5 #x9122 +#x8FE2C6 #x9123 +#x8FE2C7 #x9127 +#x8FE2C8 #x9129 +#x8FE2C9 #x912E +#x8FE2CA #x912F +#x8FE2CB #x9131 +#x8FE2CC #x9134 +#x8FE2CD #x9136 +#x8FE2CE #x9137 +#x8FE2CF #x9139 +#x8FE2D0 #x913A +#x8FE2D1 #x913C +#x8FE2D2 #x913D +#x8FE2D3 #x9143 +#x8FE2D4 #x9147 +#x8FE2D5 #x9148 +#x8FE2D6 #x914F +#x8FE2D7 #x9153 +#x8FE2D8 #x9157 +#x8FE2D9 #x9159 +#x8FE2DA #x915A +#x8FE2DB #x915B +#x8FE2DC #x9161 +#x8FE2DD #x9164 +#x8FE2DE #x9167 +#x8FE2DF #x916D +#x8FE2E0 #x9174 +#x8FE2E1 #x9179 +#x8FE2E2 #x917A +#x8FE2E3 #x917B +#x8FE2E4 #x9181 +#x8FE2E5 #x9183 +#x8FE2E6 #x9185 +#x8FE2E7 #x9186 +#x8FE2E8 #x918A +#x8FE2E9 #x918E +#x8FE2EA #x9191 +#x8FE2EB #x9193 +#x8FE2EC #x9194 +#x8FE2ED #x9195 +#x8FE2EE #x9198 +#x8FE2EF #x919E +#x8FE2F0 #x91A1 +#x8FE2F1 #x91A6 +#x8FE2F2 #x91A8 +#x8FE2F3 #x91AC +#x8FE2F4 #x91AD +#x8FE2F5 #x91AE +#x8FE2F6 #x91B0 +#x8FE2F7 #x91B1 +#x8FE2F8 #x91B2 +#x8FE2F9 #x91B3 +#x8FE2FA #x91B6 +#x8FE2FB #x91BB +#x8FE2FC #x91BC +#x8FE2FD #x91BD +#x8FE2FE #x91BF +#x8FE3A1 #x91C2 +#x8FE3A2 #x91C3 +#x8FE3A3 #x91C5 +#x8FE3A4 #x91D3 +#x8FE3A5 #x91D4 +#x8FE3A6 #x91D7 +#x8FE3A7 #x91D9 +#x8FE3A8 #x91DA +#x8FE3A9 #x91DE +#x8FE3AA #x91E4 +#x8FE3AB #x91E5 +#x8FE3AC #x91E9 +#x8FE3AD #x91EA +#x8FE3AE #x91EC +#x8FE3AF #x91ED +#x8FE3B0 #x91EE +#x8FE3B1 #x91EF +#x8FE3B2 #x91F0 +#x8FE3B3 #x91F1 +#x8FE3B4 #x91F7 +#x8FE3B5 #x91F9 +#x8FE3B6 #x91FB +#x8FE3B7 #x91FD +#x8FE3B8 #x9200 +#x8FE3B9 #x9201 +#x8FE3BA #x9204 +#x8FE3BB #x9205 +#x8FE3BC #x9206 +#x8FE3BD #x9207 +#x8FE3BE #x9209 +#x8FE3BF #x920A +#x8FE3C0 #x920C +#x8FE3C1 #x9210 +#x8FE3C2 #x9212 +#x8FE3C3 #x9213 +#x8FE3C4 #x9216 +#x8FE3C5 #x9218 +#x8FE3C6 #x921C +#x8FE3C7 #x921D +#x8FE3C8 #x9223 +#x8FE3C9 #x9224 +#x8FE3CA #x9225 +#x8FE3CB #x9226 +#x8FE3CC #x9228 +#x8FE3CD #x922E +#x8FE3CE #x922F +#x8FE3CF #x9230 +#x8FE3D0 #x9233 +#x8FE3D1 #x9235 +#x8FE3D2 #x9236 +#x8FE3D3 #x9238 +#x8FE3D4 #x9239 +#x8FE3D5 #x923A +#x8FE3D6 #x923C +#x8FE3D7 #x923E +#x8FE3D8 #x9240 +#x8FE3D9 #x9242 +#x8FE3DA #x9243 +#x8FE3DB #x9246 +#x8FE3DC #x9247 +#x8FE3DD #x924A +#x8FE3DE #x924D +#x8FE3DF #x924E +#x8FE3E0 #x924F +#x8FE3E1 #x9251 +#x8FE3E2 #x9258 +#x8FE3E3 #x9259 +#x8FE3E4 #x925C +#x8FE3E5 #x925D +#x8FE3E6 #x9260 +#x8FE3E7 #x9261 +#x8FE3E8 #x9265 +#x8FE3E9 #x9267 +#x8FE3EA #x9268 +#x8FE3EB #x9269 +#x8FE3EC #x926E +#x8FE3ED #x926F +#x8FE3EE #x9270 +#x8FE3EF #x9275 +#x8FE3F0 #x9276 +#x8FE3F1 #x9277 +#x8FE3F2 #x9278 +#x8FE3F3 #x9279 +#x8FE3F4 #x927B +#x8FE3F5 #x927C +#x8FE3F6 #x927D +#x8FE3F7 #x927F +#x8FE3F8 #x9288 +#x8FE3F9 #x9289 +#x8FE3FA #x928A +#x8FE3FB #x928D +#x8FE3FC #x928E +#x8FE3FD #x9292 +#x8FE3FE #x9297 +#x8FE4A1 #x9299 +#x8FE4A2 #x929F +#x8FE4A3 #x92A0 +#x8FE4A4 #x92A4 +#x8FE4A5 #x92A5 +#x8FE4A6 #x92A7 +#x8FE4A7 #x92A8 +#x8FE4A8 #x92AB +#x8FE4A9 #x92AF +#x8FE4AA #x92B2 +#x8FE4AB #x92B6 +#x8FE4AC #x92B8 +#x8FE4AD #x92BA +#x8FE4AE #x92BB +#x8FE4AF #x92BC +#x8FE4B0 #x92BD +#x8FE4B1 #x92BF +#x8FE4B2 #x92C0 +#x8FE4B3 #x92C1 +#x8FE4B4 #x92C2 +#x8FE4B5 #x92C3 +#x8FE4B6 #x92C5 +#x8FE4B7 #x92C6 +#x8FE4B8 #x92C7 +#x8FE4B9 #x92C8 +#x8FE4BA #x92CB +#x8FE4BB #x92CC +#x8FE4BC #x92CD +#x8FE4BD #x92CE +#x8FE4BE #x92D0 +#x8FE4BF #x92D3 +#x8FE4C0 #x92D5 +#x8FE4C1 #x92D7 +#x8FE4C2 #x92D8 +#x8FE4C3 #x92D9 +#x8FE4C4 #x92DC +#x8FE4C5 #x92DD +#x8FE4C6 #x92DF +#x8FE4C7 #x92E0 +#x8FE4C8 #x92E1 +#x8FE4C9 #x92E3 +#x8FE4CA #x92E5 +#x8FE4CB #x92E7 +#x8FE4CC #x92E8 +#x8FE4CD #x92EC +#x8FE4CE #x92EE +#x8FE4CF #x92F0 +#x8FE4D0 #x92F9 +#x8FE4D1 #x92FB +#x8FE4D2 #x92FF +#x8FE4D3 #x9300 +#x8FE4D4 #x9302 +#x8FE4D5 #x9308 +#x8FE4D6 #x930D +#x8FE4D7 #x9311 +#x8FE4D8 #x9314 +#x8FE4D9 #x9315 +#x8FE4DA #x931C +#x8FE4DB #x931D +#x8FE4DC #x931E +#x8FE4DD #x931F +#x8FE4DE #x9321 +#x8FE4DF #x9324 +#x8FE4E0 #x9325 +#x8FE4E1 #x9327 +#x8FE4E2 #x9329 +#x8FE4E3 #x932A +#x8FE4E4 #x9333 +#x8FE4E5 #x9334 +#x8FE4E6 #x9336 +#x8FE4E7 #x9337 +#x8FE4E8 #x9347 +#x8FE4E9 #x9348 +#x8FE4EA #x9349 +#x8FE4EB #x9350 +#x8FE4EC #x9351 +#x8FE4ED #x9352 +#x8FE4EE #x9355 +#x8FE4EF #x9357 +#x8FE4F0 #x9358 +#x8FE4F1 #x935A +#x8FE4F2 #x935E +#x8FE4F3 #x9364 +#x8FE4F4 #x9365 +#x8FE4F5 #x9367 +#x8FE4F6 #x9369 +#x8FE4F7 #x936A +#x8FE4F8 #x936D +#x8FE4F9 #x936F +#x8FE4FA #x9370 +#x8FE4FB #x9371 +#x8FE4FC #x9373 +#x8FE4FD #x9374 +#x8FE4FE #x9376 +#x8FE5A1 #x937A +#x8FE5A2 #x937D +#x8FE5A3 #x937F +#x8FE5A4 #x9380 +#x8FE5A5 #x9381 +#x8FE5A6 #x9382 +#x8FE5A7 #x9388 +#x8FE5A8 #x938A +#x8FE5A9 #x938B +#x8FE5AA #x938D +#x8FE5AB #x938F +#x8FE5AC #x9392 +#x8FE5AD #x9395 +#x8FE5AE #x9398 +#x8FE5AF #x939B +#x8FE5B0 #x939E +#x8FE5B1 #x93A1 +#x8FE5B2 #x93A3 +#x8FE5B3 #x93A4 +#x8FE5B4 #x93A6 +#x8FE5B5 #x93A8 +#x8FE5B6 #x93AB +#x8FE5B7 #x93B4 +#x8FE5B8 #x93B5 +#x8FE5B9 #x93B6 +#x8FE5BA #x93BA +#x8FE5BB #x93A9 +#x8FE5BC #x93C1 +#x8FE5BD #x93C4 +#x8FE5BE #x93C5 +#x8FE5BF #x93C6 +#x8FE5C0 #x93C7 +#x8FE5C1 #x93C9 +#x8FE5C2 #x93CA +#x8FE5C3 #x93CB +#x8FE5C4 #x93CC +#x8FE5C5 #x93CD +#x8FE5C6 #x93D3 +#x8FE5C7 #x93D9 +#x8FE5C8 #x93DC +#x8FE5C9 #x93DE +#x8FE5CA #x93DF +#x8FE5CB #x93E2 +#x8FE5CC #x93E6 +#x8FE5CD #x93E7 +#x8FE5CE #x93F9 +#x8FE5CF #x93F7 +#x8FE5D0 #x93F8 +#x8FE5D1 #x93FA +#x8FE5D2 #x93FB +#x8FE5D3 #x93FD +#x8FE5D4 #x9401 +#x8FE5D5 #x9402 +#x8FE5D6 #x9404 +#x8FE5D7 #x9408 +#x8FE5D8 #x9409 +#x8FE5D9 #x940D +#x8FE5DA #x940E +#x8FE5DB #x940F +#x8FE5DC #x9415 +#x8FE5DD #x9416 +#x8FE5DE #x9417 +#x8FE5DF #x941F +#x8FE5E0 #x942E +#x8FE5E1 #x942F +#x8FE5E2 #x9431 +#x8FE5E3 #x9432 +#x8FE5E4 #x9433 +#x8FE5E5 #x9434 +#x8FE5E6 #x943B +#x8FE5E7 #x943F +#x8FE5E8 #x943D +#x8FE5E9 #x9443 +#x8FE5EA #x9445 +#x8FE5EB #x9448 +#x8FE5EC #x944A +#x8FE5ED #x944C +#x8FE5EE #x9455 +#x8FE5EF #x9459 +#x8FE5F0 #x945C +#x8FE5F1 #x945F +#x8FE5F2 #x9461 +#x8FE5F3 #x9463 +#x8FE5F4 #x9468 +#x8FE5F5 #x946B +#x8FE5F6 #x946D +#x8FE5F7 #x946E +#x8FE5F8 #x946F +#x8FE5F9 #x9471 +#x8FE5FA #x9472 +#x8FE5FB #x9484 +#x8FE5FC #x9483 +#x8FE5FD #x9578 +#x8FE5FE #x9579 +#x8FE6A1 #x957E +#x8FE6A2 #x9584 +#x8FE6A3 #x9588 +#x8FE6A4 #x958C +#x8FE6A5 #x958D +#x8FE6A6 #x958E +#x8FE6A7 #x959D +#x8FE6A8 #x959E +#x8FE6A9 #x959F +#x8FE6AA #x95A1 +#x8FE6AB #x95A6 +#x8FE6AC #x95A9 +#x8FE6AD #x95AB +#x8FE6AE #x95AC +#x8FE6AF #x95B4 +#x8FE6B0 #x95B6 +#x8FE6B1 #x95BA +#x8FE6B2 #x95BD +#x8FE6B3 #x95BF +#x8FE6B4 #x95C6 +#x8FE6B5 #x95C8 +#x8FE6B6 #x95C9 +#x8FE6B7 #x95CB +#x8FE6B8 #x95D0 +#x8FE6B9 #x95D1 +#x8FE6BA #x95D2 +#x8FE6BB #x95D3 +#x8FE6BC #x95D9 +#x8FE6BD #x95DA +#x8FE6BE #x95DD +#x8FE6BF #x95DE +#x8FE6C0 #x95DF +#x8FE6C1 #x95E0 +#x8FE6C2 #x95E4 +#x8FE6C3 #x95E6 +#x8FE6C4 #x961D +#x8FE6C5 #x961E +#x8FE6C6 #x9622 +#x8FE6C7 #x9624 +#x8FE6C8 #x9625 +#x8FE6C9 #x9626 +#x8FE6CA #x962C +#x8FE6CB #x9631 +#x8FE6CC #x9633 +#x8FE6CD #x9637 +#x8FE6CE #x9638 +#x8FE6CF #x9639 +#x8FE6D0 #x963A +#x8FE6D1 #x963C +#x8FE6D2 #x963D +#x8FE6D3 #x9641 +#x8FE6D4 #x9652 +#x8FE6D5 #x9654 +#x8FE6D6 #x9656 +#x8FE6D7 #x9657 +#x8FE6D8 #x9658 +#x8FE6D9 #x9661 +#x8FE6DA #x966E +#x8FE6DB #x9674 +#x8FE6DC #x967B +#x8FE6DD #x967C +#x8FE6DE #x967E +#x8FE6DF #x967F +#x8FE6E0 #x9681 +#x8FE6E1 #x9682 +#x8FE6E2 #x9683 +#x8FE6E3 #x9684 +#x8FE6E4 #x9689 +#x8FE6E5 #x9691 +#x8FE6E6 #x9696 +#x8FE6E7 #x969A +#x8FE6E8 #x969D +#x8FE6E9 #x969F +#x8FE6EA #x96A4 +#x8FE6EB #x96A5 +#x8FE6EC #x96A6 +#x8FE6ED #x96A9 +#x8FE6EE #x96AE +#x8FE6EF #x96AF +#x8FE6F0 #x96B3 +#x8FE6F1 #x96BA +#x8FE6F2 #x96CA +#x8FE6F3 #x96D2 +#x8FE6F4 #x5DB2 +#x8FE6F5 #x96D8 +#x8FE6F6 #x96DA +#x8FE6F7 #x96DD +#x8FE6F8 #x96DE +#x8FE6F9 #x96DF +#x8FE6FA #x96E9 +#x8FE6FB #x96EF +#x8FE6FC #x96F1 +#x8FE6FD #x96FA +#x8FE6FE #x9702 +#x8FE7A1 #x9703 +#x8FE7A2 #x9705 +#x8FE7A3 #x9709 +#x8FE7A4 #x971A +#x8FE7A5 #x971B +#x8FE7A6 #x971D +#x8FE7A7 #x9721 +#x8FE7A8 #x9722 +#x8FE7A9 #x9723 +#x8FE7AA #x9728 +#x8FE7AB #x9731 +#x8FE7AC #x9733 +#x8FE7AD #x9741 +#x8FE7AE #x9743 +#x8FE7AF #x974A +#x8FE7B0 #x974E +#x8FE7B1 #x974F +#x8FE7B2 #x9755 +#x8FE7B3 #x9757 +#x8FE7B4 #x9758 +#x8FE7B5 #x975A +#x8FE7B6 #x975B +#x8FE7B7 #x9763 +#x8FE7B8 #x9767 +#x8FE7B9 #x976A +#x8FE7BA #x976E +#x8FE7BB #x9773 +#x8FE7BC #x9776 +#x8FE7BD #x9777 +#x8FE7BE #x9778 +#x8FE7BF #x977B +#x8FE7C0 #x977D +#x8FE7C1 #x977F +#x8FE7C2 #x9780 +#x8FE7C3 #x9789 +#x8FE7C4 #x9795 +#x8FE7C5 #x9796 +#x8FE7C6 #x9797 +#x8FE7C7 #x9799 +#x8FE7C8 #x979A +#x8FE7C9 #x979E +#x8FE7CA #x979F +#x8FE7CB #x97A2 +#x8FE7CC #x97AC +#x8FE7CD #x97AE +#x8FE7CE #x97B1 +#x8FE7CF #x97B2 +#x8FE7D0 #x97B5 +#x8FE7D1 #x97B6 +#x8FE7D2 #x97B8 +#x8FE7D3 #x97B9 +#x8FE7D4 #x97BA +#x8FE7D5 #x97BC +#x8FE7D6 #x97BE +#x8FE7D7 #x97BF +#x8FE7D8 #x97C1 +#x8FE7D9 #x97C4 +#x8FE7DA #x97C5 +#x8FE7DB #x97C7 +#x8FE7DC #x97C9 +#x8FE7DD #x97CA +#x8FE7DE #x97CC +#x8FE7DF #x97CD +#x8FE7E0 #x97CE +#x8FE7E1 #x97D0 +#x8FE7E2 #x97D1 +#x8FE7E3 #x97D4 +#x8FE7E4 #x97D7 +#x8FE7E5 #x97D8 +#x8FE7E6 #x97D9 +#x8FE7E7 #x97DD +#x8FE7E8 #x97DE +#x8FE7E9 #x97E0 +#x8FE7EA #x97DB +#x8FE7EB #x97E1 +#x8FE7EC #x97E4 +#x8FE7ED #x97EF +#x8FE7EE #x97F1 +#x8FE7EF #x97F4 +#x8FE7F0 #x97F7 +#x8FE7F1 #x97F8 +#x8FE7F2 #x97FA +#x8FE7F3 #x9807 +#x8FE7F4 #x980A +#x8FE7F5 #x9819 +#x8FE7F6 #x980D +#x8FE7F7 #x980E +#x8FE7F8 #x9814 +#x8FE7F9 #x9816 +#x8FE7FA #x981C +#x8FE7FB #x981E +#x8FE7FC #x9820 +#x8FE7FD #x9823 +#x8FE7FE #x9826 +#x8FE8A1 #x982B +#x8FE8A2 #x982E +#x8FE8A3 #x982F +#x8FE8A4 #x9830 +#x8FE8A5 #x9832 +#x8FE8A6 #x9833 +#x8FE8A7 #x9835 +#x8FE8A8 #x9825 +#x8FE8A9 #x983E +#x8FE8AA #x9844 +#x8FE8AB #x9847 +#x8FE8AC #x984A +#x8FE8AD #x9851 +#x8FE8AE #x9852 +#x8FE8AF #x9853 +#x8FE8B0 #x9856 +#x8FE8B1 #x9857 +#x8FE8B2 #x9859 +#x8FE8B3 #x985A +#x8FE8B4 #x9862 +#x8FE8B5 #x9863 +#x8FE8B6 #x9865 +#x8FE8B7 #x9866 +#x8FE8B8 #x986A +#x8FE8B9 #x986C +#x8FE8BA #x98AB +#x8FE8BB #x98AD +#x8FE8BC #x98AE +#x8FE8BD #x98B0 +#x8FE8BE #x98B4 +#x8FE8BF #x98B7 +#x8FE8C0 #x98B8 +#x8FE8C1 #x98BA +#x8FE8C2 #x98BB +#x8FE8C3 #x98BF +#x8FE8C4 #x98C2 +#x8FE8C5 #x98C5 +#x8FE8C6 #x98C8 +#x8FE8C7 #x98CC +#x8FE8C8 #x98E1 +#x8FE8C9 #x98E3 +#x8FE8CA #x98E5 +#x8FE8CB #x98E6 +#x8FE8CC #x98E7 +#x8FE8CD #x98EA +#x8FE8CE #x98F3 +#x8FE8CF #x98F6 +#x8FE8D0 #x9902 +#x8FE8D1 #x9907 +#x8FE8D2 #x9908 +#x8FE8D3 #x9911 +#x8FE8D4 #x9915 +#x8FE8D5 #x9916 +#x8FE8D6 #x9917 +#x8FE8D7 #x991A +#x8FE8D8 #x991B +#x8FE8D9 #x991C +#x8FE8DA #x991F +#x8FE8DB #x9922 +#x8FE8DC #x9926 +#x8FE8DD #x9927 +#x8FE8DE #x992B +#x8FE8DF #x9931 +#x8FE8E0 #x9932 +#x8FE8E1 #x9933 +#x8FE8E2 #x9934 +#x8FE8E3 #x9935 +#x8FE8E4 #x9939 +#x8FE8E5 #x993A +#x8FE8E6 #x993B +#x8FE8E7 #x993C +#x8FE8E8 #x9940 +#x8FE8E9 #x9941 +#x8FE8EA #x9946 +#x8FE8EB #x9947 +#x8FE8EC #x9948 +#x8FE8ED #x994D +#x8FE8EE #x994E +#x8FE8EF #x9954 +#x8FE8F0 #x9958 +#x8FE8F1 #x9959 +#x8FE8F2 #x995B +#x8FE8F3 #x995C +#x8FE8F4 #x995E +#x8FE8F5 #x995F +#x8FE8F6 #x9960 +#x8FE8F7 #x999B +#x8FE8F8 #x999D +#x8FE8F9 #x999F +#x8FE8FA #x99A6 +#x8FE8FB #x99B0 +#x8FE8FC #x99B1 +#x8FE8FD #x99B2 +#x8FE8FE #x99B5 +#x8FE9A1 #x99B9 +#x8FE9A2 #x99BA +#x8FE9A3 #x99BD +#x8FE9A4 #x99BF +#x8FE9A5 #x99C3 +#x8FE9A6 #x99C9 +#x8FE9A7 #x99D3 +#x8FE9A8 #x99D4 +#x8FE9A9 #x99D9 +#x8FE9AA #x99DA +#x8FE9AB #x99DC +#x8FE9AC #x99DE +#x8FE9AD #x99E7 +#x8FE9AE #x99EA +#x8FE9AF #x99EB +#x8FE9B0 #x99EC +#x8FE9B1 #x99F0 +#x8FE9B2 #x99F4 +#x8FE9B3 #x99F5 +#x8FE9B4 #x99F9 +#x8FE9B5 #x99FD +#x8FE9B6 #x99FE +#x8FE9B7 #x9A02 +#x8FE9B8 #x9A03 +#x8FE9B9 #x9A04 +#x8FE9BA #x9A0B +#x8FE9BB #x9A0C +#x8FE9BC #x9A10 +#x8FE9BD #x9A11 +#x8FE9BE #x9A16 +#x8FE9BF #x9A1E +#x8FE9C0 #x9A20 +#x8FE9C1 #x9A22 +#x8FE9C2 #x9A23 +#x8FE9C3 #x9A24 +#x8FE9C4 #x9A27 +#x8FE9C5 #x9A2D +#x8FE9C6 #x9A2E +#x8FE9C7 #x9A33 +#x8FE9C8 #x9A35 +#x8FE9C9 #x9A36 +#x8FE9CA #x9A38 +#x8FE9CB #x9A47 +#x8FE9CC #x9A41 +#x8FE9CD #x9A44 +#x8FE9CE #x9A4A +#x8FE9CF #x9A4B +#x8FE9D0 #x9A4C +#x8FE9D1 #x9A4E +#x8FE9D2 #x9A51 +#x8FE9D3 #x9A54 +#x8FE9D4 #x9A56 +#x8FE9D5 #x9A5D +#x8FE9D6 #x9AAA +#x8FE9D7 #x9AAC +#x8FE9D8 #x9AAE +#x8FE9D9 #x9AAF +#x8FE9DA #x9AB2 +#x8FE9DB #x9AB4 +#x8FE9DC #x9AB5 +#x8FE9DD #x9AB6 +#x8FE9DE #x9AB9 +#x8FE9DF #x9ABB +#x8FE9E0 #x9ABE +#x8FE9E1 #x9ABF +#x8FE9E2 #x9AC1 +#x8FE9E3 #x9AC3 +#x8FE9E4 #x9AC6 +#x8FE9E5 #x9AC8 +#x8FE9E6 #x9ACE +#x8FE9E7 #x9AD0 +#x8FE9E8 #x9AD2 +#x8FE9E9 #x9AD5 +#x8FE9EA #x9AD6 +#x8FE9EB #x9AD7 +#x8FE9EC #x9ADB +#x8FE9ED #x9ADC +#x8FE9EE #x9AE0 +#x8FE9EF #x9AE4 +#x8FE9F0 #x9AE5 +#x8FE9F1 #x9AE7 +#x8FE9F2 #x9AE9 +#x8FE9F3 #x9AEC +#x8FE9F4 #x9AF2 +#x8FE9F5 #x9AF3 +#x8FE9F6 #x9AF5 +#x8FE9F7 #x9AF9 +#x8FE9F8 #x9AFA +#x8FE9F9 #x9AFD +#x8FE9FA #x9AFF +#x8FE9FB #x9B00 +#x8FE9FC #x9B01 +#x8FE9FD #x9B02 +#x8FE9FE #x9B03 +#x8FEAA1 #x9B04 +#x8FEAA2 #x9B05 +#x8FEAA3 #x9B08 +#x8FEAA4 #x9B09 +#x8FEAA5 #x9B0B +#x8FEAA6 #x9B0C +#x8FEAA7 #x9B0D +#x8FEAA8 #x9B0E +#x8FEAA9 #x9B10 +#x8FEAAA #x9B12 +#x8FEAAB #x9B16 +#x8FEAAC #x9B19 +#x8FEAAD #x9B1B +#x8FEAAE #x9B1C +#x8FEAAF #x9B20 +#x8FEAB0 #x9B26 +#x8FEAB1 #x9B2B +#x8FEAB2 #x9B2D +#x8FEAB3 #x9B33 +#x8FEAB4 #x9B34 +#x8FEAB5 #x9B35 +#x8FEAB6 #x9B37 +#x8FEAB7 #x9B39 +#x8FEAB8 #x9B3A +#x8FEAB9 #x9B3D +#x8FEABA #x9B48 +#x8FEABB #x9B4B +#x8FEABC #x9B4C +#x8FEABD #x9B55 +#x8FEABE #x9B56 +#x8FEABF #x9B57 +#x8FEAC0 #x9B5B +#x8FEAC1 #x9B5E +#x8FEAC2 #x9B61 +#x8FEAC3 #x9B63 +#x8FEAC4 #x9B65 +#x8FEAC5 #x9B66 +#x8FEAC6 #x9B68 +#x8FEAC7 #x9B6A +#x8FEAC8 #x9B6B +#x8FEAC9 #x9B6C +#x8FEACA #x9B6D +#x8FEACB #x9B6E +#x8FEACC #x9B73 +#x8FEACD #x9B75 +#x8FEACE #x9B77 +#x8FEACF #x9B78 +#x8FEAD0 #x9B79 +#x8FEAD1 #x9B7F +#x8FEAD2 #x9B80 +#x8FEAD3 #x9B84 +#x8FEAD4 #x9B85 +#x8FEAD5 #x9B86 +#x8FEAD6 #x9B87 +#x8FEAD7 #x9B89 +#x8FEAD8 #x9B8A +#x8FEAD9 #x9B8B +#x8FEADA #x9B8D +#x8FEADB #x9B8F +#x8FEADC #x9B90 +#x8FEADD #x9B94 +#x8FEADE #x9B9A +#x8FEADF #x9B9D +#x8FEAE0 #x9B9E +#x8FEAE1 #x9BA6 +#x8FEAE2 #x9BA7 +#x8FEAE3 #x9BA9 +#x8FEAE4 #x9BAC +#x8FEAE5 #x9BB0 +#x8FEAE6 #x9BB1 +#x8FEAE7 #x9BB2 +#x8FEAE8 #x9BB7 +#x8FEAE9 #x9BB8 +#x8FEAEA #x9BBB +#x8FEAEB #x9BBC +#x8FEAEC #x9BBE +#x8FEAED #x9BBF +#x8FEAEE #x9BC1 +#x8FEAEF #x9BC7 +#x8FEAF0 #x9BC8 +#x8FEAF1 #x9BCE +#x8FEAF2 #x9BD0 +#x8FEAF3 #x9BD7 +#x8FEAF4 #x9BD8 +#x8FEAF5 #x9BDD +#x8FEAF6 #x9BDF +#x8FEAF7 #x9BE5 +#x8FEAF8 #x9BE7 +#x8FEAF9 #x9BEA +#x8FEAFA #x9BEB +#x8FEAFB #x9BEF +#x8FEAFC #x9BF3 +#x8FEAFD #x9BF7 +#x8FEAFE #x9BF8 +#x8FEBA1 #x9BF9 +#x8FEBA2 #x9BFA +#x8FEBA3 #x9BFD +#x8FEBA4 #x9BFF +#x8FEBA5 #x9C00 +#x8FEBA6 #x9C02 +#x8FEBA7 #x9C0B +#x8FEBA8 #x9C0F +#x8FEBA9 #x9C11 +#x8FEBAA #x9C16 +#x8FEBAB #x9C18 +#x8FEBAC #x9C19 +#x8FEBAD #x9C1A +#x8FEBAE #x9C1C +#x8FEBAF #x9C1E +#x8FEBB0 #x9C22 +#x8FEBB1 #x9C23 +#x8FEBB2 #x9C26 +#x8FEBB3 #x9C27 +#x8FEBB4 #x9C28 +#x8FEBB5 #x9C29 +#x8FEBB6 #x9C2A +#x8FEBB7 #x9C31 +#x8FEBB8 #x9C35 +#x8FEBB9 #x9C36 +#x8FEBBA #x9C37 +#x8FEBBB #x9C3D +#x8FEBBC #x9C41 +#x8FEBBD #x9C43 +#x8FEBBE #x9C44 +#x8FEBBF #x9C45 +#x8FEBC0 #x9C49 +#x8FEBC1 #x9C4A +#x8FEBC2 #x9C4E +#x8FEBC3 #x9C4F +#x8FEBC4 #x9C50 +#x8FEBC5 #x9C53 +#x8FEBC6 #x9C54 +#x8FEBC7 #x9C56 +#x8FEBC8 #x9C58 +#x8FEBC9 #x9C5B +#x8FEBCA #x9C5D +#x8FEBCB #x9C5E +#x8FEBCC #x9C5F +#x8FEBCD #x9C63 +#x8FEBCE #x9C69 +#x8FEBCF #x9C6A +#x8FEBD0 #x9C5C +#x8FEBD1 #x9C6B +#x8FEBD2 #x9C68 +#x8FEBD3 #x9C6E +#x8FEBD4 #x9C70 +#x8FEBD5 #x9C72 +#x8FEBD6 #x9C75 +#x8FEBD7 #x9C77 +#x8FEBD8 #x9C7B +#x8FEBD9 #x9CE6 +#x8FEBDA #x9CF2 +#x8FEBDB #x9CF7 +#x8FEBDC #x9CF9 +#x8FEBDD #x9D0B +#x8FEBDE #x9D02 +#x8FEBDF #x9D11 +#x8FEBE0 #x9D17 +#x8FEBE1 #x9D18 +#x8FEBE2 #x9D1C +#x8FEBE3 #x9D1D +#x8FEBE4 #x9D1E +#x8FEBE5 #x9D2F +#x8FEBE6 #x9D30 +#x8FEBE7 #x9D32 +#x8FEBE8 #x9D33 +#x8FEBE9 #x9D34 +#x8FEBEA #x9D3A +#x8FEBEB #x9D3C +#x8FEBEC #x9D45 +#x8FEBED #x9D3D +#x8FEBEE #x9D42 +#x8FEBEF #x9D43 +#x8FEBF0 #x9D47 +#x8FEBF1 #x9D4A +#x8FEBF2 #x9D53 +#x8FEBF3 #x9D54 +#x8FEBF4 #x9D5F +#x8FEBF5 #x9D63 +#x8FEBF6 #x9D62 +#x8FEBF7 #x9D65 +#x8FEBF8 #x9D69 +#x8FEBF9 #x9D6A +#x8FEBFA #x9D6B +#x8FEBFB #x9D70 +#x8FEBFC #x9D76 +#x8FEBFD #x9D77 +#x8FEBFE #x9D7B +#x8FECA1 #x9D7C +#x8FECA2 #x9D7E +#x8FECA3 #x9D83 +#x8FECA4 #x9D84 +#x8FECA5 #x9D86 +#x8FECA6 #x9D8A +#x8FECA7 #x9D8D +#x8FECA8 #x9D8E +#x8FECA9 #x9D92 +#x8FECAA #x9D93 +#x8FECAB #x9D95 +#x8FECAC #x9D96 +#x8FECAD #x9D97 +#x8FECAE #x9D98 +#x8FECAF #x9DA1 +#x8FECB0 #x9DAA +#x8FECB1 #x9DAC +#x8FECB2 #x9DAE +#x8FECB3 #x9DB1 +#x8FECB4 #x9DB5 +#x8FECB5 #x9DB9 +#x8FECB6 #x9DBC +#x8FECB7 #x9DBF +#x8FECB8 #x9DC3 +#x8FECB9 #x9DC7 +#x8FECBA #x9DC9 +#x8FECBB #x9DCA +#x8FECBC #x9DD4 +#x8FECBD #x9DD5 +#x8FECBE #x9DD6 +#x8FECBF #x9DD7 +#x8FECC0 #x9DDA +#x8FECC1 #x9DDE +#x8FECC2 #x9DDF +#x8FECC3 #x9DE0 +#x8FECC4 #x9DE5 +#x8FECC5 #x9DE7 +#x8FECC6 #x9DE9 +#x8FECC7 #x9DEB +#x8FECC8 #x9DEE +#x8FECC9 #x9DF0 +#x8FECCA #x9DF3 +#x8FECCB #x9DF4 +#x8FECCC #x9DFE +#x8FECCD #x9E0A +#x8FECCE #x9E02 +#x8FECCF #x9E07 +#x8FECD0 #x9E0E +#x8FECD1 #x9E10 +#x8FECD2 #x9E11 +#x8FECD3 #x9E12 +#x8FECD4 #x9E15 +#x8FECD5 #x9E16 +#x8FECD6 #x9E19 +#x8FECD7 #x9E1C +#x8FECD8 #x9E1D +#x8FECD9 #x9E7A +#x8FECDA #x9E7B +#x8FECDB #x9E7C +#x8FECDC #x9E80 +#x8FECDD #x9E82 +#x8FECDE #x9E83 +#x8FECDF #x9E84 +#x8FECE0 #x9E85 +#x8FECE1 #x9E87 +#x8FECE2 #x9E8E +#x8FECE3 #x9E8F +#x8FECE4 #x9E96 +#x8FECE5 #x9E98 +#x8FECE6 #x9E9B +#x8FECE7 #x9E9E +#x8FECE8 #x9EA4 +#x8FECE9 #x9EA8 +#x8FECEA #x9EAC +#x8FECEB #x9EAE +#x8FECEC #x9EAF +#x8FECED #x9EB0 +#x8FECEE #x9EB3 +#x8FECEF #x9EB4 +#x8FECF0 #x9EB5 +#x8FECF1 #x9EC6 +#x8FECF2 #x9EC8 +#x8FECF3 #x9ECB +#x8FECF4 #x9ED5 +#x8FECF5 #x9EDF +#x8FECF6 #x9EE4 +#x8FECF7 #x9EE7 +#x8FECF8 #x9EEC +#x8FECF9 #x9EED +#x8FECFA #x9EEE +#x8FECFB #x9EF0 +#x8FECFC #x9EF1 +#x8FECFD #x9EF2 +#x8FECFE #x9EF5 +#x8FEDA1 #x9EF8 +#x8FEDA2 #x9EFF +#x8FEDA3 #x9F02 +#x8FEDA4 #x9F03 +#x8FEDA5 #x9F09 +#x8FEDA6 #x9F0F +#x8FEDA7 #x9F10 +#x8FEDA8 #x9F11 +#x8FEDA9 #x9F12 +#x8FEDAA #x9F14 +#x8FEDAB #x9F16 +#x8FEDAC #x9F17 +#x8FEDAD #x9F19 +#x8FEDAE #x9F1A +#x8FEDAF #x9F1B +#x8FEDB0 #x9F1F +#x8FEDB1 #x9F22 +#x8FEDB2 #x9F26 +#x8FEDB3 #x9F2A +#x8FEDB4 #x9F2B +#x8FEDB5 #x9F2F +#x8FEDB6 #x9F31 +#x8FEDB7 #x9F32 +#x8FEDB8 #x9F34 +#x8FEDB9 #x9F37 +#x8FEDBA #x9F39 +#x8FEDBB #x9F3A +#x8FEDBC #x9F3C +#x8FEDBD #x9F3D +#x8FEDBE #x9F3F +#x8FEDBF #x9F41 +#x8FEDC0 #x9F43 +#x8FEDC1 #x9F44 +#x8FEDC2 #x9F45 +#x8FEDC3 #x9F46 +#x8FEDC4 #x9F47 +#x8FEDC5 #x9F53 +#x8FEDC6 #x9F55 +#x8FEDC7 #x9F56 +#x8FEDC8 #x9F57 +#x8FEDC9 #x9F58 +#x8FEDCA #x9F5A +#x8FEDCB #x9F5D +#x8FEDCC #x9F5E +#x8FEDCD #x9F68 +#x8FEDCE #x9F69 +#x8FEDCF #x9F6D +#x8FEDD0 #x9F6E +#x8FEDD1 #x9F6F +#x8FEDD2 #x9F70 +#x8FEDD3 #x9F71 +#x8FEDD4 #x9F73 +#x8FEDD5 #x9F75 +#x8FEDD6 #x9F7A +#x8FEDD7 #x9F7D +#x8FEDD8 #x9F8F +#x8FEDD9 #x9F90 +#x8FEDDA #x9F91 +#x8FEDDB #x9F92 +#x8FEDDC #x9F94 +#x8FEDDD #x9F96 +#x8FEDDE #x9F97 +#x8FEDDF #x9F9E +#x8FEDE0 #x9FA1 +#x8FEDE1 #x9FA2 +#x8FEDE2 #x9FA3 +#x8FEDE3 #x9FA5 diff --git a/tests/eucjp.impure.lisp b/tests/eucjp.impure.lisp index f4d90ed..d80e52a 100644 --- a/tests/eucjp.impure.lisp +++ b/tests/eucjp.impure.lisp @@ -8,57 +8,57 @@ ;; generate test data (with-open-file (in "eucjp-test.lisp-expr" :direction :input) (with-open-file (out-eucjp eucjp :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede) + :element-type '(unsigned-byte 8) + :if-exists :supersede) (with-open-file (out-utf8 utf8 :direction :output - :external-format :utf-8 - :if-exists :supersede) - (do ((euc (read in nil) (read in nil)) - (ucs (read in nil) (read in nil)) - (i 0 (1+ i))) - ((or (null euc) (null ucs))) - ;; write EUC-JP data as binary - (let ((out out-eucjp)) - (when (>= euc #x10000) - (write-byte (ldb (byte 8 16) euc) out)) - (when (>= euc #x100) - (write-byte (ldb (byte 8 8) euc) out)) - (write-byte (ldb (byte 8 0) euc) out) - (when (= (mod i 32) 31) - (write-byte #x0a out))) - ;; trust UTF-8 external format - (let ((out out-utf8)) - (write-char (code-char ucs) out) - (when (= (mod i 32) 31) - (write-char (code-char #x0a) out))))))) + :external-format :utf-8 + :if-exists :supersede) + (do ((euc (read in nil) (read in nil)) + (ucs (read in nil) (read in nil)) + (i 0 (1+ i))) + ((or (null euc) (null ucs))) + ;; write EUC-JP data as binary + (let ((out out-eucjp)) + (when (>= euc #x10000) + (write-byte (ldb (byte 8 16) euc) out)) + (when (>= euc #x100) + (write-byte (ldb (byte 8 8) euc) out)) + (write-byte (ldb (byte 8 0) euc) out) + (when (= (mod i 32) 31) + (write-byte #x0a out))) + ;; trust UTF-8 external format + (let ((out out-utf8)) + (write-char (code-char ucs) out) + (when (= (mod i 32) 31) + (write-char (code-char #x0a) out))))))) ;; check if input works (with-open-file (in1 eucjp :direction :input - :external-format :euc-jp) + :external-format :euc-jp) (with-open-file (in2 utf8 :direction :input - :external-format :utf-8) + :external-format :utf-8) (do ((c1 (read-char in1 nil) (read-char in1 nil)) - (c2 (read-char in2 nil) (read-char in2 nil))) - ((and (null c1) (null c2))) - (assert (eql c1 c2))))) + (c2 (read-char in2 nil) (read-char in2 nil))) + ((and (null c1) (null c2))) + (assert (eql c1 c2))))) ;; check if output works (with-open-file (in utf8 :direction :input - :external-format :utf-8) + :external-format :utf-8) (with-open-file (out p :direction :output - :external-format :euc-jp - :if-exists :supersede) + :external-format :euc-jp + :if-exists :supersede) (do ((c (read-char in nil) (read-char in nil))) - ((null c)) - (write-char c out)))) + ((null c)) + (write-char c out)))) (with-open-file (in1 eucjp :direction :input - :element-type '(unsigned-byte 8)) + :element-type '(unsigned-byte 8)) (with-open-file (in2 p :direction :input - :element-type '(unsigned-byte 8)) + :element-type '(unsigned-byte 8)) (do ((b1 (read-byte in1 nil) (read-byte in1 nil)) - (b2 (read-byte in2 nil) (read-byte in2 nil))) - ((and (null b1) (null b2))) - (assert (eql b1 b2))))) + (b2 (read-byte in2 nil) (read-byte in2 nil))) + ((and (null b1) (null b2))) + (assert (eql b1 b2))))) (delete-file p) (delete-file eucjp) (delete-file utf8)) @@ -70,18 +70,18 @@ (i 0 (1+ i))) ((or (null euc) (null ucs))) (let ((o (coerce (cond ((>= euc #x10000) - (list (ldb (byte 8 16) euc) - (ldb (byte 8 8) euc) - (ldb (byte 8 0) euc))) - ((>= euc #x100) - (list (ldb (byte 8 8) euc) - (ldb (byte 8 0) euc))) - (t (list euc))) - '(vector (unsigned-byte 8)))) - (s (string (code-char ucs)))) + (list (ldb (byte 8 16) euc) + (ldb (byte 8 8) euc) + (ldb (byte 8 0) euc))) + ((>= euc #x100) + (list (ldb (byte 8 8) euc) + (ldb (byte 8 0) euc))) + (t (list euc))) + '(vector (unsigned-byte 8)))) + (s (string (code-char ucs)))) (assert (equal (octets-to-string o :external-format :euc-jp) s)) (assert (equal (coerce (string-to-octets s :external-format :euc-jp) - 'list) - (coerce o 'list)))))) + 'list) + (coerce o 'list)))))) ;;; success (sb-ext:quit :unix-status 104) diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp index 6b22474..a7f44b7 100644 --- a/tests/eval.impure.lisp +++ b/tests/eval.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -133,8 +133,8 @@ ;;; No extra output, please (assert (equal ".." - (with-output-to-string (*standard-output*) - (eval '(progn (princ ".") (let ((x 42)) t) (princ ".")))))) + (with-output-to-string (*standard-output*) + (eval '(progn (princ ".") (let ((x 42)) t) (princ ".")))))) ;;; success (sb-ext:quit :unix-status 104) diff --git a/tests/exhaust.impure.lisp b/tests/exhaust.impure.lisp index bc4dd7b..4a91fca 100644 --- a/tests/exhaust.impure.lisp +++ b/tests/exhaust.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -23,8 +23,8 @@ ;;; and works at all optimization settings. However, it now signals a ;;; STORAGE-CONDITION instead of an ERROR. -(defun recurse () - (recurse) +(defun recurse () + (recurse) (recurse)) (defvar *count* 100) @@ -33,7 +33,7 @@ (assert (eq :exhausted (handler-case (recurse) - (storage-condition (c) + (storage-condition (c) (declare (ignore c)) :exhausted)))) diff --git a/tests/external-format.impure.lisp b/tests/external-format.impure.lisp index d1a5d38..d4e9cbd 100644 --- a/tests/external-format.impure.lisp +++ b/tests/external-format.impure.lisp @@ -10,7 +10,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -22,7 +22,7 @@ (let ((nxf (gensym))) `(dolist (,nxf sb-impl::*external-formats* ,result) (let ((,xf (first (first ,nxf)))) - ,@body)))) + ,@body)))) (do-external-formats (xf) (with-open-file (s "/dev/null" :direction :input :external-format xf) @@ -32,13 +32,13 @@ (let ((standard-characters "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!$\"'(),_-./:;?+<=>#%&*@[\\]{|}`^~")) (do-external-formats (xf) (with-open-file (s "external-format-test.txt" :direction :output - :if-exists :supersede :external-format xf) + :if-exists :supersede :external-format xf) (loop for character across standard-characters - do (write-char character s))) + do (write-char character s))) (with-open-file (s "external-format-test.txt" :direction :input - :external-format xf) + :external-format xf) (loop for character across standard-characters - do (assert (eql (read-char s) character)))))) + do (assert (eql (read-char s) character)))))) ;;; Test UTF-8 writing and reading of 1, 2, 3 and 4 octet characters with ;;; all possible offsets. Tests for buffer edge bugs. fd-stream buffers are @@ -47,92 +47,92 @@ (let ((character (code-char (elt '(1 #x81 #x801 #x10001) width-1)))) (dotimes (offset (+ width-1 1)) (with-open-file (s "external-format-test.txt" :direction :output - :if-exists :supersede :external-format :utf-8) - (dotimes (n offset) - (write-char #\a s)) - (dotimes (n 4097) - (write-char character s))) + :if-exists :supersede :external-format :utf-8) + (dotimes (n offset) + (write-char #\a s)) + (dotimes (n 4097) + (write-char character s))) (with-open-file (s "external-format-test.txt" :direction :input - :external-format :utf-8) - (dotimes (n offset) - (assert (eql (read-char s) #\a))) - (dotimes (n 4097) - (assert (eql (read-char s) character))) - (assert (eql (read-char s nil s) s)))))) + :external-format :utf-8) + (dotimes (n offset) + (assert (eql (read-char s) #\a))) + (dotimes (n 4097) + (assert (eql (read-char s) character))) + (assert (eql (read-char s nil s) s)))))) ;;; Test character decode restarts. (with-open-file (s "external-format-test.txt" :direction :output - :if-exists :supersede :element-type '(unsigned-byte 8)) + :if-exists :supersede :element-type '(unsigned-byte 8)) (write-byte 65 s) (write-byte 66 s) (write-byte #xe0 s) (write-byte 67 s)) (with-open-file (s "external-format-test.txt" :direction :input - :external-format :utf-8) + :external-format :utf-8) (handler-bind ((sb-int:character-decoding-error #'(lambda (decoding-error) - (declare (ignore decoding-error)) - (invoke-restart - 'sb-int:attempt-resync)))) + (declare (ignore decoding-error)) + (invoke-restart + 'sb-int:attempt-resync)))) (assert (equal (read-line s nil s) "ABC")) (assert (equal (read-line s nil s) s)))) (with-open-file (s "external-format-test.txt" :direction :input - :external-format :utf-8) + :external-format :utf-8) (handler-bind ((sb-int:character-decoding-error #'(lambda (decoding-error) - (declare (ignore decoding-error)) - (invoke-restart - 'sb-int:force-end-of-file)))) + (declare (ignore decoding-error)) + (invoke-restart + 'sb-int:force-end-of-file)))) (assert (equal (read-line s nil s) "AB")) (assert (equal (read-line s nil s) s)))) ;;; Test character encode restarts. (with-open-file (s "external-format-test.txt" :direction :output - :if-exists :supersede :external-format :latin-1) + :if-exists :supersede :external-format :latin-1) (handler-bind ((sb-int:character-encoding-error #'(lambda (encoding-error) - (declare (ignore encoding-error)) - (invoke-restart - 'sb-impl::output-nothing)))) + (declare (ignore encoding-error)) + (invoke-restart + 'sb-impl::output-nothing)))) (write-char #\A s) (write-char #\B s) (write-char (code-char 322) s) (write-char #\C s))) (with-open-file (s "external-format-test.txt" :direction :input - :external-format :latin-1) + :external-format :latin-1) (assert (equal (read-line s nil s) "ABC")) (assert (equal (read-line s nil s) s))) (with-open-file (s "external-format-test.txt" :direction :output - :if-exists :supersede :external-format :latin-1) + :if-exists :supersede :external-format :latin-1) (handler-bind ((sb-int:character-encoding-error #'(lambda (encoding-error) - (declare (ignore encoding-error)) - (invoke-restart - 'sb-impl::output-nothing)))) + (declare (ignore encoding-error)) + (invoke-restart + 'sb-impl::output-nothing)))) (let ((string (make-array 4 :element-type 'character - :initial-contents `(#\A #\B ,(code-char 322) - #\C)))) + :initial-contents `(#\A #\B ,(code-char 322) + #\C)))) (write-string string s)))) (with-open-file (s "external-format-test.txt" :direction :input - :external-format :latin-1) + :external-format :latin-1) (assert (equal (read-line s nil s) "ABC")) (assert (equal (read-line s nil s) s))) ;;; Test skipping character-decode-errors in comments. (let ((s (open "external-format-test.lisp" :direction :output - :if-exists :supersede :external-format :latin-1))) + :if-exists :supersede :external-format :latin-1))) (unwind-protect (progn - (write-string ";;; ABCD" s) - (write-char (code-char 233) s) - (terpri s) - (close s) - (compile-file "external-format-test.lisp" :external-format :utf-8)) + (write-string ";;; ABCD" s) + (write-char (code-char 233) s) + (terpri s) + (close s) + (compile-file "external-format-test.lisp" :external-format :utf-8)) (delete-file s) (let ((p (probe-file (compile-file-pathname "external-format-test.lisp")))) (when p - (delete-file p))))) + (delete-file p))))) (delete-file "external-format-test.txt") diff --git a/tests/filesys.pure.lisp b/tests/filesys.pure.lisp index 3e7ab3d..cdac2f3 100644 --- a/tests/filesys.pure.lisp +++ b/tests/filesys.pure.lisp @@ -4,7 +4,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -12,17 +12,17 @@ (in-package "CL-USER") ;;; In sbcl-0.6.9 FOO-NAMESTRING functions returned "" instead of NIL. -(let ((pathname0 (make-pathname :host nil - :directory - (pathname-directory - *default-pathname-defaults*) - :name "getty")) - (pathname1 (make-pathname :host nil - :directory nil - :name nil))) +(let ((pathname0 (make-pathname :host nil + :directory + (pathname-directory + *default-pathname-defaults*) + :name "getty")) + (pathname1 (make-pathname :host nil + :directory nil + :name nil))) (assert (equal (file-namestring pathname0) "getty")) (assert (equal (directory-namestring pathname0) - (directory-namestring *default-pathname-defaults*))) + (directory-namestring *default-pathname-defaults*))) (assert (equal (file-namestring pathname1) "")) (assert (equal (directory-namestring pathname1) ""))) @@ -32,9 +32,9 @@ ;; We know a little bit about the structure of this result; ;; let's test to make sure that this test file is in it. (assert (find-if (lambda (pathname) - (search "tests/filesys.pure.lisp" - (namestring pathname))) - dir))) + (search "tests/filesys.pure.lisp" + (namestring pathname))) + dir))) ;;; Set *default-pathname-defaults* to something other than the unix ;;; cwd, to catch functions which access the filesystem without @@ -43,9 +43,9 @@ (let ((*default-pathname-defaults* (make-pathname :directory - (butlast - (pathname-directory *default-pathname-defaults*)) - :defaults *default-pathname-defaults*))) + (butlast + (pathname-directory *default-pathname-defaults*)) + :defaults *default-pathname-defaults*))) ;; SBCL 0.7.1.2 failed to merge on OPEN (with-open-file (i "tests/filesys.pure.lisp") (assert i))) @@ -54,19 +54,19 @@ ;;; if they are fed wild pathname designators; firstly, with wild ;;; pathnames that don't correspond to any files: (assert (typep (nth-value 1 (ignore-errors (open "non-existent*.lisp"))) - 'file-error)) + 'file-error)) (assert (typep (nth-value 1 (ignore-errors (load "non-existent*.lisp"))) - 'file-error)) + 'file-error)) ;;; then for pathnames that correspond to precisely one: (assert (typep (nth-value 1 (ignore-errors (open "filesys.pur*.lisp"))) - 'file-error)) + 'file-error)) (assert (typep (nth-value 1 (ignore-errors (load "filesys.pur*.lisp"))) - 'file-error)) + 'file-error)) ;;; then for pathnames corresponding to many: (assert (typep (nth-value 1 (ignore-errors (open "*.lisp"))) - 'file-error)) + 'file-error)) (assert (typep (nth-value 1 (ignore-errors (load "*.lisp"))) - 'file-error)) + 'file-error)) ;;; ANSI: FILE-LENGTH should signal an error of type TYPE-ERROR if ;;; STREAM is not a stream associated with a file. @@ -74,4 +74,4 @@ ;;; (Peter Van Eynde's ansi-test suite caught this, and Eric Marsden ;;; reported a fix for CMU CL, which was ported to sbcl-0.6.12.35.) (assert (typep (nth-value 1 (ignore-errors (file-length *terminal-io*))) - 'type-error)) + 'type-error)) diff --git a/tests/float.impure.lisp b/tests/float.impure.lisp index 518a122..2af31bf 100644 --- a/tests/float.impure.lisp +++ b/tests/float.impure.lisp @@ -7,7 +7,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -24,7 +24,7 @@ ;;; e.g. someone inadvertently ports the bad code. (defun point39 (x y) (make-array 2 - :element-type 'double-float + :element-type 'double-float :initial-contents (list x y))) (declaim (inline point39-x point39-y)) @@ -36,23 +36,23 @@ (aref p 1)) (defun order39 (points) (sort points (lambda (p1 p2) - (let* ((y1 (point39-y p1)) - (y2 (point39-y p2))) - (if (= y1 y2) - (< (point39-x p1) - (point39-x p2)) - (< y1 y2)))))) + (let* ((y1 (point39-y p1)) + (y2 (point39-y p2))) + (if (= y1 y2) + (< (point39-x p1) + (point39-x p2)) + (< y1 y2)))))) (defun test39 () (order39 (make-array 4 - :initial-contents (list (point39 0.0d0 0.0d0) - (point39 1.0d0 1.0d0) - (point39 2.0d0 2.0d0) - (point39 3.0d0 3.0d0))))) + :initial-contents (list (point39 0.0d0 0.0d0) + (point39 1.0d0 1.0d0) + (point39 2.0d0 2.0d0) + (point39 3.0d0 3.0d0))))) (assert (equalp (test39) - #(#(0.0d0 0.0d0) - #(1.0d0 1.0d0) - #(2.0d0 2.0d0) - #(3.0d0 3.0d0)))) + #(#(0.0d0 0.0d0) + #(1.0d0 1.0d0) + #(2.0d0 2.0d0) + #(3.0d0 3.0d0)))) (defun complex-double-float-ppc (x y) (declare (type (complex double-float) x y)) diff --git a/tests/float.pure.lisp b/tests/float.pure.lisp index 03b3cf9..1d38c03 100644 --- a/tests/float.pure.lisp +++ b/tests/float.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -14,9 +14,9 @@ (cl:in-package :cl-user) (dolist (ifnis (list (cons single-float-positive-infinity - single-float-negative-infinity) - (cons double-float-positive-infinity - double-float-negative-infinity))) + single-float-negative-infinity) + (cons double-float-positive-infinity + double-float-negative-infinity))) (destructuring-bind (+ifni . -ifni) ifnis (assert (= (* +ifni 1) +ifni)) (assert (= (* +ifni -0.1) -ifni)) @@ -47,7 +47,7 @@ ;;; (Peter Van Eynde's ansi-test suite caught this, and Eric Marsden ;;; reported a fix for CMU CL, which was ported to sbcl-0.6.12.35.) (assert (typep (nth-value 1 (ignore-errors (float-radix "notfloat"))) - 'type-error)) + 'type-error)) (assert (typep (nth-value 1 (ignore-errors (funcall (fdefinition 'float-radix) "notfloat"))) @@ -82,21 +82,21 @@ ;;; bug found by Peter Seibel: scale-float was only accepting float ;;; exponents, when it should accept all integers. (also bug #269) (assert (= (multiple-value-bind (significand expt sign) - (integer-decode-float least-positive-double-float) - (* (scale-float (float significand 0.0d0) expt) sign)) - least-positive-double-float)) + (integer-decode-float least-positive-double-float) + (* (scale-float (float significand 0.0d0) expt) sign)) + least-positive-double-float)) (assert (= (multiple-value-bind (significand expt sign) - (decode-float least-positive-double-float) - (* (scale-float significand expt) sign)) - least-positive-double-float)) + (decode-float least-positive-double-float) + (* (scale-float significand expt) sign)) + least-positive-double-float)) (assert (= 0.0 (scale-float 1.0 most-negative-fixnum))) (assert (= 0.0d0 (scale-float 1.0d0 (1- most-negative-fixnum)))) #-(or darwin) ;; bug 372 (progn (assert (raises-error? (scale-float 1.0 most-positive-fixnum) - floating-point-overflow)) + floating-point-overflow)) (assert (raises-error? (scale-float 1.0d0 (1+ most-positive-fixnum)) - floating-point-overflow))) + floating-point-overflow))) ;;; bug found by jsnell when nfroyd tried to implement better LOGAND ;;; type derivation. diff --git a/tests/gcd.pure.lisp b/tests/gcd.pure.lisp index ae66887..08bc34b 100644 --- a/tests/gcd.pure.lisp +++ b/tests/gcd.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -20,22 +20,22 @@ (defun random-factor (n) (let ((accum 1)) (dotimes (i n accum) - (setf accum (* accum (nth (random 20) - '(2 2 2 3 3 - 5 7 11 13 17 - 19 23 29 31 37 - 41 43 47 53 59))))))) - + (setf accum (* accum (nth (random 20) + '(2 2 2 3 3 + 5 7 11 13 17 + 19 23 29 31 37 + 41 43 47 53 59))))))) + (with-open-file (s "tests/gcd.impure.lisp" - :direction :output :if-exists :supersede) + :direction :output :if-exists :supersede) (dotimes (i 40) (dotimes (j (ceiling i 2)) - (let ((x (random-factor i)) - (y (random-factor j))) - (format s "~&~S~%" `(assert (= (gcd ,x ,y) ,(gcd x y))))))))) + (let ((x (random-factor i)) + (y (random-factor j))) + (format s "~&~S~%" `(assert (= (gcd ,x ,y) ,(gcd x y))))))))) ;;; run from a different lisp implementation. As such, if you get a ;;; failure, check (by hand!) who is right. -- CSR, 2004-08-10 - + (ASSERT (= (GCD 3 1) 1)) (ASSERT (= (GCD 9 1) 1)) (ASSERT (= (GCD 1353 1) 1)) diff --git a/tests/gray-streams.impure.lisp b/tests/gray-streams.impure.lisp index 2fb58c9..0c36e79 100644 --- a/tests/gray-streams.impure.lisp +++ b/tests/gray-streams.impure.lisp @@ -1,4 +1,4 @@ -;;;; tests related to Gray streams +;;;; tests related to Gray streams ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -60,23 +60,23 @@ (defclass character-output-stream (fundamental-character-output-stream) ((lisp-stream :initarg :lisp-stream - :accessor character-output-stream-lisp-stream))) - + :accessor character-output-stream-lisp-stream))) + (defclass character-input-stream (fundamental-character-input-stream) ((lisp-stream :initarg :lisp-stream - :accessor character-input-stream-lisp-stream))) - + :accessor character-input-stream-lisp-stream))) + ;;;; example character output stream encapsulating a lisp-stream (defun make-character-output-stream (lisp-stream) (make-instance 'character-output-stream :lisp-stream lisp-stream)) - + (defmethod open-stream-p ((stream character-output-stream)) (open-stream-p (character-output-stream-lisp-stream stream))) - + (defmethod close ((stream character-output-stream) &key abort) (close (character-output-stream-lisp-stream stream) :abort abort)) - + (defmethod input-stream-p ((stream character-output-stream)) (input-stream-p (character-output-stream-lisp-stream stream))) @@ -176,10 +176,10 @@ ;;; bare Gray streams and thus bogusly omitting pretty-printing ;;; operations. (flet ((frob () - (with-output-to-string (string) - (let ((gray-output-stream (make-character-output-stream string))) - (format gray-output-stream - "~@~%"))))) + (with-output-to-string (string) + (let ((gray-output-stream (make-character-output-stream string))) + (format gray-output-stream + "~@~%"))))) (assert (= 1 (count #\newline (let ((*print-pretty* nil)) (frob))))) (assert (= 2 (count #\newline (let ((*print-pretty* t)) (frob)))))) @@ -220,11 +220,11 @@ (defclass binary-to-char-output-stream (fundamental-binary-output-stream) ((lisp-stream :initarg :lisp-stream - :accessor binary-to-char-output-stream-lisp-stream))) - + :accessor binary-to-char-output-stream-lisp-stream))) + (defclass binary-to-char-input-stream (fundamental-binary-input-stream) ((lisp-stream :initarg :lisp-stream - :accessor binary-to-char-input-stream-lisp-stream))) + :accessor binary-to-char-input-stream-lisp-stream))) (defmethod stream-element-type ((stream binary-to-char-output-stream)) '(unsigned-byte 8)) @@ -233,24 +233,24 @@ (defun make-binary-to-char-input-stream (lisp-stream) (make-instance 'binary-to-char-input-stream - :lisp-stream lisp-stream)) + :lisp-stream lisp-stream)) (defun make-binary-to-char-output-stream (lisp-stream) (make-instance 'binary-to-char-output-stream - :lisp-stream lisp-stream)) - + :lisp-stream lisp-stream)) + (defmethod stream-read-byte ((stream binary-to-char-input-stream)) (let ((char (read-char - (binary-to-char-input-stream-lisp-stream stream) nil :eof))) + (binary-to-char-input-stream-lisp-stream stream) nil :eof))) (if (eq char :eof) - char - (char-code char)))) + char + (char-code char)))) (defmethod stream-write-byte ((stream binary-to-char-output-stream) integer) (let ((char (code-char integer))) (write-char char - (binary-to-char-output-stream-lisp-stream stream)))) - + (binary-to-char-output-stream-lisp-stream stream)))) + ;;;; tests using binary i/o, using the above (let ((test-string (format nil @@ -260,9 +260,9 @@ (assert (equal (with-output-to-string (bar) (let ((our-bin-to-char-input (make-binary-to-char-input-stream - foo)) + foo)) (our-bin-to-char-output (make-binary-to-char-output-stream - bar))) + bar))) (assert (open-stream-p our-bin-to-char-input)) (assert (open-stream-p our-bin-to-char-output)) (assert (input-stream-p our-bin-to-char-input)) diff --git a/tests/hash.impure.lisp b/tests/hash.impure.lisp index dfbb9c4..9afa582 100644 --- a/tests/hash.impure.lisp +++ b/tests/hash.impure.lisp @@ -4,7 +4,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -25,158 +25,158 @@ (declare (notinline complex float coerce + - expt)) (flet ((make-sxhash-subtests () (list (cons 0 1) - (list 0 1) - (cons 1 0) - (cons (cons 1 0) (cons 0 0)) - (cons (list 1 0) (list 0 0)) - (list (cons 1 0) (list 0 0)) - (list (cons 0 1) (list 0 0)) - (list (cons 0 0) (cons 1 0)) - (list (cons 0 0) (cons 0 1)) + (list 0 1) + (cons 1 0) + (cons (cons 1 0) (cons 0 0)) + (cons (list 1 0) (list 0 0)) + (list (cons 1 0) (list 0 0)) + (list (cons 0 1) (list 0 0)) + (list (cons 0 0) (cons 1 0)) + (list (cons 0 0) (cons 0 1)) + + 44 (float 44) (coerce 44 'double-float) + -44 (float -44) (coerce -44 'double-float) + 0 (float 0) (coerce 0 'double-float) + -0 (- (float 0)) (- (coerce 0 'double-float)) + -121 (float -121) (coerce -121 'double-float) + 3/4 (float 3/4) (coerce 3/4 'double-float) + -3/4 (float -3/4) (coerce -3/4 'double-float) + 45 (float 45) (coerce 45 'double-float) + 441/10 (float 441/10) (coerce (float 441/10) 'double-float) + + (expt 2 33) (expt 2.0 33) (expt 2.0d0 33) + (- (expt 1/2 50)) (- (expt 0.5 50)) (- (expt 0.5d0 50)) + (+ (expt 1/2 50)) (+ (expt 0.5 50)) (+ (expt 0.5d0 50)) + + (complex 1.0 2.0) (complex 1.0d0 2.0) + (complex 1.5 -3/2) (complex 1.5 -1.5d0) + + #\x #\X #\* - 44 (float 44) (coerce 44 'double-float) - -44 (float -44) (coerce -44 'double-float) - 0 (float 0) (coerce 0 'double-float) - -0 (- (float 0)) (- (coerce 0 'double-float)) - -121 (float -121) (coerce -121 'double-float) - 3/4 (float 3/4) (coerce 3/4 'double-float) - -3/4 (float -3/4) (coerce -3/4 'double-float) - 45 (float 45) (coerce 45 'double-float) - 441/10 (float 441/10) (coerce (float 441/10) 'double-float) + (copy-seq "foo") (copy-seq "foobar") (copy-seq "foobarbaz") - (expt 2 33) (expt 2.0 33) (expt 2.0d0 33) - (- (expt 1/2 50)) (- (expt 0.5 50)) (- (expt 0.5d0 50)) - (+ (expt 1/2 50)) (+ (expt 0.5 50)) (+ (expt 0.5d0 50)) - - (complex 1.0 2.0) (complex 1.0d0 2.0) - (complex 1.5 -3/2) (complex 1.5 -1.5d0) - - #\x #\X #\* - - (copy-seq "foo") (copy-seq "foobar") (copy-seq "foobarbaz") + (copy-seq #*) + (copy-seq #*0) (copy-seq #*1) + (copy-seq #*00) (copy-seq #*10) + (copy-seq #*01) (copy-seq #*11) + (copy-seq #*10010) (copy-seq #*100101) (bit-not #*01101) + (make-array 6 :fill-pointer 6 + :element-type 'bit :initial-contents #*100101) - (copy-seq #*) - (copy-seq #*0) (copy-seq #*1) - (copy-seq #*00) (copy-seq #*10) - (copy-seq #*01) (copy-seq #*11) - (copy-seq #*10010) (copy-seq #*100101) (bit-not #*01101) - (make-array 6 :fill-pointer 6 - :element-type 'bit :initial-contents #*100101) - - #'allocate-instance #'no-applicable-method)) - (make-psxhash-extra-subtests () - (list (copy-seq "") - (copy-seq #*) - (copy-seq #()) - (copy-seq ()) - (copy-seq '(())) - (copy-seq #(())) - (copy-seq '(#())) - (make-array 3 :fill-pointer 0) - (make-array 7 :fill-pointer 0 :element-type 'bit) - (make-array 8 :fill-pointer 0 :element-type 'character) - (vector (cons 1 0) (cons 0 0)) - (vector (cons 0 1) (cons 0 0)) - (vector (cons 0 0) (cons 1 0)) - (vector (cons 0 0) (cons 0 1)) - (vector (cons 1 0) (cons 0 0)) - (vector (cons 0 1) (cons 0 0)) - (vector (list 0 0) (cons 1 0)) - (vector (list 0 0) (list 0 1)) - (vector (vector 1 0) (list 0 0)) - (vector (vector 0 1) (list 0 0)) - (vector (vector 0 0) (list 1 0)) - (vector (vector 0 0) (list 0 1)) - (vector #*00 #*10) - (vector (vector 0 0) (list 0 1.0d0)) - (vector (vector -0.0d0 0) (list 1.0 0)) - (vector 1 0 1 0) - (vector 0 0 0) - (copy-seq #*1010) - (copy-seq #*000) - (replace (make-array 101 - :element-type 'bit - :fill-pointer 4) - #*1010) - (replace (make-array 14 - :element-type '(unsigned-byte 8) - :fill-pointer 3) - #*000) - (replace (make-array 14 - :element-type t - :fill-pointer 3) - #*000) - (copy-seq "abc") - (copy-seq "ABC") - (copy-seq "aBc") - (copy-seq "abcc") - (copy-seq "1001") - 'abc - (vector #\a #\b #\c) - (vector 'a 'b 'c) - (vector "A" 'b 'c) - (replace (make-array 14 - :element-type 'character - :fill-pointer 3) - "aBc") - (replace (make-array 11 - :element-type 'character - :fill-pointer 4) - "1001") - (replace (make-array 12 - :element-type 'bit - :fill-pointer 4) - #*1001) - (replace (make-array 13 - :element-type t - :fill-pointer 4) - "1001") - (replace (make-array 13 - :element-type t - :fill-pointer 4) - #*1001) - ;; FIXME: What about multi-dimensional arrays, hmm? + #'allocate-instance #'no-applicable-method)) + (make-psxhash-extra-subtests () + (list (copy-seq "") + (copy-seq #*) + (copy-seq #()) + (copy-seq ()) + (copy-seq '(())) + (copy-seq #(())) + (copy-seq '(#())) + (make-array 3 :fill-pointer 0) + (make-array 7 :fill-pointer 0 :element-type 'bit) + (make-array 8 :fill-pointer 0 :element-type 'character) + (vector (cons 1 0) (cons 0 0)) + (vector (cons 0 1) (cons 0 0)) + (vector (cons 0 0) (cons 1 0)) + (vector (cons 0 0) (cons 0 1)) + (vector (cons 1 0) (cons 0 0)) + (vector (cons 0 1) (cons 0 0)) + (vector (list 0 0) (cons 1 0)) + (vector (list 0 0) (list 0 1)) + (vector (vector 1 0) (list 0 0)) + (vector (vector 0 1) (list 0 0)) + (vector (vector 0 0) (list 1 0)) + (vector (vector 0 0) (list 0 1)) + (vector #*00 #*10) + (vector (vector 0 0) (list 0 1.0d0)) + (vector (vector -0.0d0 0) (list 1.0 0)) + (vector 1 0 1 0) + (vector 0 0 0) + (copy-seq #*1010) + (copy-seq #*000) + (replace (make-array 101 + :element-type 'bit + :fill-pointer 4) + #*1010) + (replace (make-array 14 + :element-type '(unsigned-byte 8) + :fill-pointer 3) + #*000) + (replace (make-array 14 + :element-type t + :fill-pointer 3) + #*000) + (copy-seq "abc") + (copy-seq "ABC") + (copy-seq "aBc") + (copy-seq "abcc") + (copy-seq "1001") + 'abc + (vector #\a #\b #\c) + (vector 'a 'b 'c) + (vector "A" 'b 'c) + (replace (make-array 14 + :element-type 'character + :fill-pointer 3) + "aBc") + (replace (make-array 11 + :element-type 'character + :fill-pointer 4) + "1001") + (replace (make-array 12 + :element-type 'bit + :fill-pointer 4) + #*1001) + (replace (make-array 13 + :element-type t + :fill-pointer 4) + "1001") + (replace (make-array 13 + :element-type t + :fill-pointer 4) + #*1001) + ;; FIXME: What about multi-dimensional arrays, hmm? - (make-hash-table) - (make-hash-table :test 'equal) + (make-hash-table) + (make-hash-table :test 'equal) - (make-foo) - (make-bar) - (make-bar :x (list 1)) - (make-bar :y (list 1)))) - (t->boolean (x) (if x t nil))) + (make-foo) + (make-bar) + (make-bar :x (list 1)) + (make-bar :y (list 1)))) + (t->boolean (x) (if x t nil))) (let* (;; Note: - ;; * The APPEND noise here is to help more strenuously test - ;; not-EQ-but-EQUAL and not-EQ-but-EQUALP cases. - ;; * It seems not to be worth the hassle testing SXHASH on - ;; values whose structure isn't understood by EQUAL, since - ;; we get too many false positives "SXHASHes are equal even - ;; though values aren't EQUAL, what a crummy hash function!" - ;; FIXME: Or am I misunderstanding the intent of the - ;; the SXHASH specification? Perhaps SXHASH is supposed to - ;; descend into the structure of objects even when EQUAL - ;; doesn't, in order to avoid hashing together things which - ;; are guaranteed not to be EQUAL? The definition of SXHASH - ;; seems to leave this completely unspecified: should - ;; "well-distributed" depend on substructure that EQUAL - ;; ignores? For our internal hash tables, the stricter - ;; descend-into-the-structure behavior might improve - ;; performance even though it's not specified by ANSI. But - ;; is it reasonable for users to expect it? Hmm.. - (sxhash-tests (append (make-sxhash-subtests) - (make-sxhash-subtests))) - (psxhash-tests (append sxhash-tests - (make-psxhash-extra-subtests) - (make-psxhash-extra-subtests)))) + ;; * The APPEND noise here is to help more strenuously test + ;; not-EQ-but-EQUAL and not-EQ-but-EQUALP cases. + ;; * It seems not to be worth the hassle testing SXHASH on + ;; values whose structure isn't understood by EQUAL, since + ;; we get too many false positives "SXHASHes are equal even + ;; though values aren't EQUAL, what a crummy hash function!" + ;; FIXME: Or am I misunderstanding the intent of the + ;; the SXHASH specification? Perhaps SXHASH is supposed to + ;; descend into the structure of objects even when EQUAL + ;; doesn't, in order to avoid hashing together things which + ;; are guaranteed not to be EQUAL? The definition of SXHASH + ;; seems to leave this completely unspecified: should + ;; "well-distributed" depend on substructure that EQUAL + ;; ignores? For our internal hash tables, the stricter + ;; descend-into-the-structure behavior might improve + ;; performance even though it's not specified by ANSI. But + ;; is it reasonable for users to expect it? Hmm.. + (sxhash-tests (append (make-sxhash-subtests) + (make-sxhash-subtests))) + (psxhash-tests (append sxhash-tests + (make-psxhash-extra-subtests) + (make-psxhash-extra-subtests)))) ;; Check that SXHASH compiler transforms give the same results ;; as the out-of-line version of SXHASH. (let* ((fundef `(lambda () - (list ,@(mapcar (lambda (value) - `(sxhash ',value)) - sxhash-tests)))) - (fun (compile nil fundef))) - (assert (equal (funcall fun) - (mapcar #'sxhash sxhash-tests)))) + (list ,@(mapcar (lambda (value) + `(sxhash ',value)) + sxhash-tests)))) + (fun (compile nil fundef))) + (assert (equal (funcall fun) + (mapcar #'sxhash sxhash-tests)))) ;; Note: The tests for SXHASH-equality iff EQUAL and ;; PSXHASH-equality iff EQUALP could fail because of an unlucky ;; random collision. That's not very likely (since there are @@ -190,29 +190,29 @@ ;; that the SXHASH distribution changes, not once every time the ;; tests are run.) (dolist (i sxhash-tests) - (declare (notinline funcall)) - (unless (typep (funcall #'sxhash i) '(and fixnum unsigned-byte)) - (error "bad SXHASH behavior for ~S" i)) - (dolist (j sxhash-tests) - (unless (or (eq (t->boolean (equal i j)) - (t->boolean (= (sxhash i) (sxhash j)))) - (and (typep i 'number) - (typep j 'number) - (= i j) - (subtypep (type-of i) (type-of j)) - (subtypep (type-of j) (type-of i)))) - ;; (If you get a surprising failure here, maybe you were - ;; just very unlucky; see the notes above.) - (error "bad SXHASH behavior for ~S ~S" i j)))) + (declare (notinline funcall)) + (unless (typep (funcall #'sxhash i) '(and fixnum unsigned-byte)) + (error "bad SXHASH behavior for ~S" i)) + (dolist (j sxhash-tests) + (unless (or (eq (t->boolean (equal i j)) + (t->boolean (= (sxhash i) (sxhash j)))) + (and (typep i 'number) + (typep j 'number) + (= i j) + (subtypep (type-of i) (type-of j)) + (subtypep (type-of j) (type-of i)))) + ;; (If you get a surprising failure here, maybe you were + ;; just very unlucky; see the notes above.) + (error "bad SXHASH behavior for ~S ~S" i j)))) (dolist (i psxhash-tests) - (unless (typep (sb-int:psxhash i) '(and fixnum unsigned-byte)) - (error "bad PSXHASH behavior for ~S" i)) - (dolist (j psxhash-tests) - (unless (eq (t->boolean (equalp i j)) - (t->boolean (= (sb-int:psxhash i) (sb-int:psxhash j)))) - ;; (If you get a surprising failure here, maybe you were - ;; just very unlucky; see the notes above.) - (error "bad PSXHASH behavior for ~S ~S" i j)))) + (unless (typep (sb-int:psxhash i) '(and fixnum unsigned-byte)) + (error "bad PSXHASH behavior for ~S" i)) + (dolist (j psxhash-tests) + (unless (eq (t->boolean (equalp i j)) + (t->boolean (= (sb-int:psxhash i) (sb-int:psxhash j)))) + ;; (If you get a surprising failure here, maybe you were + ;; just very unlucky; see the notes above.) + (error "bad PSXHASH behavior for ~S ~S" i j)))) ))) ;;; As of sbcl-0.6.12.10, writing hash tables readably should work. @@ -225,24 +225,24 @@ (original-keys '(1 10 11 400030002 -100000000))) (dolist (key original-keys) (setf (gethash key original-ht) - (expt key 4))) + (expt key 4))) (let* ((written-ht (with-output-to-string (s) - (write original-ht :stream s :readably t))) - (read-ht (with-input-from-string (s written-ht) - (read s)))) + (write original-ht :stream s :readably t))) + (read-ht (with-input-from-string (s written-ht) + (read s)))) (assert (= (hash-table-count read-ht) - (hash-table-count original-ht) - (length original-keys))) + (hash-table-count original-ht) + (length original-keys))) (assert (eql (hash-table-test original-ht) (hash-table-test read-ht))) (assert (eql (hash-table-size original-ht) (hash-table-size read-ht))) (dolist (key original-keys) (assert (eql (gethash key read-ht) - (gethash key original-ht)))))) + (gethash key original-ht)))))) ;;; NIL is both SYMBOL and LIST (dolist (fun '(sxhash sb-impl::psxhash)) (assert (= (eval `(,fun nil)) - (funcall fun nil) + (funcall fun nil) (funcall (compile nil `(lambda (x) (declare (symbol x)) (,fun x))) @@ -252,7 +252,7 @@ (,fun x))) nil) (funcall (compile nil `(lambda (x) - (declare (null x)) + (declare (null x)) (,fun x))) nil)))) diff --git a/tests/info.before-xc.lisp b/tests/info.before-xc.lisp index 4d91bfb..9bdbfc2 100644 --- a/tests/info.before-xc.lisp +++ b/tests/info.before-xc.lisp @@ -8,7 +8,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -18,7 +18,7 @@ (/show "beginning tests/info.before-xc.lisp") (assert (eq (sb!int:info :variable :kind 'sb!vm:vector-data-offset) - :constant)) + :constant)) ;;; It's possible in general for a constant to have the value NIL, but ;;; not for vector-data-offset, which must be a number: (multiple-value-bind (value successp) diff --git a/tests/info.impure.lisp b/tests/info.impure.lisp index ffb3a06..db2eb2a 100644 --- a/tests/info.impure.lisp +++ b/tests/info.impure.lisp @@ -13,7 +13,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. diff --git a/tests/interface.impure.lisp b/tests/interface.impure.lisp index c8c3d0f..3d757fc 100644 --- a/tests/interface.impure.lisp +++ b/tests/interface.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -19,22 +19,22 @@ x) (assert (string= (documentation '(setf foo) 'function) - "(setf foo) documentation")) + "(setf foo) documentation")) (assert (string= (documentation #'(setf foo) 'function) - "(setf foo) documentation")) + "(setf foo) documentation")) (defun (sb-pcl::class-predicate foo) (x) "(class-predicate foo) documentation" x) (assert (string= (documentation '(setf foo) 'function) - "(setf foo) documentation")) + "(setf foo) documentation")) (assert (string= (documentation #'(setf foo) 'function) - "(setf foo) documentation")) + "(setf foo) documentation")) (assert (string= (documentation '(sb-pcl::class-predicate foo) 'function) - "(class-predicate foo) documentation")) + "(class-predicate foo) documentation")) (assert (string= (documentation #'(sb-pcl::class-predicate foo) 'function) - "(class-predicate foo) documentation")) + "(class-predicate foo) documentation")) ;;; DISASSEMBLE shouldn't fail on closures or unpurified functions (defun disassemble-fun (x) x) diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp index cc83e6a..829a4d4 100644 --- a/tests/interface.pure.lisp +++ b/tests/interface.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -25,16 +25,16 @@ ;;; furthermore do the right thing when it gets a package designator. ;;; (bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-17) (assert (< 0 - (length (apropos-list "PRINT" :cl)) - (length (apropos-list "PRINT")))) + (length (apropos-list "PRINT" :cl)) + (length (apropos-list "PRINT")))) ;;; Further, it should correctly deal with the external-only flag (bug ;;; reported by cliini on #lisp IRC 2003-05-30, fixed in sbcl-0.8.0.1x ;;; by CSR) (assert (= (length (apropos-list "" "CL")) - (length (apropos-list "" "CL" t)))) + (length (apropos-list "" "CL" t)))) (assert (< 0 - (length (apropos-list "" "SB-VM" t)) - (length (apropos-list "" "SB-VM")))) + (length (apropos-list "" "SB-VM" t)) + (length (apropos-list "" "SB-VM")))) ;;; DESCRIBE shouldn't fail on rank-0 arrays (bug reported and fixed ;;; by Lutz Euler sbcl-devel 2002-12-03) @@ -58,31 +58,31 @@ ;;; The DESCRIBE-OBJECT methods for built-in CL stuff should do ;;; FRESH-LINE and TERPRI neatly. (dolist (i (list (make-to-be-described :a 14) 12 "a string" - #0a0 #(1 2 3) #2a((1 2) (3 4)) 'sym :keyword - (find-package :keyword) (list 1 2 3) - nil (cons 1 2) (make-hash-table) - (let ((h (make-hash-table))) - (setf (gethash 10 h) 100 - (gethash 11 h) 121) - h) - (make-condition 'simple-error) - (make-condition 'simple-error :format-control "fc") - #'car #'make-to-be-described (lambda (x) (+ x 11)) - (constantly 'foo) #'(setf to-be-described-a) - #'describe-object (find-class 'to-be-described) - (find-class 'forward-describe-class) - (find-class 'forward-describe-ref) (find-class 'cons))) + #0a0 #(1 2 3) #2a((1 2) (3 4)) 'sym :keyword + (find-package :keyword) (list 1 2 3) + nil (cons 1 2) (make-hash-table) + (let ((h (make-hash-table))) + (setf (gethash 10 h) 100 + (gethash 11 h) 121) + h) + (make-condition 'simple-error) + (make-condition 'simple-error :format-control "fc") + #'car #'make-to-be-described (lambda (x) (+ x 11)) + (constantly 'foo) #'(setf to-be-described-a) + #'describe-object (find-class 'to-be-described) + (find-class 'forward-describe-class) + (find-class 'forward-describe-ref) (find-class 'cons))) (let ((s (with-output-to-string (s) - (write-char #\x s) - (describe i s)))) + (write-char #\x s) + (describe i s)))) (unless (and (char= #\x (char s 0)) - ;; one leading #\NEWLINE from FRESH-LINE or the like, no more - (char= #\newline (char s 1)) - (char/= #\newline (char s 2)) - ;; one trailing #\NEWLINE from TERPRI or the like, no more - (let ((n (length s))) - (and (char= #\newline (char s (- n 1))) - (char/= #\newline (char s (- n 2)))))) + ;; one leading #\NEWLINE from FRESH-LINE or the like, no more + (char= #\newline (char s 1)) + (char/= #\newline (char s 2)) + ;; one trailing #\NEWLINE from TERPRI or the like, no more + (let ((n (length s))) + (and (char= #\newline (char s (- n 1))) + (char/= #\newline (char s (- n 2)))))) (error "misbehavior in DESCRIBE of ~S" i)))) ;;; TYPEP, SUBTYPEP, UPGRADED-ARRAY-ELEMENT-TYPE and @@ -112,19 +112,19 @@ ;;; DECODE-UNIVERSAL-TIME should accept second-resolution time-zones. (macrolet ((test (ut time-zone list) - (destructuring-bind (sec min hr date mon yr day tz) - list - `(multiple-value-bind (sec min hr date mon yr day dst tz) - (decode-universal-time ,ut ,time-zone) - (declare (ignore dst)) - (assert (= sec ,sec)) - (assert (= min ,min)) - (assert (= hr ,hr)) - (assert (= date ,date)) - (assert (= mon ,mon)) - (assert (= yr ,yr)) - (assert (= day ,day)) - (assert (= tz ,tz)))))) + (destructuring-bind (sec min hr date mon yr day tz) + list + `(multiple-value-bind (sec min hr date mon yr day dst tz) + (decode-universal-time ,ut ,time-zone) + (declare (ignore dst)) + (assert (= sec ,sec)) + (assert (= min ,min)) + (assert (= hr ,hr)) + (assert (= date ,date)) + (assert (= mon ,mon)) + (assert (= yr ,yr)) + (assert (= day ,day)) + (assert (= tz ,tz)))))) (test (* 86400 365) -1/3600 (1 0 0 1 1 1901 1 -1/3600)) (test (* 86400 365) 0 (0 0 0 1 1 1901 1 0)) (test (* 86400 365) 1/3600 (59 59 23 31 12 1900 0 1/3600))) diff --git a/tests/lambda-list.pure.lisp b/tests/lambda-list.pure.lisp index 4b318df..3ccb547 100644 --- a/tests/lambda-list.pure.lisp +++ b/tests/lambda-list.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. diff --git a/tests/list.pure.lisp b/tests/list.pure.lisp index b1f588e..1e0a247 100644 --- a/tests/list.pure.lisp +++ b/tests/list.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -18,34 +18,34 @@ ;;; looks as though it's past time to start accumulating regression ;;; tests for these. (dolist (testcase - '((:args ((1 2 3 4 5)) :result (1 2 3 4)) - (:args ((1 2 3 4 5) 6) :result nil) - (:args (nil) :result nil) - (:args ((1 2 3) 0) :result (1 2 3)) - (:args ((1 2 3) 1) :result (1 2)) - (:args ((1 2 3)) :result (1 2)) - (:args ((1 2 3) 2) :result (1)) - (:args ((1 2 3) 3) :result nil) - (:args ((1 2 3) 4) :result nil) - (:args ((1 2 3 . 4) 0) :result (1 2 3 . 4)) - (:args ((1 2 3 . 4) 1) :result (1 2)) - (:args ((1 2 3 . 4)) :result (1 2)) - (:args ((1 2 3 . 4) 2) :result (1)) - (:args ((1 2 3 . 4) 3) :result nil) - (:args ((1 2 3 . 4) 4) :result nil))) + '((:args ((1 2 3 4 5)) :result (1 2 3 4)) + (:args ((1 2 3 4 5) 6) :result nil) + (:args (nil) :result nil) + (:args ((1 2 3) 0) :result (1 2 3)) + (:args ((1 2 3) 1) :result (1 2)) + (:args ((1 2 3)) :result (1 2)) + (:args ((1 2 3) 2) :result (1)) + (:args ((1 2 3) 3) :result nil) + (:args ((1 2 3) 4) :result nil) + (:args ((1 2 3 . 4) 0) :result (1 2 3 . 4)) + (:args ((1 2 3 . 4) 1) :result (1 2)) + (:args ((1 2 3 . 4)) :result (1 2)) + (:args ((1 2 3 . 4) 2) :result (1)) + (:args ((1 2 3 . 4) 3) :result nil) + (:args ((1 2 3 . 4) 4) :result nil))) (destructuring-bind (&key args result) testcase (destructuring-bind (list &rest rest) args ;; Test with BUTLAST. (let ((actual-result (apply #'butlast args))) - (when (and (consp list) (eq actual-result list)) - (error "not a copy in BUTLAST for ~S" args)) - (unless (equal actual-result result) - (error "failed BUTLAST for ~S" args))) + (when (and (consp list) (eq actual-result list)) + (error "not a copy in BUTLAST for ~S" args)) + (unless (equal actual-result result) + (error "failed BUTLAST for ~S" args))) ;; Test with NBUTLAST. (let* ((copied-list (copy-list list)) - (actual-result (apply #'nbutlast copied-list rest))) - (unless (equal actual-result result) - (error "failed NBUTLAST for ~S" args)))))) + (actual-result (apply #'nbutlast copied-list rest))) + (unless (equal actual-result result) + (error "failed NBUTLAST for ~S" args)))))) (multiple-value-bind (result error) (ignore-errors (apply #'butlast (list t))) @@ -107,9 +107,9 @@ (reverse (1 2 . 3)) (nreverse (1 2 . 3)) (nreconc (1 2 . 3) (4 5)) - (copy-alist ((1 . 2) (3 . 4) . 5)))) + (copy-alist ((1 . 2) (3 . 4) . 5)))) (assert (raises-error? (apply (first test) (copy-tree (rest test))) - type-error))) + type-error))) ;;; Bug reported by Paul Dietz: NSET-EXCLUSIVE-OR should not return ;;; extra elements, even when given "sets" contain duplications diff --git a/tests/load.impure.lisp b/tests/load.impure.lisp index fb7b9c9..fb107f4 100644 --- a/tests/load.impure.lisp +++ b/tests/load.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. diff --git a/tests/load.pure.lisp b/tests/load.pure.lisp index f12a9bd..09ef251 100644 --- a/tests/load.pure.lisp +++ b/tests/load.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. diff --git a/tests/loop.impure.lisp b/tests/loop.impure.lisp index 1440165..22530a5 100644 --- a/tests/loop.impure.lisp +++ b/tests/loop.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -22,14 +22,14 @@ (let ((blah2 (intern "blah2" package))) (export blah2 package)) (assert (equal '("blah" "blah2") - (sort (loop for sym being each present-symbol of package - for sym-name = (symbol-name sym) - collect sym-name) - #'string<))) + (sort (loop for sym being each present-symbol of package + for sym-name = (symbol-name sym) + collect sym-name) + #'string<))) (assert (equal '("blah2") - (sort (loop for sym being each external-symbol of package for - sym-name = (symbol-name sym) collect sym-name) - (function string<))))) + (sort (loop for sym being each external-symbol of package for + sym-name = (symbol-name sym) collect sym-name) + (function string<))))) ;;; success (quit :unix-status 104) diff --git a/tests/loop.pure.lisp b/tests/loop.pure.lisp index 6d5f3e4..917731a 100644 --- a/tests/loop.pure.lisp +++ b/tests/loop.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -16,31 +16,31 @@ ;;; The bug reported by Alexei Dejneka on sbcl-devel 2001-09-03 ;;; is fixed now. (assert (equal (let ((hash (make-hash-table))) - (setf (gethash 'key1 hash) 'val1) - (setf (gethash 'key2 hash) 'val2) - (sort (loop for key being each hash-key in hash - collect key) - #'string<)) - '(key1 key2))) + (setf (gethash 'key1 hash) 'val1) + (setf (gethash 'key2 hash) 'val2) + (sort (loop for key being each hash-key in hash + collect key) + #'string<)) + '(key1 key2))) ;;; Bug 81, reported by Wolfhard Buss on cmucl-help 2001-02-14, was ;;; fixed by Alexey Dejneka's patch on sbcl-devel 2001-09-30. (assert (equal '(0.0 1.0 2.0 3.0) - (loop with (a . b) of-type float = '(0.0 . 1.0) - and (c . d) of-type float = '(2.0 . 3.0) - return (list a b c d)))) + (loop with (a . b) of-type float = '(0.0 . 1.0) + and (c . d) of-type float = '(2.0 . 3.0) + return (list a b c d)))) ;;; a bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-05: ;;; The type declarations should apply, hence under Python's ;;; declarations-are-assertions rule, the code should signal a type ;;; error. (assert (typep (nth-value 1 - (ignore-errors - (funcall (lambda () - (loop with (a . b) - of-type float = '(5 . 5) - return (list a b)))))) - 'type-error)) + (ignore-errors + (funcall (lambda () + (loop with (a . b) + of-type float = '(5 . 5) + return (list a b)))))) + 'type-error)) ;;; bug 103, reported by Arthur Lemmens sbcl-devel 2001-05-05, ;;; fixed by Alexey Dejneka patch sbcl-devel 2001-10-05: @@ -48,10 +48,10 @@ ;;; must be compound forms. (multiple-value-bind (function warnings-p failure-p) (compile nil - '(lambda () - (loop while t do - *print-level* - (print t)))) + '(lambda () + (loop while t do + *print-level* + (print t)))) (declare (ignore function warnings-p)) (assert failure-p)) @@ -59,11 +59,11 @@ ;;; duplicate bindings in LOOP must signal errors of type ;;; PROGRAM-ERROR. (assert (typep (nth-value 1 - (ignore-errors - (funcall (lambda () - (loop for (a . a) in '((1 . 2) (3 . 4)) - return a))))) - 'program-error)) + (ignore-errors + (funcall (lambda () + (loop for (a . a) in '((1 . 2) (3 . 4)) + return a))))) + 'program-error)) ;;; similar to gcl/ansi-test LOOP.1.27, and fixed at the same time: (assert (equal (loop for x downto 7 by 2 from 13 collect x) '(13 11 9 7))) @@ -73,10 +73,10 @@ (setf (gethash 'foo table) '(bar baz)) (assert (= (loop for nil being the hash-keys of table count t) 1)) (assert (equal (loop for nil being the hash-keys of table - using (hash-value (v1 . v2)) - when v1 - return v2) - '(baz)))) + using (hash-value (v1 . v2)) + when v1 + return v2) + '(baz)))) (assert (= (loop for nil being the external-symbols of :cl count t) 978)) (assert (= (loop for x being the external-symbols of :cl count x) 977)) @@ -89,7 +89,7 @@ (multiple-value-bind (result error) (ignore-errors (loop for nil being the external-symbols of :nonexistent-package - count t)) + count t)) (assert (null result)) (assert (typep error 'package-error))) @@ -103,13 +103,13 @@ (assert (typep error 'program-error))) (assert (equal - (ignore-errors (loop for i from 1 repeat 6.5 collect i)) - (ignore-errors (loop for i from 1 repeat (eval '6.5) collect i)))) + (ignore-errors (loop for i from 1 repeat 6.5 collect i)) + (ignore-errors (loop for i from 1 repeat (eval '6.5) collect i)))) (assert (eq (block nil - (loop named foo do (loop-finish) finally (return :good)) - :bad) - :good)) + (loop named foo do (loop-finish) finally (return :good)) + :bad) + :good)) (assert (= (loop with (a nil) = '(1 2) return a) 1)) (assert (= (loop with (nil a) = '(1 2) return a) 2)) @@ -122,26 +122,26 @@ (assert (null result)) (assert (typep error 'program-error))) (assert (equal - (loop for i in '(1 2 3) collect i into foo always (< i 4) - finally (return foo)) - '(1 2 3))) + (loop for i in '(1 2 3) collect i into foo always (< i 4) + finally (return foo)) + '(1 2 3))) (assert (equal - (loop for i in '(1 2 3) collect i into foo always (= i 4) - finally (return foo)) - nil)) + (loop for i in '(1 2 3) collect i into foo always (= i 4) + finally (return foo)) + nil)) (multiple-value-bind (result error) (ignore-errors (loop for i in '(1 2 3) always (< i 4) collect i)) (assert (null result)) (assert (typep error 'program-error))) (assert (equal - (loop for i in '(1 2 3) always (< i 4) collect i into foo - finally (return foo)) - '(1 2 3))) + (loop for i in '(1 2 3) always (< i 4) collect i into foo + finally (return foo)) + '(1 2 3))) (assert (equal - (loop for i in '(1 2 3) always (= i 4) collect i into foo - finally (return foo)) - nil)) + (loop for i in '(1 2 3) always (= i 4) collect i into foo + finally (return foo)) + nil)) (multiple-value-bind (result error) (ignore-errors (loop for i in '(1 2 3) thereis (= i 3) collect i)) @@ -158,19 +158,19 @@ ;; ANSI seems specifically to disallow it (ignore-errors (loop with i = 1 with i = (1+ i) - for x from 1 to 3 - collect (+ x i))) + for x from 1 to 3 + collect (+ x i))) (assert (null result)) (assert (typep error 'program-error))) (let ((it 'z)) (assert (equal - ;; this one just seems weird. Nevertheless... - (loop for i in '(a b c d) - when i - collect it - and collect it) - '(a z b z c z d z)))) + ;; this one just seems weird. Nevertheless... + (loop for i in '(a b c d) + when i + collect it + and collect it) + '(a z b z c z d z)))) (let ((ht (make-hash-table))) (setf (gethash 1 ht) 3) @@ -182,9 +182,9 @@ ;; arithmetic indexes can be NIL or symbols. (assert (equal (loop for nil from 0 to 2 collect nil) - '(nil nil nil))) + '(nil nil nil))) (assert (equal (loop for nil to 2 collect nil) - '(nil nil nil))) + '(nil nil nil))) ;; although allowed by the loop syntax definition in 6.2/LOOP, ;; 6.1.2.1.1 says: "The variable var is bound to the value of form1 in @@ -192,16 +192,16 @@ ;; we give a program error. (multiple-value-bind (function warnings-p failure-p) (compile nil - `(lambda () - (loop for (i j) from 4 to 6 collect nil))) + `(lambda () + (loop for (i j) from 4 to 6 collect nil))) (assert failure-p)) ;; ...and another for indexes without FROM forms (these are treated ;; differently by the loop code right now (multiple-value-bind (function warnings-p failure-p) (compile nil - `(lambda () - (loop for (i j) to 6 collect nil))) + `(lambda () + (loop for (i j) to 6 collect nil))) (assert failure-p)) (assert @@ -216,12 +216,12 @@ '(10d0 8d0 6d0 4d0 2d0 0d0))) (let ((fn (handler-case - (compile nil '(lambda () - (declare (special x y)) - (loop thereis (pop x) thereis (pop y)))) - (warning (c) (error "Warned: ~S" c))))) + (compile nil '(lambda () + (declare (special x y)) + (loop thereis (pop x) thereis (pop y)))) + (warning (c) (error "Warned: ~S" c))))) (let ((x (list nil nil 1)) - (y (list nil 2 nil))) + (y (list nil 2 nil))) (declare (special x y)) (assert (= (funcall fn) 2)))) @@ -232,7 +232,7 @@ ;;; Detection of duplicate bindings, reported by Bruno Haible for CMUCL. (multiple-value-bind (_ condition) - (ignore-errors + (ignore-errors (macroexpand '(LOOP WITH A = 0 FOR A DOWNFROM 10 TO 0 DO (PRINT A)))) (declare (ignore _)) (assert (typep condition 'program-error))) diff --git a/tests/map-tests.impure.lisp b/tests/map-tests.impure.lisp index d618309..efd4ca3 100644 --- a/tests/map-tests.impure.lisp +++ b/tests/map-tests.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -17,25 +17,25 @@ ;;; tests of MAP ;;; FIXME: Move these into their own file. (assertoid (map 'vector #'+ '(1 2 3) '(30 20)) - :expected-equalp #(31 22)) + :expected-equalp #(31 22)) (assertoid (map 'list #'+ #(1 2) '(100) #(0) #(100 100)) - :expected-equal '(201)) + :expected-equal '(201)) (defmacro with-mapnil-test-fun (fun-name &body body) `(let ((reversed-result nil)) (flet ((,fun-name (&rest rest) - (push rest reversed-result))) + (push rest reversed-result))) ,@body (nreverse reversed-result)))) (assertoid (with-mapnil-test-fun fun - (map nil #'fun #(1))) - :expected-equal '((1))) + (map nil #'fun #(1))) + :expected-equal '((1))) (assertoid (with-mapnil-test-fun fun - (map nil #'fun #() '(1 2 3))) - :expected-equal '()) + (map nil #'fun #() '(1 2 3))) + :expected-equal '()) (assertoid (with-mapnil-test-fun fun - (map nil #'fun #(a b c) '(alpha beta) '(aleph beth))) - :expected-equal '((a alpha aleph) (b beta beth))) + (map nil #'fun #(a b c) '(alpha beta) '(aleph beth))) + :expected-equal '((a alpha aleph) (b beta beth))) ;;; Exercise MAP repeatedly on the same dataset by providing various ;;; combinations of sequence type arguments, declarations, and so @@ -48,65 +48,65 @@ (defvar *vector-20* #(10 20)) (defvar *vector-30* #(10 20 30)) (defmacro maptest (&key - result-seq - fun-name - arg-seqs - arg-types - (result-element-types '(t))) + result-seq + fun-name + arg-seqs + arg-types + (result-element-types '(t))) (let ((reversed-assertoids nil)) (dotimes (arg-type-index (expt 2 (length arg-types))) (labels (;; Arrange for EXPR to be executed. - (arrange (expr) - (push expr reversed-assertoids)) - ;; We toggle the various type declarations on and - ;; off depending on the bit pattern in ARG-TYPE-INDEX, - ;; so that we get lots of different things to test. - (eff-arg-type (i) - (if (and (< i (length arg-types)) - (plusp (logand (expt 2 i) - arg-type-index))) - (nth i arg-types) - t)) - (args-with-type-decls () - (let ((reversed-result nil)) - (dotimes (i (length arg-seqs) (nreverse reversed-result)) - (push `(the ,(eff-arg-type i) - ,(nth i arg-seqs)) - reversed-result))))) - (dolist (fun `(',fun-name #',fun-name)) - (dolist (result-type (cons 'list - (mapcan (lambda (et) - `((vector ,et) - (simple-array ,et 1))) - result-element-types))) - (arrange - `(assertoid (map ',result-type ,fun ,@(args-with-type-decls)) - :expected-equalp (coerce ,result-seq - ',result-type))))) - (arrange - `(assertoid (mapcar (lambda (args) (apply #',fun-name args)) - (with-mapnil-test-fun mtf - (map nil - ;; (It would be nice to test MAP - ;; NIL with function names, too, - ;; but I can't see any concise way - ;; to do it..) - #'mtf - ,@(args-with-type-decls)))) - :expected-equal (coerce ,result-seq 'list))))) + (arrange (expr) + (push expr reversed-assertoids)) + ;; We toggle the various type declarations on and + ;; off depending on the bit pattern in ARG-TYPE-INDEX, + ;; so that we get lots of different things to test. + (eff-arg-type (i) + (if (and (< i (length arg-types)) + (plusp (logand (expt 2 i) + arg-type-index))) + (nth i arg-types) + t)) + (args-with-type-decls () + (let ((reversed-result nil)) + (dotimes (i (length arg-seqs) (nreverse reversed-result)) + (push `(the ,(eff-arg-type i) + ,(nth i arg-seqs)) + reversed-result))))) + (dolist (fun `(',fun-name #',fun-name)) + (dolist (result-type (cons 'list + (mapcan (lambda (et) + `((vector ,et) + (simple-array ,et 1))) + result-element-types))) + (arrange + `(assertoid (map ',result-type ,fun ,@(args-with-type-decls)) + :expected-equalp (coerce ,result-seq + ',result-type))))) + (arrange + `(assertoid (mapcar (lambda (args) (apply #',fun-name args)) + (with-mapnil-test-fun mtf + (map nil + ;; (It would be nice to test MAP + ;; NIL with function names, too, + ;; but I can't see any concise way + ;; to do it..) + #'mtf + ,@(args-with-type-decls)))) + :expected-equal (coerce ,result-seq 'list))))) `(progn ,@(nreverse reversed-assertoids)))) (maptest :result-seq '(2 3) - :fun-name 1+ - :arg-seqs (*list-2*) - :arg-types (list)) + :fun-name 1+ + :arg-seqs (*list-2*) + :arg-types (list)) (maptest :result-seq '(nil nil nil) - :fun-name oddp - :arg-seqs (*vector-30*) - :arg-types (vector)) + :fun-name oddp + :arg-seqs (*vector-30*) + :arg-types (vector)) (maptest :result-seq '(12 24) - :fun-name + - :arg-seqs (*list-2* *list-2* *vector-30*) - :arg-types (list list vector)) + :fun-name + + :arg-seqs (*list-2* *list-2* *vector-30*) + :arg-types (list list vector)) ;;; success (quit :unix-status 104) diff --git a/tests/mop-1.impure-cload.lisp b/tests/mop-1.impure-cload.lisp index 42f7453..9d33e90 100644 --- a/tests/mop-1.impure-cload.lisp +++ b/tests/mop-1.impure-cload.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -85,21 +85,21 @@ (call-next-method)))) (defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-class) - instance slotd) + instance slotd) (let ((slot (find slotd (class-slots class)))) (if slot - (write-dynamic-slot-value new-value instance (slot-definition-name slotd)) - (call-next-method)))) + (write-dynamic-slot-value new-value instance (slot-definition-name slotd)) + (call-next-method)))) (defmethod slot-boundp-using-class ((class dynamic-slot-class) - instance slotd) + instance slotd) (let ((slot (find slotd (class-slots class)))) (if slot (dynamic-slot-boundp instance (slot-definition-name slotd)) (call-next-method)))) (defmethod slot-makunbound-using-class ((class dynamic-slot-class) - instance slotd) + instance slotd) (let ((slot (find slotd (class-slots class)))) (if slot (dynamic-slot-makunbound instance (slot-definition-name slotd)) diff --git a/tests/mop-2.impure-cload.lisp b/tests/mop-2.impure-cload.lisp index 0f229a0..a3d7bc8 100644 --- a/tests/mop-2.impure-cload.lisp +++ b/tests/mop-2.impure-cload.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -82,21 +82,21 @@ (call-next-method)))) (defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-class) - instance slotd) + instance slotd) (let ((slot (find slotd (class-slots class)))) (if (and slot (dynamic-slot-p slot)) - (write-dynamic-slot-value new-value instance (slot-definition-name slotd)) - (call-next-method)))) + (write-dynamic-slot-value new-value instance (slot-definition-name slotd)) + (call-next-method)))) (defmethod slot-boundp-using-class ((class dynamic-slot-class) - instance slotd) + instance slotd) (let ((slot (find slotd (class-slots class)))) (if (and slot (dynamic-slot-p slot)) (dynamic-slot-boundp instance (slot-definition-name slotd)) (call-next-method)))) (defmethod slot-makunbound-using-class ((class dynamic-slot-class) - instance slotd) + instance slotd) (let ((slot (find slotd (class-slots class)))) (if (and slot (dynamic-slot-p slot)) (dynamic-slot-makunbound instance (slot-definition-name slotd)) @@ -135,18 +135,18 @@ (defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-subclass) - instance slotd) + instance slotd) (let ((slot (find slotd (class-slots class)))) (if (and slot (dynamic-slot-p slot)) - (write-dynamic-slot-value new-value instance (slot-definition-name slotd)) - (call-next-method)))) + (write-dynamic-slot-value new-value instance (slot-definition-name slotd)) + (call-next-method)))) (defmethod slot-boundp-using-class ((class dynamic-slot-subclass) instance slotd) (let ((slot (find slotd (class-slots class)))) (if (and slot (dynamic-slot-p slot)) - (dynamic-slot-boundp instance (slot-definition-name slotd)) - (call-next-method)))) + (dynamic-slot-boundp instance (slot-definition-name slotd)) + (call-next-method)))) (defclass test-class-3 (test-class-1) ((slot2 :initarg :slot2 :initform t :allocation :dynamic) diff --git a/tests/mop.impure-cload.lisp b/tests/mop.impure-cload.lisp index 56a0ddb..07932e0 100644 --- a/tests/mop.impure-cload.lisp +++ b/tests/mop.impure-cload.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -24,8 +24,8 @@ ;;; hyperobject. Fix from Gerd Moellmann. (defclass hyperobject-class (standard-class) ((user-name :initarg :user-name :type string :initform nil - :accessor user-name - :documentation "User name for class"))) + :accessor user-name + :documentation "User name for class"))) (defclass hyperobject-dsd (standard-direct-slot-definition) ()) @@ -34,7 +34,7 @@ ((vc :initform 42))) (defmethod validate-superclass ((class hyperobject-class) - (superclass standard-class)) + (superclass standard-class)) t) (defmethod compute-effective-slot-definition :around diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index 3b9aede..053148e 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -25,26 +25,26 @@ (assert (null (class-direct-slots (find-class 'forward-ref)))) (assert (null (class-direct-default-initargs - (find-class 'forward-ref)))) + (find-class 'forward-ref)))) ;;; Readers for Generic Function Metaobjects (pp. 216--218 of AMOP) (defgeneric fn-with-odd-arg-precedence (a b c) (:argument-precedence-order b c a)) (assert (equal - (generic-function-lambda-list #'fn-with-odd-arg-precedence) - '(a b c))) + (generic-function-lambda-list #'fn-with-odd-arg-precedence) + '(a b c))) (assert (equal - (generic-function-argument-precedence-order #'fn-with-odd-arg-precedence) - '(b c a))) + (generic-function-argument-precedence-order #'fn-with-odd-arg-precedence) + '(b c a))) ;;; Test for DOCUMENTATION's order, which was wrong until sbcl-0.7.8.39 (assert (equal - (generic-function-argument-precedence-order #'documentation) - (let ((ll (generic-function-lambda-list #'documentation))) - (list (nth 1 ll) (nth 0 ll))))) + (generic-function-argument-precedence-order #'documentation) + (let ((ll (generic-function-lambda-list #'documentation))) + (list (nth 1 ll) (nth 0 ll))))) (assert (null - (generic-function-declarations #'fn-with-odd-arg-precedence))) + (generic-function-declarations #'fn-with-odd-arg-precedence))) (defgeneric gf-with-declarations (x) (declare (optimize (speed 3))) (declare (optimize (safety 0)))) @@ -61,13 +61,13 @@ ((an-instance-slot :accessor an-instance-slot) (a-class-slot :allocation :class :accessor a-class-slot))) (dolist (m (list (list #'an-instance-slot :instance) - (list #'a-class-slot :class))) + (list #'a-class-slot :class))) (let ((methods (generic-function-methods (car m)))) (assert (= (length methods) 1)) (assert (eq (slot-definition-allocation - (accessor-method-slot-definition - (car methods))) - (cadr m))))) + (accessor-method-slot-definition + (car methods))) + (cadr m))))) ;;; Class Finalization Protocol (see section 5.5.2 of AMOP) (let ((finalized-count 0)) @@ -98,9 +98,9 @@ ;;; not going to change often. (dolist (x '(number array sequence character symbol)) (assert (eq (car (class-direct-superclasses (find-class x))) - (find-class t))) + (find-class t))) (assert (member (find-class x) - (class-direct-subclasses (find-class t))))) + (class-direct-subclasses (find-class t))))) ;;; the class-prototype of the NULL class used to be some weird ;;; standard-instance-like thing. Make sure it's actually NIL. @@ -112,17 +112,17 @@ ;;; simple consistency checks for the SB-MOP package: all of the ;;; functionality specified in AMOP is in functions and classes: (assert (null (loop for x being each external-symbol in "SB-MOP" - unless (or (fboundp x) (find-class x)) collect x))) + unless (or (fboundp x) (find-class x)) collect x))) ;;; and all generic functions in SB-MOP have at least one specified ;;; method, except for UPDATE-DEPENDENT (assert (null (loop for x being each external-symbol in "SB-MOP" - unless (or (not (fboundp x)) - (eq x 'update-dependent) - (not (typep (fdefinition x) 'generic-function)) - (> (length (generic-function-methods - (fdefinition x))) - 0)) - collect x))) + unless (or (not (fboundp x)) + (eq x 'update-dependent) + (not (typep (fdefinition x) 'generic-function)) + (> (length (generic-function-methods + (fdefinition x))) + 0)) + collect x))) ;;; make sure that ENSURE-CLASS-USING-CLASS's arguments are the right ;;; way round (!) @@ -194,17 +194,17 @@ (defclass class-to-add-instance-slot (dummy-ctais) ()) (defmethod compute-slots ((c (eql (find-class 'class-to-add-instance-slot)))) (append (call-next-method) - (list (make-instance 'standard-effective-slot-definition - :name 'y - :allocation :instance)))) + (list (make-instance 'standard-effective-slot-definition + :name 'y + :allocation :instance)))) (defclass dummy-ctais () ((x :allocation :class))) -(assert (equal (mapcar #'slot-definition-allocation - (class-slots (find-class 'class-to-add-instance-slot))) - ;; FIXME: is the order really guaranteed? - '(:class :instance))) -(assert (typep (slot-definition-location - (cadr (class-slots (find-class 'class-to-add-instance-slot)))) - 'unsigned-byte)) +(assert (equal (mapcar #'slot-definition-allocation + (class-slots (find-class 'class-to-add-instance-slot))) + ;; FIXME: is the order really guaranteed? + '(:class :instance))) +(assert (typep (slot-definition-location + (cadr (class-slots (find-class 'class-to-add-instance-slot)))) + 'unsigned-byte)) #| (assert (typep (slot-definition-location (car ...)) '???)) |# (let ((x (make-instance 'class-to-add-instance-slot))) (assert (not (slot-boundp x 'x))) @@ -221,13 +221,13 @@ (defclass class-to-add-class-slot (dummy-ctacs) ()) (defmethod compute-slots ((c (eql (find-class 'class-to-add-class-slot)))) (append (call-next-method) - (list (make-instance 'standard-effective-slot-definition - :name 'y - :allocation :class)))) + (list (make-instance 'standard-effective-slot-definition + :name 'y + :allocation :class)))) (defclass dummy-ctacs () ((x :allocation :class))) -(assert (equal (mapcar #'slot-definition-allocation - (class-slots (find-class 'class-to-add-class-slot))) - '(:class :class))) +(assert (equal (mapcar #'slot-definition-allocation + (class-slots (find-class 'class-to-add-class-slot))) + '(:class :class))) (let ((x (make-instance 'class-to-add-class-slot))) (assert (not (slot-boundp x 'x))) (setf (slot-value x 'x) nil) @@ -252,8 +252,8 @@ ((frob-slot :initarg :frob-slot :allocation :frob))) (handler-case (funcall (compile nil '(lambda () - (make-instance 'class-with-frob-slot - :frob-slot 1)))) + (make-instance 'class-with-frob-slot + :frob-slot 1)))) (sb-int:bug (c) (error c)) (error () "Probably OK: haven't implemented SLOT-BOUNDP-USING-CLASS")) ;;; secondly, it failed to take account of the fact that we might wish @@ -265,7 +265,7 @@ (new-value class (instance class-with-special-ssvuc) slotd) (incf *special-ssvuc-counter*)) (let ((fun (compile nil '(lambda () (make-instance 'class-with-special-ssvuc - :some-slot 1))))) + :some-slot 1))))) (assert (= *special-ssvuc-counter* 0)) (funcall fun) (assert (= *special-ssvuc-counter* 1)) @@ -276,7 +276,7 @@ ((some-slot :initarg :some-slot))) (defvar *special-ssvuc-counter-2* 0) (let ((fun (compile nil '(lambda () (make-instance 'class-with-special-ssvuc-2 - :some-slot 1))))) + :some-slot 1))))) (assert (= *special-ssvuc-counter-2* 0)) (funcall fun) (assert (= *special-ssvuc-counter-2* 0)) @@ -298,7 +298,7 @@ (defclass auto-accessors-class (standard-class) ()) (defmethod direct-slot-definition-class ((class auto-accessors-class) - &rest initargs) + &rest initargs) (let ((dsd-class-name (gensym))) (sb-pcl:ensure-class dsd-class-name @@ -306,21 +306,21 @@ :direct-superclasses (list (find-class 'standard-direct-slot-definition)) :containing-class-name (class-name class)) (eval `(defmethod initialize-instance :after ((dsd ,dsd-class-name) - &rest args) - (when (and (null (slot-definition-readers dsd)) - (null (slot-definition-writers dsd))) - (let* ((containing-class-name - (slot-value (class-of dsd) 'containing-class-name)) - (accessor-name - (intern - (concatenate 'string - (symbol-name containing-class-name) - "-" - (symbol-name (slot-definition-name dsd))) - (symbol-package containing-class-name)))) - (setf (slot-definition-readers dsd) (list accessor-name)) - (setf (slot-definition-writers dsd) - (list (list 'setf accessor-name))))))) + &rest args) + (when (and (null (slot-definition-readers dsd)) + (null (slot-definition-writers dsd))) + (let* ((containing-class-name + (slot-value (class-of dsd) 'containing-class-name)) + (accessor-name + (intern + (concatenate 'string + (symbol-name containing-class-name) + "-" + (symbol-name (slot-definition-name dsd))) + (symbol-package containing-class-name)))) + (setf (slot-definition-readers dsd) (list accessor-name)) + (setf (slot-definition-writers dsd) + (list (list 'setf accessor-name))))))) (find-class dsd-class-name))) (defmethod validate-superclass ((c1 auto-accessors-class) (c2 standard-class)) t) @@ -329,7 +329,7 @@ (:metaclass auto-accessors-class)) (let ((inst (make-instance 'testclass15 :x 12))) (assert (equal (list (testclass15-x inst) (setf (testclass15-y inst) 13)) - '(12 13)))) + '(12 13)))) ;;; bug reported by Bruno Haible on sbcl-devel 2004-11-17: incorrect ;;; handling of multiple values for non-standard slot-options @@ -338,19 +338,19 @@ ((option :accessor sl-option :initarg :my-option))) (defclass option-slot-class (standard-class) ()) - (defmethod sb-mop:direct-slot-definition-class + (defmethod sb-mop:direct-slot-definition-class ((c option-slot-class) &rest args) (declare (ignore args)) (find-class 'option-slot-definition)) - (defmethod sb-mop:validate-superclass + (defmethod sb-mop:validate-superclass ((c1 option-slot-class) (c2 standard-class)) t) (eval '(defclass test-multiple-slot-option-bug () ((x :my-option bar :my-option baz)) (:metaclass option-slot-class))) - (assert (null (set-difference + (assert (null (set-difference '(bar baz) - (sl-option (first (sb-mop:class-direct-slots + (sl-option (first (sb-mop:class-direct-slots (find-class 'test-multiple-slot-option-bug)))))))) ;;; bug reported by Bruno Haibel on sbcl-devel 2004-11-19: AMOP requires @@ -397,14 +397,14 @@ (assert (not result)) (assert error)) -;;; class as :metaclass +;;; class as :metaclass (assert (typep - (sb-mop:ensure-class-using-class - nil 'class-as-metaclass-test - :metaclass (find-class 'standard-class) - :name 'class-as-metaclass-test - :direct-superclasses (list (find-class 'standard-object))) - 'class)) + (sb-mop:ensure-class-using-class + nil 'class-as-metaclass-test + :metaclass (find-class 'standard-class) + :name 'class-as-metaclass-test + :direct-superclasses (list (find-class 'standard-object))) + 'class)) ;;; COMPUTE-DEFAULT-INITARGS protocol mismatch reported by Bruno ;;; Haible @@ -413,16 +413,16 @@ ()) (defmethod compute-default-initargs ((class custom-default-initargs-class)) (let ((original-default-initargs - (remove-duplicates - (reduce #'append - (mapcar #'class-direct-default-initargs - (class-precedence-list class))) - :key #'car - :from-end t))) + (remove-duplicates + (reduce #'append + (mapcar #'class-direct-default-initargs + (class-precedence-list class))) + :key #'car + :from-end t))) (cons (list ':extra '*extra-initarg-value* #'(lambda () *extra-initarg-value*)) - (remove ':extra original-default-initargs :key #'car)))) + (remove ':extra original-default-initargs :key #'car)))) (defmethod validate-superclass ((c1 custom-default-initargs-class) - (c2 standard-class)) + (c2 standard-class)) t) (defclass extra-initarg () ((slot :initarg :extra)) diff --git a/tests/octets.pure.lisp b/tests/octets.pure.lisp index adafca8..f0d5dba 100644 --- a/tests/octets.pure.lisp +++ b/tests/octets.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -17,69 +17,69 @@ (declare (optimize debug (speed 0))) (labels ((ub8 (len-or-seq) - (if (numberp len-or-seq) - (make-array len-or-seq :element-type '(unsigned-byte 8) :initial-element 0) - (coerce len-or-seq '(simple-array (unsigned-byte 8) (*))))) - - (ensure-roundtrip-ascii () - (let ((octets (ub8 128))) - (dotimes (i 128) - (setf (aref octets i) i)) - (let* ((str (octets-to-string octets :external-format :ascii)) - (oct2 (string-to-octets str :external-format :ascii))) - (assert (= (length octets) (length oct2))) - (assert (every #'= octets oct2)))) - t) - - (ensure-roundtrip-latin (format) - (let ((octets (ub8 256))) - (dotimes (i 256) - (setf (aref octets i) i)) - (let* ((str (octets-to-string octets :external-format format)) - (oct2 (string-to-octets str :external-format format))) - (assert (= (length octets) (length oct2))) - (assert (every #'= octets oct2)))) - t) - - (ensure-roundtrip-latin1 () - (ensure-roundtrip-latin :latin1)) - - #+sb-unicode - (ensure-roundtrip-latin9 () - (ensure-roundtrip-latin :latin9)) - - (ensure-roundtrip-utf8 () - (let ((string (make-string char-code-limit))) - (dotimes (i char-code-limit) - (setf (char string i) (code-char i))) - (let ((string2 - (octets-to-string (string-to-octets string :external-format :utf8) - :external-format :utf8))) - (assert (= (length string2) (length string))) - (assert (string= string string2)))) - t) - - (utf8-decode-test (octets expected-results expected-errors) - (let ((error-count 0)) - (handler-bind ((sb-int:character-decoding-error - (lambda (c) - (incf error-count) - (use-value "?" c)))) - (assert (string= expected-results - (octets-to-string (ub8 octets) - :external-format :utf-8))) - (assert (= error-count expected-errors))))) - - (utf8-decode-tests (octets expected-results) - (let ((expected-errors (count #\? expected-results))) - (utf8-decode-test octets expected-results expected-errors) - (utf8-decode-test (concatenate 'vector - '(34) - octets - '(34)) - (format nil "\"~A\"" expected-results) - expected-errors)))) - + (if (numberp len-or-seq) + (make-array len-or-seq :element-type '(unsigned-byte 8) :initial-element 0) + (coerce len-or-seq '(simple-array (unsigned-byte 8) (*))))) + + (ensure-roundtrip-ascii () + (let ((octets (ub8 128))) + (dotimes (i 128) + (setf (aref octets i) i)) + (let* ((str (octets-to-string octets :external-format :ascii)) + (oct2 (string-to-octets str :external-format :ascii))) + (assert (= (length octets) (length oct2))) + (assert (every #'= octets oct2)))) + t) + + (ensure-roundtrip-latin (format) + (let ((octets (ub8 256))) + (dotimes (i 256) + (setf (aref octets i) i)) + (let* ((str (octets-to-string octets :external-format format)) + (oct2 (string-to-octets str :external-format format))) + (assert (= (length octets) (length oct2))) + (assert (every #'= octets oct2)))) + t) + + (ensure-roundtrip-latin1 () + (ensure-roundtrip-latin :latin1)) + + #+sb-unicode + (ensure-roundtrip-latin9 () + (ensure-roundtrip-latin :latin9)) + + (ensure-roundtrip-utf8 () + (let ((string (make-string char-code-limit))) + (dotimes (i char-code-limit) + (setf (char string i) (code-char i))) + (let ((string2 + (octets-to-string (string-to-octets string :external-format :utf8) + :external-format :utf8))) + (assert (= (length string2) (length string))) + (assert (string= string string2)))) + t) + + (utf8-decode-test (octets expected-results expected-errors) + (let ((error-count 0)) + (handler-bind ((sb-int:character-decoding-error + (lambda (c) + (incf error-count) + (use-value "?" c)))) + (assert (string= expected-results + (octets-to-string (ub8 octets) + :external-format :utf-8))) + (assert (= error-count expected-errors))))) + + (utf8-decode-tests (octets expected-results) + (let ((expected-errors (count #\? expected-results))) + (utf8-decode-test octets expected-results expected-errors) + (utf8-decode-test (concatenate 'vector + '(34) + octets + '(34)) + (format nil "\"~A\"" expected-results) + expected-errors)))) + (ensure-roundtrip-ascii) (ensure-roundtrip-latin1) #+sb-unicode @@ -91,29 +91,29 @@ (let ((l9c (map 'string #'code-char '(8364 352 353 381 382 338 339 376)))) (assert (string= (octets-to-string (string-to-octets l9c :external-format :latin9) - :external-format :latin9) - l9c)))) + :external-format :latin9) + l9c)))) (ensure-roundtrip-utf8) (let ((non-ascii-bytes (make-array 128 - :element-type '(unsigned-byte 8) - :initial-contents (loop for i from 128 below 256 - collect i)))) + :element-type '(unsigned-byte 8) + :initial-contents (loop for i from 128 below 256 + collect i)))) (handler-bind ((sb-int:character-decoding-error - (lambda (c) - (use-value "??" c)))) + (lambda (c) + (use-value "??" c)))) (assert (string= (octets-to-string non-ascii-bytes :external-format :ascii) - (make-string 256 :initial-element #\?))))) + (make-string 256 :initial-element #\?))))) (let ((non-ascii-chars (make-array 128 - :element-type 'character - :initial-contents (loop for i from 128 below 256 - collect (code-char i))))) + :element-type 'character + :initial-contents (loop for i from 128 below 256 + collect (code-char i))))) (handler-bind ((sb-int:character-encoding-error - (lambda (c) - (use-value "??" c)))) + (lambda (c) + (use-value "??" c)))) (assert (equalp (string-to-octets non-ascii-chars :external-format :ascii) - (make-array 256 :initial-element (char-code #\?)))))) - + (make-array 256 :initial-element (char-code #\?)))))) + ;; From Markus Kuhn's UTF-8 test file: ;; http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt @@ -131,7 +131,7 @@ (utf8-decode-tests #(#xfb #xbf #xbf #xbf #xbf) "?") ; #x3ffffff (utf8-decode-tests #(#xfc #x84 #x80 #x80 #x80 #x80) "?") ; #x4000000 (utf8-decode-tests #(#xfd #xbf #xbf #xbf #xbf #xbf) "?") ; #x7fffffff - + ;; Unexpected continuation bytes (utf8-decode-tests #(#x80) "?") (utf8-decode-tests #(#xbf) "?") @@ -144,26 +144,26 @@ ;; All 64 continuation bytes in a row (apply #'utf8-decode-tests - (loop for i from #x80 to #xbf - collect i into bytes - collect #\? into chars - finally (return (list bytes - (coerce chars 'string))))) + (loop for i from #x80 to #xbf + collect i into bytes + collect #\? into chars + finally (return (list bytes + (coerce chars 'string))))) ;; Lonely start characters (flet ((lsc (first last) - (apply #'utf8-decode-tests - (loop for i from first to last - nconc (list i 32) into bytes - nconc (list #\? #\Space) into chars - finally (return (list bytes - (coerce chars 'string))))) - (apply #'utf8-decode-tests - (loop for i from first to last - collect i into bytes - collect #\? into chars - finally (return (list bytes - (coerce chars 'string))))))) + (apply #'utf8-decode-tests + (loop for i from first to last + nconc (list i 32) into bytes + nconc (list #\? #\Space) into chars + finally (return (list bytes + (coerce chars 'string))))) + (apply #'utf8-decode-tests + (loop for i from first to last + collect i into bytes + collect #\? into chars + finally (return (list bytes + (coerce chars 'string))))))) (lsc #xc0 #xdf) ; 2-byte sequence start chars (lsc #xe0 #xef) ; 3-byte (lsc #xf0 #xf7) ; 4-byte @@ -184,7 +184,7 @@ ;; All ten previous tests concatenated (utf8-decode-tests (concatenate 'vector #0# #1# #2# #3# #4# #5# #6# #7# #8# #9#) - "??????????") + "??????????") ;; Random impossible bytes (utf8-decode-tests #(#xfe) "?") diff --git a/tests/package-locks.impure.lisp b/tests/package-locks.impure.lisp index 12e533f..59415e3 100644 --- a/tests/package-locks.impure.lisp +++ b/tests/package-locks.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -30,7 +30,7 @@ (defpackage :test (:use :test-used) (:shadow #:shadowed) - (:export + (:export #:*special* #:car #:cdr @@ -62,26 +62,26 @@ (defun maybe-unintern (name package) (let ((s (find-symbol name package))) (when s - (unintern s package)))) + (unintern s package)))) (defun set-test-locks (lock-p) (dolist (p '(:test :test-aux :test-delete)) (when (find-package p) (if lock-p - (sb-ext:lock-package p) - (sb-ext:unlock-package p))))) + (sb-ext:lock-package p) + (sb-ext:unlock-package p))))) (defun reset-test () "Reset TEST package to a known state, ensure that TEST-DELETE exists." (unless (find-package :test-delete) (make-package :test-delete)) (sb-ext:with-unlocked-packages (:test :test-aux) - (dolist (s '(test:nosymbol-macro - test:noclass test:nostruct test:nostruct2 test:nocondition)) + (dolist (s '(test:nosymbol-macro + test:noclass test:nostruct test:nostruct2 test:nocondition)) (makunbound s) (unintern s) (intern (symbol-name s) :test)) - (rename-package (find-package :test) :test) + (rename-package (find-package :test) :test) (unexport (intern "INTERNAL" :test) :test) (intern *interned* :test) (use-package :test-used :test) @@ -94,11 +94,11 @@ (defconstant test:constant 'test:constant) (intern "UNUSED" :test) (dolist (s '(test:nocondition-slot test:noclass-slot test:nostruct-slot - test-aux:noslot test-aux:noslot2)) + test-aux:noslot test-aux:noslot2)) (fmakunbound s)) (ignore-errors (progn - (fmakunbound 'test:unused) - (makunbound 'test:unused))) + (fmakunbound 'test:unused) + (makunbound 'test:unused))) (maybe-unintern *uninterned* :test) (maybe-unintern "NOT-FROM-TEST" :test) (defconstant test:num 0) @@ -116,8 +116,8 @@ (defmacro with-error-info ((string &rest args) &body forms) `(handler-bind ((error (lambda (e) - (format t ,string ,@args) - (finish-output)))) + (format t ,string ,@args) + (finish-output)))) (progn ,@forms))) ;;;; Test cases @@ -136,10 +136,10 @@ (use-package :test-used :test) (unuse-package :test-unused :test) (shadow "SHADOWED" :test) - (let ((s (with-unlocked-packages (:test) - (let ((s (intern *uninterned* :test))) - (unintern s :test) - s)))) + (let ((s (with-unlocked-packages (:test) + (let ((s (intern *uninterned* :test))) + (unintern s :test) + s)))) (unintern s :test)) ;; binding and altering value @@ -152,7 +152,7 @@ (assert (eql test:*special* :quux))) (let ((test:unused :zot)) (assert (eql test:unused :zot))) - + ;; symbol-macrolet (symbol-macrolet ((test:function :sym-ok)) (assert (eql test:function :sym-ok))) @@ -201,17 +201,17 @@ ;; defining or undefining as a macro or compiler macro (defmacro test:unused () ''foo) (setf (macro-function 'test:unused) (constantly 'foo)) - (define-compiler-macro test:unused (&whole form arg) + (define-compiler-macro test:unused (&whole form arg) form) (setf (compiler-macro-function 'test:unused) (constantly 'foo)) - + ;; type-specifier or structure (progn (defstruct test:nostruct test:nostruct-slot) ;; test creation as well, since the structure-class won't be ;; finalized before that (make-nostruct :nostruct-slot :foo)) - (defclass test:noclass () + (defclass test:noclass () ((slot :initform nil :accessor test:noclass-slot))) (deftype test:notype () 'string) (define-condition test:nocondition (error) @@ -241,7 +241,7 @@ `(setf (car ,cons) ,new-car)) (define-setf-expander test:car (place) (multiple-value-bind (dummies vals newval setter getter) - (get-setf-expansion place) + (get-setf-expansion place) (let ((store (gensym))) (values dummies vals @@ -252,11 +252,11 @@ ;; setf function names (defun (setf test:function) (obj) obj) - (tmp-fmakunbound '(setf test:cdr)) - + (tmp-fmakunbound '(setf test:cdr)) + ;; define-method-combination (define-method-combination test:unused) - + ;; setf find-class (setf (find-class 'test:class) (find-class 'standard-class)) )) @@ -304,7 +304,7 @@ (test:num . (locally (declare (type fixnum test:num)) (cons t t))) - + ;; special (test:nospecial . (locally (declare (special test:nospecial)) @@ -392,10 +392,10 @@ (declare (ignore x)) (incf error-count) (continue x)))) - (eval form) - (unless (= 2 error-count) - (error "expected 2 errors per form, got ~A for ~A" - error-count form)))))) + (eval form) + (unless (= 2 error-count) + (error "expected 2 errors per form, got ~A for ~A" + error-count form)))))) ;;; COMPILE-FILE when unlocked, LOAD locked -- *illegal-runtime-forms* only (let* ((tmp "package-locks.tmp.lisp") @@ -403,18 +403,18 @@ (n 0)) (dolist (form *illegal-runtime-forms*) (unwind-protect - (with-simple-restart (next "~S failed, continue with next test" form) - (reset-test) - (set-test-locks nil) - (with-open-file (f tmp :direction :output) - (prin1 form f)) - (multiple-value-bind (file warnings failure-p) (compile-file tmp) - (set-test-locks t) - (assert (raises-error? (load fasl) sb-ext:package-lock-violation)))) + (with-simple-restart (next "~S failed, continue with next test" form) + (reset-test) + (set-test-locks nil) + (with-open-file (f tmp :direction :output) + (prin1 form f)) + (multiple-value-bind (file warnings failure-p) (compile-file tmp) + (set-test-locks t) + (assert (raises-error? (load fasl) sb-ext:package-lock-violation)))) (when (probe-file tmp) - (delete-file tmp)) + (delete-file tmp)) (when (probe-file fasl) - (delete-file fasl))))) + (delete-file fasl))))) ;;;; Tests for enable-package-locks declarations (reset-test) @@ -442,7 +442,7 @@ (destructuring-bind (sym . form) pair (declare (ignore sym)) (let ((fun (compile nil `(lambda () - ,form)))) + ,form)))) (assert (raises-error? (funcall fun) program-error))))) ;;;; See that trace on functions in locked packages doesn't break @@ -453,8 +453,8 @@ ;;;; package. Reported by by Francois-Rene Rideau. (assert (package-locked-p :sb-gray)) (multiple-value-bind (fun compile-errors) - (ignore-errors - (compile nil + (ignore-errors + (compile nil '(lambda () (defclass fare-class () ((line-column :initform 0 :reader sb-gray:stream-line-column)))))) @@ -472,10 +472,10 @@ test:*special*) (assert (eq *terminal-io* (pcl-type-declaration-method-bug *terminal-io*))) (assert (raises-error? - (eval '(defmethod pcl-type-declaration-method-bug ((test:*special* stream)) - (declare (type stream test:*special*)) - test:*special*)) - package-lock-violation)) + (eval '(defmethod pcl-type-declaration-method-bug ((test:*special* stream)) + (declare (type stream test:*special*)) + test:*special*)) + package-lock-violation)) ;;; WOOT! Done. (sb-ext:quit :unix-status 104) diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp index b7e22b0..0496895 100644 --- a/tests/packages.impure.lisp +++ b/tests/packages.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index bb23ae0..b4a9af5 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -9,7 +9,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -48,7 +48,7 @@ "tmp/rel/foo.lisp"))) (assert (equal (namestring (translate-logical-pathname "demo1:;foo.lisp")) "/tmp/rel/foo.lisp")) - + ;;; Under SBCL: new function #'UNPARSE-ENOUGH-NAMESTRING, to ;;; handle the following case exactly (otherwise we get an error: ;;; "#'IDENTITY CALLED WITH 2 ARGS." @@ -62,11 +62,11 @@ ;;; in the cleanup issue PATHNAME-LOGICAL:ADD seem to be a pretty ;;; compelling reason for the implementors to choose case ;;; insensitivity and a canonical case.) -(setf (logical-pathname-translations "FOO") +(setf (logical-pathname-translations "FOO") '(("**;*.*.*" "/full/path/to/foo/**/*.*"))) -(let* ((pn1 (make-pathname :host "FOO" :directory "etc" :name "INETD" +(let* ((pn1 (make-pathname :host "FOO" :directory "etc" :name "INETD" :type "conf")) - (pn2 (make-pathname :host "foo" :directory "ETC" :name "inetd" + (pn2 (make-pathname :host "foo" :directory "ETC" :name "inetd" :type "CONF")) (pn3 (read-from-string (prin1-to-string pn1)))) (assert (equal pn1 pn2)) @@ -81,18 +81,18 @@ (locally ;; MAKE-PATHNAME is UNSAFELY-FLUSHABLE (declare (optimize safety)) - + (assert (not (ignore-errors - (make-pathname :host "FOO" :directory "!bla" :name "bar")))) - + (make-pathname :host "FOO" :directory "!bla" :name "bar")))) + ;; error: name-component not valid (assert (not (ignore-errors - (make-pathname :host "FOO" :directory "bla" :name "!bar")))) - + (make-pathname :host "FOO" :directory "bla" :name "!bar")))) + ;; error: type-component not valid. (assert (not (ignore-errors - (make-pathname :host "FOO" :directory "bla" :name "bar" - :type "&baz"))))) + (make-pathname :host "FOO" :directory "bla" :name "bar" + :type "&baz"))))) ;;; We may need to parse the host as a LOGICAL-NAMESTRING HOST. The ;;; HOST in PARSE-NAMESTRING can be either a string or :UNSPECIFIC @@ -225,14 +225,14 @@ ;; recognizes a logical pathname namestring when ;; default-pathname is a logical pathname ;; FIXME: 0.6.12.23 fails this one. - ;; - ;; And, as it happens, it's right to fail it. Because - ;; #p"name1" is read in with the ambient *d-p-d* value, which - ;; has a physical (Unix) host; therefore, the host of the - ;; default-pathname argument to merge-pathnames is - ;; irrelevant. The result is (correctly) different if - ;; '#p"name1"' is replaced by "name1", below, though it's - ;; still not what one might expect... -- CSR, 2002-05-09 + ;; + ;; And, as it happens, it's right to fail it. Because + ;; #p"name1" is read in with the ambient *d-p-d* value, which + ;; has a physical (Unix) host; therefore, the host of the + ;; default-pathname argument to merge-pathnames is + ;; irrelevant. The result is (correctly) different if + ;; '#p"name1"' is replaced by "name1", below, though it's + ;; still not what one might expect... -- CSR, 2002-05-09 #+nil (#P"scratch:foo;name1" #p"name1" #p"scratch:foo;") ;; or when the namestring begins with the name of a defined ;; logical host followed by a colon [I assume that refers to pathname @@ -241,23 +241,23 @@ ;; conduct the previous set of tests again, with a lpn first argument (#P"SCRATCH:USR;LOCAL;DOC;FOO" #p"scratch:;foo" #p"/usr/local/doc/") (#p"SCRATCH:SUPPLIED-DIR;NAME.TYPE" - #p"scratch:supplied-dir;" - #p"/dir/name.type") + #p"scratch:supplied-dir;" + #p"/dir/name.type") (#p"SCRATCH:DIR;SUPPLIED-NAME.TYPE" - #p"scratch:;supplied-name" - #p"/dir/name.type") + #p"scratch:;supplied-name" + #p"/dir/name.type") (#p"SCRATCH:DIR;NAME.SUPPLIED-TYPE" ,(make-pathname :host "scratch" :type "supplied-type") - #p"/dir/name.type") + #p"/dir/name.type") (#p"SCRATCH:AAA;BBB;CCC;DDD;FOO;BAR" ,(make-pathname :host "scratch" - :directory '(:relative "foo") - :name "bar") + :directory '(:relative "foo") + :name "bar") #p"/aaa/bbb/ccc/ddd/eee") (#p"SCRATCH:AAA;BBB;CCC;FOO;BAR" ,(make-pathname :host "scratch" - :directory '(:relative :back "foo") - :name "bar") + :directory '(:relative :back "foo") + :name "bar") #p"/aaa/bbb/ccc/ddd/eee") (#p"SCRATCH:ABSOLUTE;PATH;NAME.TYPE" #p"scratch:absolute;path;name" #p"/dir/default-name.type") @@ -265,23 +265,23 @@ ;; FIXME: test version handling in LPNs ) do (let ((result (apply #'merge-pathnames params))) - (macrolet ((frob (op) - `(assert (equal (,op result) (,op expected-result))))) - (frob pathname-host) - (frob pathname-directory) - (frob pathname-name) - (frob pathname-type)))) + (macrolet ((frob (op) + `(assert (equal (,op result) (,op expected-result))))) + (frob pathname-host) + (frob pathname-directory) + (frob pathname-name) + (frob pathname-type)))) ;;; host-namestring testing (assert (string= - (namestring (parse-namestring "/foo" (host-namestring #p"/bar"))) - "/foo")) + (namestring (parse-namestring "/foo" (host-namestring #p"/bar"))) + "/foo")) (assert (string= - (namestring (parse-namestring "FOO" (host-namestring #p"SCRATCH:BAR"))) - "SCRATCH:FOO")) + (namestring (parse-namestring "FOO" (host-namestring #p"SCRATCH:BAR"))) + "SCRATCH:FOO")) (assert (raises-error? - (setf (logical-pathname-translations "") - (list '("**;*.*.*" "/**/*.*"))))) + (setf (logical-pathname-translations "") + (list '("**;*.*.*" "/**/*.*"))))) ;;; Bug 200: translate-logical-pathname is according to the spec supposed ;;; not to give errors if asked to translate a namestring for a valid @@ -294,41 +294,41 @@ ;;; functions (they would cause memory protection errors). Make sure ;;; that those errors are gone: (assert (raises-error? (pathname (make-string-input-stream "FOO")) - type-error)) + type-error)) (assert (raises-error? (merge-pathnames (make-string-output-stream)) - type-error)) + type-error)) ;;; ensure read/print consistency (or print-not-readable-error) on ;;; pathnames: (let ((pathnames (list - (make-pathname :name "foo" :type "txt" :version :newest) - (make-pathname :name "foo" :type "txt" :version 1) - (make-pathname :name "foo" :type ".txt") - (make-pathname :name "foo." :type "txt") - (parse-namestring "SCRATCH:FOO.TXT.1") - (parse-namestring "SCRATCH:FOO.TXT.NEWEST") - (parse-namestring "SCRATCH:FOO.TXT")))) + (make-pathname :name "foo" :type "txt" :version :newest) + (make-pathname :name "foo" :type "txt" :version 1) + (make-pathname :name "foo" :type ".txt") + (make-pathname :name "foo." :type "txt") + (parse-namestring "SCRATCH:FOO.TXT.1") + (parse-namestring "SCRATCH:FOO.TXT.NEWEST") + (parse-namestring "SCRATCH:FOO.TXT")))) (dolist (p pathnames) (print p) (handler-case - (let ((*print-readably* t)) - (assert (equal (read-from-string (format nil "~S" p)) p))) + (let ((*print-readably* t)) + (assert (equal (read-from-string (format nil "~S" p)) p))) (print-not-readable () nil)))) ;;; BUG 330: "PARSE-NAMESTRING should accept namestrings as the ;;; default argument" ...and streams as well (assert (equal (parse-namestring "foo" nil "/") - (parse-namestring "foo" nil #P"/"))) + (parse-namestring "foo" nil #P"/"))) (let ((test "parse-namestring-test.tmp")) (unwind-protect (with-open-file (f test :direction :output) - ;; FIXME: This test is a bit flaky, since we only check that - ;; no error is signalled. The dilemma here is "what is the - ;; correct result when defaults is a _file_, not a - ;; directory". Currently (0.8.10.73) we get #P"foo" here (as - ;; opposed to eg. #P"/path/to/current/foo"), which is - ;; possibly mildly surprising but probably conformant. - (assert (parse-namestring "foo" nil f))) + ;; FIXME: This test is a bit flaky, since we only check that + ;; no error is signalled. The dilemma here is "what is the + ;; correct result when defaults is a _file_, not a + ;; directory". Currently (0.8.10.73) we get #P"foo" here (as + ;; opposed to eg. #P"/path/to/current/foo"), which is + ;; possibly mildly surprising but probably conformant. + (assert (parse-namestring "foo" nil f))) (when (probe-file test) (delete-file test)))) diff --git a/tests/pprint.impure.lisp b/tests/pprint.impure.lisp index 8c68a65..9c6fcee 100644 --- a/tests/pprint.impure.lisp +++ b/tests/pprint.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -16,7 +16,7 @@ ;;;; tests for former BUG 99, where pretty-printing was pretty messed ;;;; up, e.g. PPRINT-LOGICAL-BLOCK - because of CHECK-FOR-CIRCULARITY ;;;; - didn't really work: -;;;; "DESCRIBE interacts poorly with *PRINT-CIRCLE*, e.g. the output from +;;;; "DESCRIBE interacts poorly with *PRINT-CIRCLE*, e.g. the output from ;;;; (let ((*print-circle* t)) (describe (make-hash-table))) ;;;; is weird, [...] # is an . (EQL) ;;;; ..." @@ -97,50 +97,50 @@ ;;; bug 141b: not enough care taken to disambiguate ,.FOO and ,@FOO ;;; from , .FOO and , @FOO (assert (equal - (with-output-to-string (s) - (write '`(, .foo) :stream s :pretty t :readably t)) - "`(, .FOO)")) + (with-output-to-string (s) + (write '`(, .foo) :stream s :pretty t :readably t)) + "`(, .FOO)")) (assert (equal - (with-output-to-string (s) - (write '`(, @foo) :stream s :pretty t :readably t)) - "`(, @FOO)")) + (with-output-to-string (s) + (write '`(, @foo) :stream s :pretty t :readably t)) + "`(, @FOO)")) (assert (equal - (with-output-to-string (s) - (write '`(, ?foo) :stream s :pretty t :readably t)) - "`(,?FOO)")) + (with-output-to-string (s) + (write '`(, ?foo) :stream s :pretty t :readably t)) + "`(,?FOO)")) ;;; bug reported by Paul Dietz on sbcl-devel: unquoted lambda lists ;;; were leaking the SB-IMPL::BACKQ-COMMA implementation. (assert (equal - (with-output-to-string (s) - (write '`(foo ,x) :stream s :pretty t :readably t)) - "`(FOO ,X)")) + (with-output-to-string (s) + (write '`(foo ,x) :stream s :pretty t :readably t)) + "`(FOO ,X)")) (assert (equal - (with-output-to-string (s) - (write '`(foo ,@x) :stream s :pretty t :readably t)) - "`(FOO ,@X)")) -#+nil ; '`(foo ,.x) => '`(foo ,@x) apparently. + (with-output-to-string (s) + (write '`(foo ,@x) :stream s :pretty t :readably t)) + "`(FOO ,@X)")) +#+nil ; '`(foo ,.x) => '`(foo ,@x) apparently. (assert (equal - (with-output-to-string (s) - (write '`(foo ,.x) :stream s :pretty t :readably t)) - "`(FOO ,.X)")) + (with-output-to-string (s) + (write '`(foo ,.x) :stream s :pretty t :readably t)) + "`(FOO ,.X)")) (assert (equal - (with-output-to-string (s) - (write '`(lambda ,x) :stream s :pretty t :readably t)) - "`(LAMBDA ,X)")) + (with-output-to-string (s) + (write '`(lambda ,x) :stream s :pretty t :readably t)) + "`(LAMBDA ,X)")) (assert (equal - (with-output-to-string (s) - (write '`(lambda ,@x) :stream s :pretty t :readably t)) - "`(LAMBDA ,@X)")) + (with-output-to-string (s) + (write '`(lambda ,@x) :stream s :pretty t :readably t)) + "`(LAMBDA ,@X)")) #+nil ; see above (assert (equal - (with-output-to-string (s) - (write '`(lambda ,.x) :stream s :pretty t :readably t)) - "`(LAMBDA ,.X)")) + (with-output-to-string (s) + (write '`(lambda ,.x) :stream s :pretty t :readably t)) + "`(LAMBDA ,.X)")) (assert (equal - (with-output-to-string (s) - (write '`(lambda (,x)) :stream s :pretty t :readably t)) - "`(LAMBDA (,X))")) + (with-output-to-string (s) + (write '`(lambda (,x)) :stream s :pretty t :readably t)) + "`(LAMBDA (,X))")) ;;; more backquote printing brokenness, fixed quasi-randomly by CSR. ;;; NOTE KLUDGE FIXME: because our backquote optimizes at read-time, ;;; these assertions, like the ones above, are fragile. Likewise, it @@ -149,17 +149,17 @@ ;;; since the magical symbols are accessible though (car '`(,foo)) and ;;; friends. HATE HATE HATE. -- CSR, 2004-06-10 (assert (equal - (with-output-to-string (s) - (write '``(foo ,@',@bar) :stream s :pretty t)) - "``(FOO ,@',@BAR)")) + (with-output-to-string (s) + (write '``(foo ,@',@bar) :stream s :pretty t)) + "``(FOO ,@',@BAR)")) (assert (equal - (with-output-to-string (s) - (write '``(,,foo ,',foo foo) :stream s :pretty t)) - "``(,,FOO ,',FOO FOO)")) + (with-output-to-string (s) + (write '``(,,foo ,',foo foo) :stream s :pretty t)) + "``(,,FOO ,',FOO FOO)")) (assert (equal - (with-output-to-string (s) - (write '``(((,,foo) ,',foo) foo) :stream s :pretty t)) - "``(((,,FOO) ,',FOO) FOO)")) + (with-output-to-string (s) + (write '``(((,,foo) ,',foo) foo) :stream s :pretty t)) + "``(((,,FOO) ,',FOO) FOO)")) ;;; SET-PPRINT-DISPATCH should accept function name arguments, and not ;;; rush to coerce them to functions. @@ -167,32 +167,32 @@ (defun ppd-function-name (s o) (print (length o) s)) (let ((s (with-output-to-string (s) - (pprint '(frob a b) s)))) + (pprint '(frob a b) s)))) (assert (position #\3 s))) -;; Test that circularity detection works with pprint-logical-block +;; Test that circularity detection works with pprint-logical-block ;; (including when called through pprint-dispatch). (let ((*print-pretty* t) (*print-circle* t) (*print-pprint-dispatch* (copy-pprint-dispatch))) (labels ((pprint-a (stream form &rest rest) - (declare (ignore rest)) - (pprint-logical-block (stream form :prefix "<" :suffix ">") - (pprint-exit-if-list-exhausted) - (loop - (write (pprint-pop) :stream stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream))))) + (declare (ignore rest)) + (pprint-logical-block (stream form :prefix "<" :suffix ">") + (pprint-exit-if-list-exhausted) + (loop + (write (pprint-pop) :stream stream) + (pprint-exit-if-list-exhausted) + (write-char #\space stream))))) (set-pprint-dispatch '(cons (eql a)) #'pprint-a) (assert (string= "" - (with-output-to-string (s) - (write '(a 1 2 3) :stream s)))) + (with-output-to-string (s) + (write '(a 1 2 3) :stream s)))) (assert (string= "#1=" - (with-output-to-string (s) - (write '#2=(a 1 #2# #5=#(2) #5#) :stream s)))) + (with-output-to-string (s) + (write '#2=(a 1 #2# #5=#(2) #5#) :stream s)))) (assert (string= "#1=(B #2= #2#)" - (with-output-to-string (s) - (write '#3=(b #4=(a 1 #3# 2 3) #4#) :stream s)))))) + (with-output-to-string (s) + (write '#3=(b #4=(a 1 #3# 2 3) #4#) :stream s)))))) ;; Test that a circular improper list inside a logical block works. (let ((*print-circle* t) diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp index 2198269..a0f67bf 100644 --- a/tests/print.impure.lisp +++ b/tests/print.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -17,9 +17,9 @@ ;;; We should be able to output X readably (at least when *READ-EVAL*). (defun assert-readable-output (x) (assert (eql x - (let ((*read-eval* t)) - (read-from-string (with-output-to-string (s) - (write x :stream s :readably t))))))) + (let ((*read-eval* t)) + (read-from-string (with-output-to-string (s) + (write x :stream s :readably t))))))) ;;; Even when *READ-EVAL* is NIL, we should be able to output some ;;; (not necessarily readable) representation without signalling an @@ -27,7 +27,7 @@ (defun assert-unreadable-output (x) (let ((*read-eval* nil)) (with-output-to-string (s) (write x :stream s :readably nil)))) - + (defun assert-output (x) (assert-readable-output x) (assert-unreadable-output x)) @@ -35,11 +35,11 @@ ;;; Nathan Froyd reported that sbcl-0.6.11.34 screwed up output of ;;; floating point infinities. (dolist (x (list short-float-positive-infinity short-float-negative-infinity - single-float-positive-infinity single-float-negative-infinity - double-float-positive-infinity double-float-negative-infinity - long-float-positive-infinity long-float-negative-infinity)) + single-float-positive-infinity single-float-negative-infinity + double-float-positive-infinity double-float-negative-infinity + long-float-positive-infinity long-float-negative-infinity)) (assert-output x)) - + ;;; Eric Marsden reported that this would blow up in CMU CL (even ;;; though ANSI says that the mismatch between ~F expected type and ;;; provided string type is supposed to be handled without signalling @@ -51,7 +51,7 @@ (loop for base from 2 to 36 with *print-radix* = t do (let ((*print-base* base)) - (assert (string= "#*101" (format nil "~S" #*101))))) + (assert (string= "#*101" (format nil "~S" #*101))))) ;;; bug in sbcl-0.7.1.25, reported by DB sbcl-devel 2002-02-25 (assert (string= "0.5" (format nil "~2D" 0.5))) @@ -106,28 +106,28 @@ ;;; Check that arrays that we print while *PRINT-READABLY* is true are ;;; in fact generating similar objects. (assert (equal (array-dimensions - (read-from-string - (with-output-to-string (s) - (let ((*print-readably* t)) - (print (make-array '(1 2 0)) s))))) - '(1 2 0))) + (read-from-string + (with-output-to-string (s) + (let ((*print-readably* t)) + (print (make-array '(1 2 0)) s))))) + '(1 2 0))) (dolist (array (list (make-array '(1 0 1)) - (make-array 0 :element-type nil) - (make-array 1 :element-type 'base-char) - (make-array 1 :element-type 'character))) + (make-array 0 :element-type nil) + (make-array 1 :element-type 'base-char) + (make-array 1 :element-type 'character))) (assert (multiple-value-bind (result error) - (ignore-errors (read-from-string - (with-output-to-string (s) - (let ((*print-readably* t)) - (print array s))))) - ;; it might not be readably-printable - (or (typep error 'print-not-readable) - (and - ;; or else it had better have the same dimensions - (equal (array-dimensions result) (array-dimensions array)) - ;; and the same element-type - (equal (array-element-type result) (array-element-type array))))))) + (ignore-errors (read-from-string + (with-output-to-string (s) + (let ((*print-readably* t)) + (print array s))))) + ;; it might not be readably-printable + (or (typep error 'print-not-readable) + (and + ;; or else it had better have the same dimensions + (equal (array-dimensions result) (array-dimensions array)) + ;; and the same element-type + (equal (array-element-type result) (array-element-type array))))))) ;;; before 0.8.0.66 it signalled UNBOUND-VARIABLE (write #(1 2 3) :pretty nil :readably t) @@ -165,9 +165,9 @@ (wexercise-0-8-7-interpreted "~W") (wexercise-0-8-7-compiled-without-atsign)) (remove-method #'print-object - (find-method #'print-object - '(:before) - (mapcar #'find-class '(wexerciser-0-8-7 t)))) + (find-method #'print-object + '(:before) + (mapcar #'find-class '(wexerciser-0-8-7 t)))) (defmethod print-object :before ((wexerciser-0-8-7 wexerciser-0-8-7) stream) (when (or *print-level* *print-length*) (error "gotcha going"))) @@ -182,7 +182,7 @@ (defpackage "SCRATCH-WRITE-TO-STRING" (:use)) (with-standard-io-syntax (let* ((*package* (find-package "SCRATCH-WRITE-TO-STRING")) - (answer (write-to-string 'scratch-write-to-string::x :readably nil))) + (answer (write-to-string 'scratch-write-to-string::x :readably nil))) (assert (string= answer "X")))) ;;; and a couple from Bruno Haible (defun my-pprint-reverse (out list) @@ -228,15 +228,15 @@ (let ((x1 (float -5496527/100000000000000000)) (x2 (float -54965272/1000000000000000000))) (assert (or (equal (multiple-value-list (integer-decode-float x1)) - (multiple-value-list (integer-decode-float x2))) - (string/= (prin1-to-string x1) (prin1-to-string x2))))) + (multiple-value-list (integer-decode-float x2))) + (string/= (prin1-to-string x1) (prin1-to-string x2))))) ;;; readable printing of arrays with *print-radix* t -(let ((*print-radix* t) +(let ((*print-radix* t) (*print-readably* t) (*print-pretty* nil)) (let ((output (with-output-to-string (s) - (write #2a((t t) (nil nil)) :stream s)))) + (write #2a((t t) (nil nil)) :stream s)))) (assert (equalp (read-from-string output) #2a((t t) (nil nil)))))) ;;; NIL parameters to "interpreted" FORMAT directives @@ -245,7 +245,7 @@ ;;; PRINC-TO-STRING should bind print-readably (let ((*print-readably* t)) (assert (string= (princ-to-string #\7) - (write-to-string #\7 :escape nil :readably nil)))) + (write-to-string #\7 :escape nil :readably nil)))) ;;; in FORMAT, ~^ inside ~:{ should go to the next case, not break ;;; iteration, even if one argument is just a one-element list. @@ -301,7 +301,7 @@ (incf *read-base*)) (assert (not (eql r (read-from-string (prin1-to-string r))))) (let ((*print-radix* t)) - (assert (= r (read-from-string + (assert (= r (read-from-string (princ-to-string r))))))))) (write-char #\.) (finish-output))) diff --git a/tests/properties.impure.lisp b/tests/properties.impure.lisp index bec65f0..bdfa8bc 100644 --- a/tests/properties.impure.lisp +++ b/tests/properties.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. diff --git a/tests/pure.lisp b/tests/pure.lisp index 25140bf..ba80ac3 100644 --- a/tests/pure.lisp +++ b/tests/pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. diff --git a/tests/reader.impure.lisp b/tests/reader.impure.lisp index 1d90ae1..3a9507a 100644 --- a/tests/reader.impure.lisp +++ b/tests/reader.impure.lisp @@ -8,7 +8,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -81,7 +81,7 @@ ;;; reported by Henrik Motakef (defpackage "") (assert (eq (symbol-package (read-from-string "||::FOO")) - (find-package ""))) + (find-package ""))) ;;; test nested reads, test case by Helmut Eller for cmucl (defclass my-in-stream (sb-gray:fundamental-character-input-stream) @@ -93,8 +93,8 @@ (with-input-from-string (s "b") (read s)) (with-slots (last-char) s (cond (last-char (prog1 last-char (setf last-char nil))) - (t (prog1 (aref string i) - (setq i (mod (1+ i) (length string))))))))) + (t (prog1 (aref string i) + (setq i (mod (1+ i) (length string))))))))) (defmethod sb-gray:stream-unread-char ((s my-in-stream) char) (setf (slot-value s 'last-char) char) diff --git a/tests/reader.pure.lisp b/tests/reader.pure.lisp index 0d22933..ed9743a 100644 --- a/tests/reader.pure.lisp +++ b/tests/reader.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -38,9 +38,9 @@ ;;; GET-DISPATCH-MACRO misbehavior fixed in sbcl-0.7.2.10, but ;;; was fixed a little later.) (dolist (customizable-char - ;; According to ANSI "2.1.4 Character Syntax Types", these - ;; characters are reserved for the programmer. - '(#\? #\! #\[ #\] #\{ #\})) + ;; According to ANSI "2.1.4 Character Syntax Types", these + ;; characters are reserved for the programmer. + '(#\? #\! #\[ #\] #\{ #\})) ;; So they should have no macro-characterness. (multiple-value-bind (macro-fun non-terminating-p) (get-macro-character customizable-char) @@ -63,10 +63,10 @@ ;;; PARSE-INTEGER must signal an error of type PARSE-ERROR if it is ;;; unable to parse an integer and :JUNK-ALLOWED is NIL. (macrolet ((assert-parse-error (form) - `(multiple-value-bind (val cond) - (ignore-errors ,form) - (assert (null val)) - (assert (typep cond 'parse-error))))) + `(multiple-value-bind (val cond) + (ignore-errors ,form) + (assert (null val)) + (assert (typep cond 'parse-error))))) (assert-parse-error (parse-integer " ")) (assert-parse-error (parse-integer "12 a")) (assert-parse-error (parse-integer "12a")) @@ -78,11 +78,11 @@ ;;; #A notation enforces that once one 0 dimension has been found, all ;;; subsequent ones are also 0. (assert (equal (array-dimensions (read-from-string "#3A()")) - '(0 0 0))) + '(0 0 0))) (assert (equal (array-dimensions (read-from-string "#3A(())")) - '(1 0 0))) + '(1 0 0))) (assert (equal (array-dimensions (read-from-string "#3A((() ()))")) - '(1 2 0))) + '(1 2 0))) ;;; Bug reported by Nikodemus Siivola on sbcl-devel 2003-07-21: ;;; package misconfiguration @@ -110,86 +110,86 @@ (let ((*read-base* *read-base*)) (dolist (float-string '(".9" ".9e9" ".9e+9" ".9e-9" - "-.9" "-.9e9" "-.9e+9" "-.9e-9" - "+.9" "+.9e9" "+.9e+9" "+.9e-9" - "0.9" "0.9e9" "0.9e+9" "0.9e-9" - "9.09" "9.09e9" "9.09e+9" "9.09e-9" - #|"9e9" could be integer|# "9e+9" "9e-9")) + "-.9" "-.9e9" "-.9e+9" "-.9e-9" + "+.9" "+.9e9" "+.9e+9" "+.9e-9" + "0.9" "0.9e9" "0.9e+9" "0.9e-9" + "9.09" "9.09e9" "9.09e+9" "9.09e-9" + #|"9e9" could be integer|# "9e+9" "9e-9")) (loop for i from 2 to 36 - do (setq *read-base* i) - do (assert (typep (read-from-string float-string) - *read-default-float-format*)) - do (assert (typep - (read-from-string (substitute #\E #\e float-string)) - *read-default-float-format*)) - if (position #\e float-string) - do (assert (typep - (read-from-string (substitute #\s #\e float-string)) - 'short-float)) - and do (assert (typep - (read-from-string (substitute #\S #\e float-string)) - 'short-float)) - and do (assert (typep - (read-from-string (substitute #\f #\e float-string)) - 'single-float)) - and do (assert (typep - (read-from-string (substitute #\F #\e float-string)) - 'single-float)) - and do (assert (typep - (read-from-string (substitute #\d #\e float-string)) - 'double-float)) - and do (assert (typep - (read-from-string (substitute #\D #\e float-string)) - 'double-float)) - and do (assert (typep - (read-from-string (substitute #\l #\e float-string)) - 'long-float)) - and do (assert (typep - (read-from-string (substitute #\L #\e float-string)) - 'long-float))))) + do (setq *read-base* i) + do (assert (typep (read-from-string float-string) + *read-default-float-format*)) + do (assert (typep + (read-from-string (substitute #\E #\e float-string)) + *read-default-float-format*)) + if (position #\e float-string) + do (assert (typep + (read-from-string (substitute #\s #\e float-string)) + 'short-float)) + and do (assert (typep + (read-from-string (substitute #\S #\e float-string)) + 'short-float)) + and do (assert (typep + (read-from-string (substitute #\f #\e float-string)) + 'single-float)) + and do (assert (typep + (read-from-string (substitute #\F #\e float-string)) + 'single-float)) + and do (assert (typep + (read-from-string (substitute #\d #\e float-string)) + 'double-float)) + and do (assert (typep + (read-from-string (substitute #\D #\e float-string)) + 'double-float)) + and do (assert (typep + (read-from-string (substitute #\l #\e float-string)) + 'long-float)) + and do (assert (typep + (read-from-string (substitute #\L #\e float-string)) + 'long-float))))) (let ((*read-base* *read-base*)) (dolist (integer-string '("1." "2." "3." "4." "5." "6." "7." "8." "9." "0.")) (loop for i from 2 to 36 - do (setq *read-base* i) - do (assert (typep (read-from-string integer-string) 'integer))))) + do (setq *read-base* i) + do (assert (typep (read-from-string integer-string) 'integer))))) (let ((*read-base* *read-base*)) (dolist (symbol-string '("A." "a." "Z." "z." - - "+.9eA" "+.9ea" - - "0.A" "0.a" "0.Z" "0.z" - #|"9eA" "9ea"|# "9e+A" "9e+a" "9e-A" "9e-a" - #|"Ae9" "ae9"|# "Ae+9" "ae+9" "Ae-9" "ae-9" + "+.9eA" "+.9ea" + + "0.A" "0.a" "0.Z" "0.z" + + #|"9eA" "9ea"|# "9e+A" "9e+a" "9e-A" "9e-a" + #|"Ae9" "ae9"|# "Ae+9" "ae+9" "Ae-9" "ae-9" - "ee+9" "Ee+9" "eE+9" "EE+9" - "ee-9" "Ee-9" "eE-9" "EE-9" + "ee+9" "Ee+9" "eE+9" "EE+9" + "ee-9" "Ee-9" "eE-9" "EE-9" - "A.0" "A.0e10" "a.0" "a.0e10" + "A.0" "A.0e10" "a.0" "a.0e10" - "1e1e+9")) + "1e1e+9")) (loop for i from 2 to 36 - do (setq *read-base* i) - do (assert (typep (read-from-string symbol-string) 'symbol))))) + do (setq *read-base* i) + do (assert (typep (read-from-string symbol-string) 'symbol))))) (let ((standard-chars " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~ ") (standard-terminating-macro-chars "\"'(),;`") (standard-nonterminating-macro-chars "#")) (flet ((frob (char) - (multiple-value-bind (fun non-terminating-p) - (get-macro-character char) - (cond - ((find char standard-terminating-macro-chars) - (unless (and fun (not non-terminating-p)) - (list char))) - ((find char standard-nonterminating-macro-chars) - (unless (and fun non-terminating-p) - (list char))) - (t (unless (and (not fun) (not non-terminating-p)) - (list char))))))) + (multiple-value-bind (fun non-terminating-p) + (get-macro-character char) + (cond + ((find char standard-terminating-macro-chars) + (unless (and fun (not non-terminating-p)) + (list char))) + ((find char standard-nonterminating-macro-chars) + (unless (and fun non-terminating-p) + (list char))) + (t (unless (and (not fun) (not non-terminating-p)) + (list char))))))) (let ((*readtable* (copy-readtable nil))) (assert (null (loop for c across standard-chars append (frob c))))))) @@ -197,14 +197,14 @@ ") (undefined-chars "!\"$%&,;>?@[]^_`~{}/dDeEfFgGhHiIjJkKlLmMnNqQtTuUvVwWyYzZ")) (flet ((frob (char) - (let ((fun (get-dispatch-macro-character #\# char))) - (cond - ((find char undefined-chars) - (when fun (list char))) - ((digit-char-p char 10) - (when fun (list char))) - (t - (unless fun (list char))))))) + (let ((fun (get-dispatch-macro-character #\# char))) + (cond + ((find char undefined-chars) + (when fun (list char))) + ((digit-char-p char 10) + (when fun (list char))) + (t + (unless fun (list char))))))) (let ((*readtable* (copy-readtable nil))) (assert (null (loop for c across standard-chars append (frob c))))))) @@ -226,5 +226,5 @@ (assert (typep err 'end-of-file))) (assert (equal '((0 . "A") (1 . "B")) - (coerce (read-from-string "#((0 . \"A\") (1 . \"B\"))") + (coerce (read-from-string "#((0 . \"A\") (1 . \"B\"))") 'list))) diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index acb8dab..52b8b13 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -8,7 +8,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -24,71 +24,71 @@ ;;; specialized types, and in many different optimization scenarios (defun for-every-seq-1 (base-seq snippet) (dolist (seq-type '(list - (simple-array t 1) - (vector t) - (simple-array character 1) - (vector character) - (simple-array (signed-byte 4) 1) - (vector (signed-byte 4)))) + (simple-array t 1) + (vector t) + (simple-array character 1) + (vector character) + (simple-array (signed-byte 4) 1) + (vector (signed-byte 4)))) (flet ((entirely (eltype) - (every (lambda (el) (typep el eltype)) base-seq))) + (every (lambda (el) (typep el eltype)) base-seq))) (dolist (declaredness '(nil t)) - (dolist (optimization '(((speed 3) (space 0)) - ((speed 2) (space 2)) - ((speed 1) (space 2)) - ((speed 0) (space 1)))) - (let* ((seq (if (eq seq-type 'list) - (coerce base-seq 'list) - (destructuring-bind (type-first &rest type-rest) - seq-type - (ecase type-first - (simple-array - (destructuring-bind (eltype one) type-rest - (assert (= one 1)) - (if (entirely eltype) - (coerce base-seq seq-type) - (return)))) - (vector - (destructuring-bind (eltype) type-rest - (if (entirely eltype) - (let ((initial-element - (cond ((subtypep eltype 'character) - #\!) - ((subtypep eltype 'number) - 0) - (t #'error)))) - (replace (make-array - (+ (length base-seq) - (random 3)) - :element-type eltype - :fill-pointer - (length base-seq) - :initial-element - initial-element) - base-seq)) - (return)))))))) - (lambda-expr `(lambda (seq) - ,@(when declaredness - `((declare (type ,seq-type seq)))) - (declare (optimize ,@optimization)) - ,snippet))) - (format t "~&~S~%" lambda-expr) - (multiple-value-bind (fun warnings-p failure-p) - (compile nil lambda-expr) - (when (or warnings-p failure-p) - (error "~@" - lambda-expr warnings-p failure-p)) - (format t "~&~S ~S~%~S~%~S ~S~%" - base-seq snippet seq-type declaredness optimization) - (format t "~&(TYPEP SEQ 'SIMPLE-ARRAY)=~S~%" - (typep seq 'simple-array)) - (unless (funcall fun seq) - (error "~@" - base-seq - snippet - seq-type - declaredness - optimization))))))))) + (dolist (optimization '(((speed 3) (space 0)) + ((speed 2) (space 2)) + ((speed 1) (space 2)) + ((speed 0) (space 1)))) + (let* ((seq (if (eq seq-type 'list) + (coerce base-seq 'list) + (destructuring-bind (type-first &rest type-rest) + seq-type + (ecase type-first + (simple-array + (destructuring-bind (eltype one) type-rest + (assert (= one 1)) + (if (entirely eltype) + (coerce base-seq seq-type) + (return)))) + (vector + (destructuring-bind (eltype) type-rest + (if (entirely eltype) + (let ((initial-element + (cond ((subtypep eltype 'character) + #\!) + ((subtypep eltype 'number) + 0) + (t #'error)))) + (replace (make-array + (+ (length base-seq) + (random 3)) + :element-type eltype + :fill-pointer + (length base-seq) + :initial-element + initial-element) + base-seq)) + (return)))))))) + (lambda-expr `(lambda (seq) + ,@(when declaredness + `((declare (type ,seq-type seq)))) + (declare (optimize ,@optimization)) + ,snippet))) + (format t "~&~S~%" lambda-expr) + (multiple-value-bind (fun warnings-p failure-p) + (compile nil lambda-expr) + (when (or warnings-p failure-p) + (error "~@" + lambda-expr warnings-p failure-p)) + (format t "~&~S ~S~%~S~%~S ~S~%" + base-seq snippet seq-type declaredness optimization) + (format t "~&(TYPEP SEQ 'SIMPLE-ARRAY)=~S~%" + (typep seq 'simple-array)) + (unless (funcall fun seq) + (error "~@" + base-seq + snippet + seq-type + declaredness + optimization))))))))) (defun for-every-seq (base-seq snippets) (dolist (snippet snippets) (for-every-seq-1 base-seq snippet))) @@ -98,15 +98,15 @@ ;;; (POSITION 1 #() :KEY #'ABS) when #() has been coerced to a string. (defun indiscriminate (fun) (lambda (&rest rest) (apply fun rest))) - + ;;; asymmetric test arg order example from ANSI FIND definition page (assert (eql #\space ; original example, depends on ASCII character ordering - (find #\d "here are some letters that can be looked at" - :test #'char>))) + (find #\d "here are some letters that can be looked at" + :test #'char>))) (assert (eql #\e ; modified example, depends only on standard a-z ordering - (find #\f "herearesomeletters" :test #'char>))) + (find #\f "herearesomeletters" :test #'char>))) (assert (eql 4 ; modified more, avoids charset technicalities completely - (find 5 '(6 4) :test '>))) + (find 5 '(6 4) :test '>))) ;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for ;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too) @@ -179,11 +179,11 @@ (find-if #'characterp seq) (find-if (lambda (c) (typep c 'base-char)) seq :from-end t) (null (find-if 'upper-case-p seq)))) - + ;;; SUBSEQ (let ((avec (make-array 10 - :fill-pointer 4 - :initial-contents '(0 1 2 3 iv v vi vii iix ix)))) + :fill-pointer 4 + :initial-contents '(0 1 2 3 iv v vi vii iix ix)))) ;; These first five always worked AFAIK. (assert (equalp (subseq avec 0 3) #(0 1 2))) (assert (equalp (subseq avec 3 3) #())) @@ -215,14 +215,14 @@ ;;; MAKE-SEQUENCE, COERCE, CONCATENATE, MERGE, MAP and requested ;;; result type (BUGs 46a, 46b, 66) (macrolet ((assert-type-error (form) - `(assert (typep (nth-value 1 (ignore-errors ,form)) - 'type-error)))) - (dolist (type-stub '((simple-vector) - (vector *) - (vector (signed-byte 8)) - (vector (unsigned-byte 16)) - (vector (signed-byte 32)) - (simple-bit-vector))) + `(assert (typep (nth-value 1 (ignore-errors ,form)) + 'type-error)))) + (dolist (type-stub '((simple-vector) + (vector *) + (vector (signed-byte 8)) + (vector (unsigned-byte 16)) + (vector (signed-byte 32)) + (simple-bit-vector))) (declare (optimize safety)) (format t "~&~S~%" type-stub) ;; MAKE-SEQUENCE @@ -236,30 +236,30 @@ ;; CONCATENATE (assert (= (length (concatenate `(,@type-stub) #(0 0 0) #*111)) 6)) (assert (equalp (concatenate `(,@type-stub) #(0 0 0) #*111) - (coerce #(0 0 0 1 1 1) `(,@type-stub)))) + (coerce #(0 0 0 1 1 1) `(,@type-stub)))) (assert (= (length (concatenate `(,@type-stub 6) #(0 0 0) #*111)) 6)) (assert (equalp (concatenate `(,@type-stub 6) #(0 0 0) #*111) - (coerce #(0 0 0 1 1 1) `(,@type-stub 6)))) + (coerce #(0 0 0 1 1 1) `(,@type-stub 6)))) (assert-type-error (concatenate `(,@type-stub 5) #(0 0 0) #*111)) ;; MERGE (assert (= (length (merge `(,@type-stub) #(0 1 0) #*111 #'>)) 6)) (assert (equalp (merge `(,@type-stub) #(0 1 0) #*111 #'>) - (coerce #(1 1 1 0 1 0) `(,@type-stub)))) + (coerce #(1 1 1 0 1 0) `(,@type-stub)))) (assert (= (length (merge `(,@type-stub 6) #(0 1 0) #*111 #'>)) 6)) (assert (equalp (merge `(,@type-stub 6) #(0 1 0) #*111 #'>) - (coerce #(1 1 1 0 1 0) `(,@type-stub 6)))) + (coerce #(1 1 1 0 1 0) `(,@type-stub 6)))) (assert-type-error (merge `(,@type-stub 4) #(0 1 0) #*111 #'>)) ;; MAP (assert (= (length (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1))) 4)) (assert (equalp (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1)) - (coerce #(0 1 1 0) `(,@type-stub)))) - (assert (= (length (map `(,@type-stub 4) #'logxor #(0 0 1 1) '(0 1 0 1))) - 4)) + (coerce #(0 1 1 0) `(,@type-stub)))) + (assert (= (length (map `(,@type-stub 4) #'logxor #(0 0 1 1) '(0 1 0 1))) + 4)) (assert (equalp (map `(,@type-stub 4) #'logxor #(0 0 1 1) '(0 1 0 1)) - (coerce #(0 1 1 0) `(,@type-stub 4)))) + (coerce #(0 1 1 0) `(,@type-stub 4)))) (assert-type-error (map `(,@type-stub 5) #'logxor #(0 0 1 1) '(0 1 0 1)))) ;; some more CONCATENATE tests for strings - (locally + (locally (declare (optimize safety)) (assert (string= (concatenate 'string "foo" " " "bar") "foo bar")) (assert (string= (concatenate '(string 7) "foo" " " "bar") "foo bar")) @@ -272,7 +272,7 @@ (assert-type-error (concatenate 'simple-array "foo" "bar")) (assert-type-error (map 'simple-array #'identity '(1 2 3))) (assert (equalp #(11 13) - (map '(simple-array fixnum (*)) #'+ '(1 2 3) '(10 11)))) + (map '(simple-array fixnum (*)) #'+ '(1 2 3) '(10 11)))) (assert-type-error (coerce '(1 2 3) 'simple-array)) (assert-type-error (merge 'simple-array '(1 3) '(2 4) '<)) (assert (equalp #(3 2 1) (coerce '(3 2 1) '(vector fixnum)))) @@ -294,8 +294,8 @@ ;;; but wait, there's more! The NULL and CONS types also have implicit ;;; length requirements: (macrolet ((assert-type-error (form) - `(assert (typep (nth-value 1 (ignore-errors ,form)) - 'type-error)))) + `(assert (typep (nth-value 1 (ignore-errors ,form)) + 'type-error)))) (locally (declare (optimize safety)) ;; MAKE-SEQUENCE @@ -327,7 +327,7 @@ (assert (null (merge 'null () () '<))) (assert (= (length (merge 'cons '(1 3) '(2 4) '<)) 4)) (assert (= (length (merge '(cons t (cons t (cons t (cons t null)))) - '(1 3) '(2 4) '<)) 4)) + '(1 3) '(2 4) '<)) 4)) (assert-type-error (merge 'nil () () '<)) ;; CONCATENATE (assert-type-error (concatenate 'null '(1) "2")) @@ -367,40 +367,40 @@ ;; See Issues 332 [and 333(!)] in the CLHS (declare (optimize (safety 3))) (let ((string (make-array 10 - :fill-pointer 5 - :initial-element #\a - :element-type 'base-char))) - ,(car body) - (format t "... BASE-CHAR") - (finish-output) - (flet ((reset () - (setf (fill-pointer string) 10) - (fill string #\a) - (setf (fill-pointer string) 5))) - (declare (ignorable #'reset)) - ,@(cdr body)))) + :fill-pointer 5 + :initial-element #\a + :element-type 'base-char))) + ,(car body) + (format t "... BASE-CHAR") + (finish-output) + (flet ((reset () + (setf (fill-pointer string) 10) + (fill string #\a) + (setf (fill-pointer string) 5))) + (declare (ignorable #'reset)) + ,@(cdr body)))) (locally ;; See Issues 332 [and 333(!)] in the CLHS (declare (optimize (safety 3))) (let ((string (make-array 10 - :fill-pointer 5 - :initial-element #\a - :element-type 'character))) - ,(car body) - (format t "... CHARACTER") - (finish-output) + :fill-pointer 5 + :initial-element #\a + :element-type 'character))) + ,(car body) + (format t "... CHARACTER") + (finish-output) (flet ((reset () - (setf (fill-pointer string) 10) - (fill string #\a) - (setf (fill-pointer string) 5))) - (declare (ignorable #'reset)) - ,@(cdr body)))))) + (setf (fill-pointer string) 10) + (fill string #\a) + (setf (fill-pointer string) 5))) + (declare (ignorable #'reset)) + ,@(cdr body)))))) (declaim (notinline opaque-identity)) (defun opaque-identity (x) x) ;;; Accessor SUBSEQ (sequence-bounding-indices-test - (format t "~&/Accessor SUBSEQ") + (format t "~&/Accessor SUBSEQ") (assert (string= (subseq string 0 5) "aaaaa")) (assert (raises-error? (subseq string 0 6))) (assert (raises-error? (subseq string (opaque-identity -1) 5))) @@ -416,7 +416,7 @@ ;;; Function COUNT, COUNT-IF, COUNT-IF-NOT (sequence-bounding-indices-test - (format t "~&/Function COUNT, COUNT-IF, COUNT-IF-NOT") + (format t "~&/Function COUNT, COUNT-IF, COUNT-IF-NOT") (assert (= (count #\a string :start 0 :end nil) 5)) (assert (= (count #\a string :start 0 :end 5) 5)) (assert (raises-error? (count #\a string :start 0 :end 6))) @@ -426,27 +426,27 @@ (assert (= (count-if #'alpha-char-p string :start 0 :end nil) 5)) (assert (= (count-if #'alpha-char-p string :start 0 :end 5) 5)) (assert (raises-error? - (count-if #'alpha-char-p string :start 0 :end 6))) + (count-if #'alpha-char-p string :start 0 :end 6))) (assert (raises-error? - (count-if #'alpha-char-p string :start (opaque-identity -1) :end 5))) + (count-if #'alpha-char-p string :start (opaque-identity -1) :end 5))) (assert (raises-error? - (count-if #'alpha-char-p string :start 4 :end 2))) + (count-if #'alpha-char-p string :start 4 :end 2))) (assert (raises-error? - (count-if #'alpha-char-p string :start 6 :end 9))) + (count-if #'alpha-char-p string :start 6 :end 9))) (assert (= (count-if-not #'alpha-char-p string :start 0 :end nil) 0)) (assert (= (count-if-not #'alpha-char-p string :start 0 :end 5) 0)) (assert (raises-error? - (count-if-not #'alpha-char-p string :start 0 :end 6))) + (count-if-not #'alpha-char-p string :start 0 :end 6))) (assert (raises-error? - (count-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5))) + (count-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5))) (assert (raises-error? - (count-if-not #'alpha-char-p string :start 4 :end 2))) + (count-if-not #'alpha-char-p string :start 4 :end 2))) (assert (raises-error? - (count-if-not #'alpha-char-p string :start 6 :end 9)))) + (count-if-not #'alpha-char-p string :start 6 :end 9)))) ;;; Function FILL (sequence-bounding-indices-test - (format t "~&/Function FILL") + (format t "~&/Function FILL") (assert (string= (fill string #\b :start 0 :end 5) "bbbbb")) (assert (string= (fill string #\c :start 0 :end nil) "ccccc")) (assert (raises-error? (fill string #\d :start 0 :end 6))) @@ -456,7 +456,7 @@ ;;; Function FIND, FIND-IF, FIND-IF-NOT (sequence-bounding-indices-test - (format t "~&/Function FIND, FIND-IF, FIND-IF-NOT") + (format t "~&/Function FIND, FIND-IF, FIND-IF-NOT") (assert (char= (find #\a string :start 0 :end nil) #\a)) (assert (char= (find #\a string :start 0 :end 5) #\a)) (assert (raises-error? (find #\a string :start 0 :end 6))) @@ -466,27 +466,27 @@ (assert (char= (find-if #'alpha-char-p string :start 0 :end nil) #\a)) (assert (char= (find-if #'alpha-char-p string :start 0 :end 5) #\a)) (assert (raises-error? - (find-if #'alpha-char-p string :start 0 :end 6))) + (find-if #'alpha-char-p string :start 0 :end 6))) (assert (raises-error? - (find-if #'alpha-char-p string :start (opaque-identity -1) :end 5))) + (find-if #'alpha-char-p string :start (opaque-identity -1) :end 5))) (assert (raises-error? - (find-if #'alpha-char-p string :start 4 :end 2))) + (find-if #'alpha-char-p string :start 4 :end 2))) (assert (raises-error? - (find-if #'alpha-char-p string :start 6 :end 9))) + (find-if #'alpha-char-p string :start 6 :end 9))) (assert (eq (find-if-not #'alpha-char-p string :start 0 :end nil) nil)) (assert (eq (find-if-not #'alpha-char-p string :start 0 :end 5) nil)) (assert (raises-error? - (find-if-not #'alpha-char-p string :start 0 :end 6))) + (find-if-not #'alpha-char-p string :start 0 :end 6))) (assert (raises-error? - (find-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5))) + (find-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5))) (assert (raises-error? - (find-if-not #'alpha-char-p string :start 4 :end 2))) + (find-if-not #'alpha-char-p string :start 4 :end 2))) (assert (raises-error? - (find-if-not #'alpha-char-p string :start 6 :end 9)))) + (find-if-not #'alpha-char-p string :start 6 :end 9)))) ;;; Function MISMATCH (sequence-bounding-indices-test - (format t "~&/Function MISMATCH") + (format t "~&/Function MISMATCH") (assert (null (mismatch string "aaaaa" :start1 0 :end1 nil))) (assert (= (mismatch "aaab" string :start2 0 :end2 4) 3)) (assert (raises-error? (mismatch "aaaaaa" string :start2 0 :end2 6))) @@ -496,7 +496,7 @@ ;;; Function PARSE-INTEGER (sequence-bounding-indices-test - (format t "~&/Function PARSE-INTEGER") + (format t "~&/Function PARSE-INTEGER") (setf (fill-pointer string) 10) (setf (subseq string 0 10) "1234567890") (setf (fill-pointer string) 5) @@ -509,31 +509,31 @@ ;;; Function PARSE-NAMESTRING (sequence-bounding-indices-test - (format t "~&/Function PARSE-NAMESTRING") + (format t "~&/Function PARSE-NAMESTRING") (setf (fill-pointer string) 10) (setf (subseq string 0 10) "/dev/ /tmp") (setf (fill-pointer string) 5) (assert (truename (parse-namestring string nil *default-pathname-defaults* - :start 0 :end 5))) + :start 0 :end 5))) (assert (truename (parse-namestring string nil *default-pathname-defaults* - :start 0 :end nil))) + :start 0 :end nil))) (assert (raises-error? (parse-namestring string nil - *default-pathname-defaults* - :start 0 :end 6))) + *default-pathname-defaults* + :start 0 :end 6))) (assert (raises-error? (parse-namestring string nil - *default-pathname-defaults* - :start (opaque-identity -1) :end 5))) + *default-pathname-defaults* + :start (opaque-identity -1) :end 5))) (assert (raises-error? (parse-namestring string nil - *default-pathname-defaults* - :start 4 :end 2))) + *default-pathname-defaults* + :start 4 :end 2))) (assert (raises-error? (parse-namestring string nil - *default-pathname-defaults* - :start 6 :end 9)))) + *default-pathname-defaults* + :start 6 :end 9)))) ;;; Function POSITION, POSITION-IF, POSITION-IF-NOT (sequence-bounding-indices-test (format t "~&/Function POSITION, POSITION-IF, POSITION-IF-NOT") - + (assert (= (position #\a string :start 0 :end nil) 0)) (assert (= (position #\a string :start 0 :end 5) 0)) (assert (raises-error? (position #\a string :start 0 :end 6))) @@ -543,27 +543,27 @@ (assert (= (position-if #'alpha-char-p string :start 0 :end nil) 0)) (assert (= (position-if #'alpha-char-p string :start 0 :end 5) 0)) (assert (raises-error? - (position-if #'alpha-char-p string :start 0 :end 6))) + (position-if #'alpha-char-p string :start 0 :end 6))) (assert (raises-error? - (position-if #'alpha-char-p string :start (opaque-identity -1) :end 5))) + (position-if #'alpha-char-p string :start (opaque-identity -1) :end 5))) (assert (raises-error? - (position-if #'alpha-char-p string :start 4 :end 2))) + (position-if #'alpha-char-p string :start 4 :end 2))) (assert (raises-error? - (position-if #'alpha-char-p string :start 6 :end 9))) + (position-if #'alpha-char-p string :start 6 :end 9))) (assert (eq (position-if-not #'alpha-char-p string :start 0 :end nil) nil)) (assert (eq (position-if-not #'alpha-char-p string :start 0 :end 5) nil)) (assert (raises-error? - (position-if-not #'alpha-char-p string :start 0 :end 6))) + (position-if-not #'alpha-char-p string :start 0 :end 6))) (assert (raises-error? - (position-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5))) + (position-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5))) (assert (raises-error? - (position-if-not #'alpha-char-p string :start 4 :end 2))) + (position-if-not #'alpha-char-p string :start 4 :end 2))) (assert (raises-error? - (position-if-not #'alpha-char-p string :start 6 :end 9)))) + (position-if-not #'alpha-char-p string :start 6 :end 9)))) ;;; Function READ-FROM-STRING (sequence-bounding-indices-test - (format t "~&/Function READ-FROM-STRING") + (format t "~&/Function READ-FROM-STRING") (setf (subseq string 0 5) "(a b)") (assert (equal (read-from-string string nil nil :start 0 :end 5) '(a b))) (assert (equal (read-from-string string nil nil :start 0 :end nil) '(a b))) @@ -574,12 +574,12 @@ ;;; Function REDUCE (sequence-bounding-indices-test - (format t "~&/Function REDUCE") + (format t "~&/Function REDUCE") (setf (subseq string 0 5) "abcde") (assert (equal (reduce #'list* string :from-end t :start 0 :end nil) - '(#\a #\b #\c #\d . #\e))) + '(#\a #\b #\c #\d . #\e))) (assert (equal (reduce #'list* string :from-end t :start 0 :end 5) - '(#\a #\b #\c #\d . #\e))) + '(#\a #\b #\c #\d . #\e))) (assert (raises-error? (reduce #'list* string :start 0 :end 6))) (assert (raises-error? (reduce #'list* string :start (opaque-identity -1) :end 5))) (assert (raises-error? (reduce #'list* string :start 4 :end 2))) @@ -588,7 +588,7 @@ ;;; Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, DELETE, DELETE-IF, ;;; DELETE-IF-NOT (sequence-bounding-indices-test - (format t "~&/Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, ...") + (format t "~&/Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, ...") (assert (equal (remove #\a string :start 0 :end nil) "")) (assert (equal (remove #\a string :start 0 :end 5) "")) (assert (raises-error? (remove #\a string :start 0 :end 6))) @@ -598,27 +598,27 @@ (assert (equal (remove-if #'alpha-char-p string :start 0 :end nil) "")) (assert (equal (remove-if #'alpha-char-p string :start 0 :end 5) "")) (assert (raises-error? - (remove-if #'alpha-char-p string :start 0 :end 6))) + (remove-if #'alpha-char-p string :start 0 :end 6))) (assert (raises-error? - (remove-if #'alpha-char-p string :start (opaque-identity -1) :end 5))) + (remove-if #'alpha-char-p string :start (opaque-identity -1) :end 5))) (assert (raises-error? - (remove-if #'alpha-char-p string :start 4 :end 2))) + (remove-if #'alpha-char-p string :start 4 :end 2))) (assert (raises-error? - (remove-if #'alpha-char-p string :start 6 :end 9))) + (remove-if #'alpha-char-p string :start 6 :end 9))) (assert (equal (remove-if-not #'alpha-char-p string :start 0 :end nil) - "aaaaa")) + "aaaaa")) (assert (equal (remove-if-not #'alpha-char-p string :start 0 :end 5) - "aaaaa")) + "aaaaa")) (assert (raises-error? - (remove-if-not #'alpha-char-p string :start 0 :end 6))) + (remove-if-not #'alpha-char-p string :start 0 :end 6))) (assert (raises-error? - (remove-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5))) + (remove-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5))) (assert (raises-error? - (remove-if-not #'alpha-char-p string :start 4 :end 2))) + (remove-if-not #'alpha-char-p string :start 4 :end 2))) (assert (raises-error? - (remove-if-not #'alpha-char-p string :start 6 :end 9)))) + (remove-if-not #'alpha-char-p string :start 6 :end 9)))) (sequence-bounding-indices-test - (format t "~&/... DELETE, DELETE-IF, DELETE-IF-NOT") + (format t "~&/... DELETE, DELETE-IF, DELETE-IF-NOT") (assert (equal (delete #\a string :start 0 :end nil) "")) (reset) (assert (equal (delete #\a string :start 0 :end 5) "")) @@ -636,38 +636,38 @@ (assert (equal (delete-if #'alpha-char-p string :start 0 :end 5) "")) (reset) (assert (raises-error? - (delete-if #'alpha-char-p string :start 0 :end 6))) + (delete-if #'alpha-char-p string :start 0 :end 6))) (reset) (assert (raises-error? - (delete-if #'alpha-char-p string :start (opaque-identity -1) :end 5))) + (delete-if #'alpha-char-p string :start (opaque-identity -1) :end 5))) (reset) (assert (raises-error? - (delete-if #'alpha-char-p string :start 4 :end 2))) + (delete-if #'alpha-char-p string :start 4 :end 2))) (reset) (assert (raises-error? - (delete-if #'alpha-char-p string :start 6 :end 9))) + (delete-if #'alpha-char-p string :start 6 :end 9))) (reset) (assert (equal (delete-if-not #'alpha-char-p string :start 0 :end nil) - "aaaaa")) + "aaaaa")) (reset) (assert (equal (delete-if-not #'alpha-char-p string :start 0 :end 5) - "aaaaa")) + "aaaaa")) (reset) (assert (raises-error? - (delete-if-not #'alpha-char-p string :start 0 :end 6))) + (delete-if-not #'alpha-char-p string :start 0 :end 6))) (reset) (assert (raises-error? - (delete-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5))) + (delete-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5))) (reset) (assert (raises-error? - (delete-if-not #'alpha-char-p string :start 4 :end 2))) + (delete-if-not #'alpha-char-p string :start 4 :end 2))) (reset) (assert (raises-error? - (delete-if-not #'alpha-char-p string :start 6 :end 9)))) + (delete-if-not #'alpha-char-p string :start 6 :end 9)))) ;;; Function REMOVE-DUPLICATES, DELETE-DUPLICATES (sequence-bounding-indices-test - (format t "~&/Function REMOVE-DUPLICATES, DELETE-DUPLICATES") + (format t "~&/Function REMOVE-DUPLICATES, DELETE-DUPLICATES") (assert (string= (remove-duplicates string :start 0 :end 5) "a")) (assert (string= (remove-duplicates string :start 0 :end nil) "a")) (assert (raises-error? (remove-duplicates string :start 0 :end 6))) @@ -688,11 +688,11 @@ ;;; Function REPLACE (sequence-bounding-indices-test - (format t "~&/Function REPLACE") + (format t "~&/Function REPLACE") (assert (string= (replace string "bbbbb" :start1 0 :end1 5) "bbbbb")) (assert (string= (replace (copy-seq "ccccc") - string - :start2 0 :end2 nil) "bbbbb")) + string + :start2 0 :end2 nil) "bbbbb")) (assert (raises-error? (replace string "ccccc" :start1 0 :end1 6))) (assert (raises-error? (replace string "ccccc" :start2 (opaque-identity -1) :end2 5))) (assert (raises-error? (replace string "ccccc" :start1 4 :end1 2))) @@ -700,7 +700,7 @@ ;;; Function SEARCH (sequence-bounding-indices-test - (format t "~&/Function SEARCH") + (format t "~&/Function SEARCH") (assert (= (search "aa" string :start2 0 :end2 5) 0)) (assert (null (search string "aa" :start1 0 :end2 nil))) (assert (raises-error? (search "aa" string :start2 0 :end2 6))) @@ -716,7 +716,7 @@ (assert (raises-error? (,fn string :start (opaque-identity -1) :end 5))) (assert (raises-error? (,fn string :start 4 :end 2))) (assert (raises-error? (,fn string :start 6 :end 9))))) - + (sequence-bounding-indices-test (format t "~&/Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE, ...") (string-case-frob string-upcase) @@ -726,7 +726,7 @@ (string-case-frob nstring-upcase) (string-case-frob nstring-downcase) (string-case-frob nstring-capitalize)) - + ;;; Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=, ;;; STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, STRING-GREATERP, ;;; STRING-NOT-GREATERP, STRING-NOT-LESSP @@ -735,11 +735,11 @@ (,fn string "abcde" :start1 0 :end1 5) (,fn "fghij" string :start2 0 :end2 nil) (assert (raises-error? (,fn string "klmno" - :start1 0 :end1 6))) + :start1 0 :end1 6))) (assert (raises-error? (,fn "pqrst" string - :start2 (opaque-identity -1) :end2 5))) + :start2 (opaque-identity -1) :end2 5))) (assert (raises-error? (,fn "uvwxy" string - :start1 4 :end1 2))) + :start1 4 :end1 2))) (assert (raises-error? (,fn string "z" :start2 6 :end2 9))))) (sequence-bounding-indices-test (format t "~&/Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=, ...") @@ -766,45 +766,45 @@ (format t "~&/Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT, ...") (assert (string= (substitute #\b #\a string :start 0 :end 5) "bbbbb")) (assert (string= (substitute #\c #\a string :start 0 :end nil) - "ccccc")) + "ccccc")) (assert (raises-error? (substitute #\b #\a string :start 0 :end 6))) (assert (raises-error? (substitute #\b #\a string :start (opaque-identity -1) :end 5))) (assert (raises-error? (substitute #\b #\a string :start 4 :end 2))) (assert (raises-error? (substitute #\b #\a string :start 6 :end 9))) (assert (string= (substitute-if #\b #'alpha-char-p string - :start 0 :end 5) - "bbbbb")) + :start 0 :end 5) + "bbbbb")) (assert (string= (substitute-if #\c #'alpha-char-p string - :start 0 :end nil) - "ccccc")) + :start 0 :end nil) + "ccccc")) (assert (raises-error? (substitute-if #\b #'alpha-char-p string - :start 0 :end 6))) + :start 0 :end 6))) (assert (raises-error? (substitute-if #\b #'alpha-char-p string - :start (opaque-identity -1) :end 5))) + :start (opaque-identity -1) :end 5))) (assert (raises-error? (substitute-if #\b #'alpha-char-p string - :start 4 :end 2))) + :start 4 :end 2))) (assert (raises-error? (substitute-if #\b #'alpha-char-p string - :start 6 :end 9))) + :start 6 :end 9))) (assert (string= (substitute-if-not #\b #'alpha-char-p string - :start 0 :end 5) - "aaaaa")) + :start 0 :end 5) + "aaaaa")) (assert (string= (substitute-if-not #\c #'alpha-char-p string - :start 0 :end nil) - "aaaaa")) + :start 0 :end nil) + "aaaaa")) (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string - :start 0 :end 6))) + :start 0 :end 6))) (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string - :start (opaque-identity -1) :end 5))) + :start (opaque-identity -1) :end 5))) (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string - :start 4 :end 2))) + :start 4 :end 2))) (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string - :start 6 :end 9)))) + :start 6 :end 9)))) (sequence-bounding-indices-test (format t "~&/... NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT") (assert (string= (nsubstitute #\b #\a string :start 0 :end 5) "bbbbb")) (reset) (assert (string= (nsubstitute #\c #\a string :start 0 :end nil) - "ccccc")) + "ccccc")) (reset) (assert (raises-error? (nsubstitute #\b #\a string :start 0 :end 6))) (reset) @@ -815,67 +815,67 @@ (assert (raises-error? (nsubstitute #\b #\a string :start 6 :end 9))) (reset) (assert (string= (nsubstitute-if #\b #'alpha-char-p string - :start 0 :end 5) - "bbbbb")) + :start 0 :end 5) + "bbbbb")) (reset) (assert (string= (nsubstitute-if #\c #'alpha-char-p string - :start 0 :end nil) - "ccccc")) + :start 0 :end nil) + "ccccc")) (reset) (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string - :start 0 :end 6))) + :start 0 :end 6))) (reset) (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string - :start (opaque-identity -1) :end 5))) + :start (opaque-identity -1) :end 5))) (reset) (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string - :start 4 :end 2))) + :start 4 :end 2))) (reset) (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string - :start 6 :end 9))) + :start 6 :end 9))) (reset) (assert (string= (nsubstitute-if-not #\b #'alpha-char-p string - :start 0 :end 5) - "aaaaa")) + :start 0 :end 5) + "aaaaa")) (reset) (assert (string= (nsubstitute-if-not #\c #'alpha-char-p string - :start 0 :end nil) - "aaaaa")) + :start 0 :end nil) + "aaaaa")) (reset) (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string - :start 0 :end 6))) + :start 0 :end 6))) (reset) (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string - :start (opaque-identity -1) :end 5))) + :start (opaque-identity -1) :end 5))) (reset) (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string - :start 4 :end 2))) + :start 4 :end 2))) (reset) (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string - :start 6 :end 9)))) + :start 6 :end 9)))) ;;; Function WRITE-STRING, WRITE-LINE (sequence-bounding-indices-test (format t "~&/Function WRITE-STRING, WRITE-LINE") (write-string string *standard-output* :start 0 :end 5) (write-string string *standard-output* :start 0 :end nil) (assert (raises-error? (write-string string *standard-output* - :start 0 :end 6))) + :start 0 :end 6))) (assert (raises-error? (write-string string *standard-output* - :start (opaque-identity -1) :end 5))) + :start (opaque-identity -1) :end 5))) (assert (raises-error? (write-string string *standard-output* - :start 4 :end 2))) + :start 4 :end 2))) (assert (raises-error? (write-string string *standard-output* - :start 6 :end 9))) + :start 6 :end 9))) (write-line string *standard-output* :start 0 :end 5) (write-line string *standard-output* :start 0 :end nil) (assert (raises-error? (write-line string *standard-output* - :start 0 :end 6))) + :start 0 :end 6))) (assert (raises-error? (write-line string *standard-output* - :start (opaque-identity -1) :end 5))) + :start (opaque-identity -1) :end 5))) (assert (raises-error? (write-line string *standard-output* - :start 4 :end 2))) + :start 4 :end 2))) (assert (raises-error? (write-line string *standard-output* - :start 6 :end 9)))) + :start 6 :end 9)))) ;;; Macro WITH-INPUT-FROM-STRING (sequence-bounding-indices-test @@ -885,17 +885,17 @@ (with-input-from-string (s string :start 0 :end nil) (assert (char= (read-char s) #\a))) (assert (raises-error? - (with-input-from-string (s string :start 0 :end 6) - (read-char s)))) + (with-input-from-string (s string :start 0 :end 6) + (read-char s)))) (assert (raises-error? - (with-input-from-string (s string :start (opaque-identity -1) :end 5) - (read-char s)))) + (with-input-from-string (s string :start (opaque-identity -1) :end 5) + (read-char s)))) (assert (raises-error? - (with-input-from-string (s string :start 4 :end 2) - (read-char s)))) + (with-input-from-string (s string :start 4 :end 2) + (read-char s)))) (assert (raises-error? - (with-input-from-string (s string :start 6 :end 9) - (read-char s))))) + (with-input-from-string (s string :start 6 :end 9) + (read-char s))))) ;;; testing bit-bashing according to _The Practice of Programming_ (defun fill-bytes-for-testing (bitsize) diff --git a/tests/seq.pure.lisp b/tests/seq.pure.lisp index e59ab96..a0897be 100644 --- a/tests/seq.pure.lisp +++ b/tests/seq.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -27,42 +27,42 @@ (assert (loop for i from 0 to 9 always (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute 'x 'a x :start i :end j :count c))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 (+ i c)) - :initial-element 'a)))))))) + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :count c))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) + :initial-element 'a)))))))) (assert (loop for i from 0 to 9 always (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if 'x (lambda (x) (eq x 'a)) x - :start i :end j - :count c :from-end t))) - (equal y (nconc (make-list (- j c) :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 j) - :initial-element 'a)))))))) + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (lambda (x) (eq x 'a)) x + :start i :end j + :count c :from-end t))) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) + :initial-element 'a)))))))) (assert (loop for i from 0 to 9 always (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if-not 'x (lambda (x) - (not (eq x 'a))) x - :start i :end j - :count c :from-end t))) - (equal y (nconc (make-list (- j c) :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 j) - :initial-element 'a)))))))) + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (lambda (x) + (not (eq x 'a))) x + :start i :end j + :count c :from-end t))) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) + :initial-element 'a)))))))) ;;; And equally similarly, REMOVE-DUPLICATES misbehaved when given ;;; :START arguments: @@ -78,29 +78,29 @@ ;;; tests of COUNT-IF and COUNT-IF-NOT (macrolet (;; the guts of CCI, abstracted over whether we're testing - ;; COUNT-IF or COUNT-IF-NOT - (%cci (expected count-if test sequence-as-list &rest keys) + ;; COUNT-IF or COUNT-IF-NOT + (%cci (expected count-if test sequence-as-list &rest keys) `(let* ((list ',sequence-as-list) - (simple-vector (coerce list 'simple-vector)) - (length (length list)) - (vector (make-array (* 2 length) :fill-pointer length))) - (replace vector list :end1 length) - (dolist (seq (list list simple-vector vector)) - (assert (= ,expected (,count-if ,test seq ,@keys)))))) - ;; "Check COUNT-IF" - (cci (expected test sequence-as-list &rest keys) - `(progn + (simple-vector (coerce list 'simple-vector)) + (length (length list)) + (vector (make-array (* 2 length) :fill-pointer length))) + (replace vector list :end1 length) + (dolist (seq (list list simple-vector vector)) + (assert (= ,expected (,count-if ,test seq ,@keys)))))) + ;; "Check COUNT-IF" + (cci (expected test sequence-as-list &rest keys) + `(progn (format t "~&SEQUENCE-AS-LIST=~S~%" ',sequence-as-list) - (%cci ,expected - count-if - ,test - ,sequence-as-list - ,@keys) - (%cci ,expected - count-if-not - (complement ,test) - ,sequence-as-list - ,@keys)))) + (%cci ,expected + count-if + ,test + ,sequence-as-list + ,@keys) + (%cci ,expected + count-if-not + (complement ,test) + ,sequence-as-list + ,@keys)))) (cci 1 #'consp (1 (12) 1)) (cci 3 #'consp (1 (2) 3 (4) (5) 6)) (cci 3 #'consp (1 (2) 3 (4) (5) 6) :from-end t) @@ -152,16 +152,16 @@ (assert (equal (merge 'list (list 1 2 4) (list 2 3 7) '<) '(1 2 2 3 4 7))) (assert (equal (merge 'list (list 1 2 4) (list -2 3 7) #'<) '(-2 1 2 3 4 7))) (assert (equal (merge 'list (list 1 2 4) (vector -2 3 7) '< :key 'abs) - '(1 2 -2 3 4 7))) + '(1 2 -2 3 4 7))) (assert (equal (merge 'list (list 1 -2 4) (list -2 3 7) '< :key #'abs) - '(1 -2 -2 3 4 7))) + '(1 -2 -2 3 4 7))) (assert (equal (stable-sort (list 1 10 2 12 13 3) '<) '(1 2 3 10 12 13))) (assert (equal (stable-sort (list 1 10 2 12 13 3) #'< :key '-) - '(13 12 10 3 2 1))) + '(13 12 10 3 2 1))) (assert (equal (stable-sort (list 1 10 2 12 13 3) '> :key #'-) - '(1 2 3 10 12 13))) + '(1 2 3 10 12 13))) (assert (equal (stable-sort (list 1 2 3 -3 -2 -1) '< :key 'abs) - '(1 -1 2 -2 3 -3))) + '(1 -1 2 -2 3 -3))) ;;; CSR broke FILL by not returning the sequence argument in a transform. (let* ((s1 (copy-seq "abcde")) diff --git a/tests/setf.impure.lisp b/tests/setf.impure.lisp index f14fce5..cd78733 100644 --- a/tests/setf.impure.lisp +++ b/tests/setf.impure.lisp @@ -32,7 +32,7 @@ ;;; SETF of values with multiple-value place forms (let ((a t) (b t) (c t) (d t)) (let ((list (multiple-value-list - (setf (values (values a b) (values c d)) (values 1 2 3 4))))) + (setf (values (values a b) (values c d)) (values 1 2 3 4))))) (assert (equal list '(1 2))) (assert (eql a 1)) (assert (eql c 2)) diff --git a/tests/smoke.impure.lisp b/tests/smoke.impure.lisp index a7130a7..9a77d0b 100644 --- a/tests/smoke.impure.lisp +++ b/tests/smoke.impure.lisp @@ -7,7 +7,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -51,12 +51,12 @@ (assert (= (oidentity +const+) 1)) (handler-bind ((sb-ext:defconstant-uneql - (lambda (c) (abort c)))) + (lambda (c) (abort c)))) (defconstant +const+ 3)) (assert (= (oidentity +const+) 1)) (handler-bind ((sb-ext:defconstant-uneql - (lambda (c) (continue c)))) + (lambda (c) (continue c)))) (defconstant +const+ 3)) (assert (= (oidentity +const+) 3)) diff --git a/tests/static-alloc.impure.lisp b/tests/static-alloc.impure.lisp index 4709855..b5d4b66 100644 --- a/tests/static-alloc.impure.lisp +++ b/tests/static-alloc.impure.lisp @@ -1,14 +1,14 @@ (dolist (type '(single-float double-float (unsigned-byte 8) - (unsigned-byte 32) (signed-byte 32))) - (let* ((vectors (loop - for i upto 1024 - collect (sb-int:make-static-vector - 256 :element-type type))) - (saps (mapcar #'sb-sys:vector-sap vectors))) + (unsigned-byte 32) (signed-byte 32))) + (let* ((vectors (loop + for i upto 1024 + collect (sb-int:make-static-vector + 256 :element-type type))) + (saps (mapcar #'sb-sys:vector-sap vectors))) (gc :full t) (assert (every #'sb-sys:sap= - saps - (mapcar #'sb-sys:vector-sap vectors))))) + saps + (mapcar #'sb-sys:vector-sap vectors))))) (quit :unix-status 104) diff --git a/tests/stream.impure-cload.lisp b/tests/stream.impure-cload.lisp index 323881c..acfc228 100644 --- a/tests/stream.impure-cload.lisp +++ b/tests/stream.impure-cload.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -28,37 +28,37 @@ (defparameter *scratch-file-name* "sbcl-wrapped-stream-test-data.tmp") (defvar *scratch-file-stream*) (dolist (scratch-file-length '(1 ; everyone's favorite corner case - 200123)) ; hopefully much bigger than buffer + 200123)) ; hopefully much bigger than buffer (format t "/SCRATCH-FILE-LENGTH=~W~%" scratch-file-length) (with-open-file (s *scratch-file-name* :direction :output) (dotimes (i scratch-file-length) (write-char #\x s))) (dolist (wrap-named-stream-fn - ;; All kinds of wrapped input streams have the same issue. - (list (lambda (wrapped-stream-name) - (make-synonym-stream wrapped-stream-name)) - (lambda (wrapped-stream-name) - (make-two-way-stream (symbol-value wrapped-stream-name) - *standard-output*)) - (lambda (wrapped-stream-name) - (make-concatenated-stream (symbol-value wrapped-stream-name) - (make-string-input-stream ""))))) + ;; All kinds of wrapped input streams have the same issue. + (list (lambda (wrapped-stream-name) + (make-synonym-stream wrapped-stream-name)) + (lambda (wrapped-stream-name) + (make-two-way-stream (symbol-value wrapped-stream-name) + *standard-output*)) + (lambda (wrapped-stream-name) + (make-concatenated-stream (symbol-value wrapped-stream-name) + (make-string-input-stream ""))))) (format t "/WRAP-NAMED-STREAM-FN=~S~%" wrap-named-stream-fn) (with-open-file (*scratch-file-stream* *scratch-file-name* - :direction :input) + :direction :input) (let ((ss (funcall wrap-named-stream-fn '*scratch-file-stream*))) - (flet ((expect (thing-expected) - (let ((thing-found (read-char ss nil nil))) - (unless (eql thing-found thing-expected) - (error "expected ~S, found ~S" - thing-expected thing-found))))) - (dotimes (i scratch-file-length) - (expect #\x) - (unread-char #\y ss) - (expect #\y) - (unread-char #\z ss) - (expect #\z)) - (expect nil))))) ; i.e. end of file + (flet ((expect (thing-expected) + (let ((thing-found (read-char ss nil nil))) + (unless (eql thing-found thing-expected) + (error "expected ~S, found ~S" + thing-expected thing-found))))) + (dotimes (i scratch-file-length) + (expect #\x) + (unread-char #\y ss) + (expect #\y) + (unread-char #\z ss) + (expect #\z)) + (expect nil))))) ; i.e. end of file (delete-file *scratch-file-name*)) (with-open-file (s *scratch-file-name* :direction :output) diff --git a/tests/stream.impure.lisp b/tests/stream.impure.lisp index fdc294b..3568766 100644 --- a/tests/stream.impure.lisp +++ b/tests/stream.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -19,11 +19,11 @@ (locally (declare (optimize (safety 3))) (assert (raises-error? (make-two-way-stream (make-string-output-stream) - (make-string-output-stream)) - type-error)) + (make-string-output-stream)) + type-error)) (assert (raises-error? (make-two-way-stream (make-string-input-stream "foo") - (make-string-input-stream "bar")) - type-error)) + (make-string-input-stream "bar")) + type-error)) ;; the following two aren't actually guaranteed, because ANSI, as it ;; happens, doesn't say "should signal an error" for ;; MAKE-ECHO-STREAM. It's still good to have, but if future @@ -31,15 +31,15 @@ ;; MAKE-ECHO-STREAM clauses, consider simply removing these clauses ;; from the test. -- CSR, 2002-10-06 (assert (raises-error? (make-echo-stream (make-string-output-stream) - (make-string-output-stream)) - type-error)) + (make-string-output-stream)) + type-error)) (assert (raises-error? (make-echo-stream (make-string-input-stream "foo") - (make-string-input-stream "bar")) - type-error)) + (make-string-input-stream "bar")) + type-error)) (assert (raises-error? (make-concatenated-stream - (make-string-output-stream) - (make-string-input-stream "foo")) - type-error))) + (make-string-output-stream) + (make-string-input-stream "foo")) + type-error))) ;;; bug 225: STRING-STREAM was not a class (eval `(defgeneric bug225 (s) @@ -58,9 +58,9 @@ ;;; improper buffering on (SIGNED-BYTE 8) streams (fixed by David Lichteblau): (let ((p "signed-byte-8-test.data")) (with-open-file (s p - :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede) + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) (write-byte 255 s)) (with-open-file (s p :element-type '(signed-byte 8)) (assert (= (read-byte s) -1))) @@ -72,15 +72,15 @@ (stream (open p :direction :output :if-exists :error))) (assert (null (with-open-file (s p :direction :output :if-exists nil) s))) (assert (raises-error? - (with-open-file (s p :direction :output :if-exists :error)))) + (with-open-file (s p :direction :output :if-exists :error)))) (close stream) (delete-file p)) (assert (raises-error? (read-byte (make-string-input-stream "abc")) - type-error)) + type-error)) (assert (raises-error? (with-open-file (s "/dev/zero") - (read-byte s)) - type-error)) + (read-byte s)) + type-error)) ;;; bidirectional streams getting confused about their position (let ((p "bidirectional-stream-test")) (with-open-file (s p :direction :output :if-exists :supersede) @@ -130,25 +130,25 @@ ;;; files should be restored. (let ((test "test-file-for-close-should-not-delete")) (macrolet ((test-mode (mode) - `(progn - (catch :close-test-exit - (with-open-file (f test :direction :output :if-exists ,mode) - (write-line "test" f) - (throw :close-test-exit t))) - (assert (and (probe-file test) ,mode))))) + `(progn + (catch :close-test-exit + (with-open-file (f test :direction :output :if-exists ,mode) + (write-line "test" f) + (throw :close-test-exit t))) + (assert (and (probe-file test) ,mode))))) (unwind-protect - (progn - (with-open-file (f test :direction :output) - (write-line "test" f)) - (test-mode :append) - (test-mode :overwrite) - ;; FIXME: We really should recover supersede files as well, according to - ;; CLOSE in CLHS, but at the moment we don't. - ;; (test-mode :supersede) - (test-mode :rename) - (test-mode :rename-and-delete)) + (progn + (with-open-file (f test :direction :output) + (write-line "test" f)) + (test-mode :append) + (test-mode :overwrite) + ;; FIXME: We really should recover supersede files as well, according to + ;; CLOSE in CLHS, but at the moment we don't. + ;; (test-mode :supersede) + (test-mode :rename) + (test-mode :rename-and-delete)) (when (probe-file test) - (delete-file test))))) + (delete-file test))))) ;;; test for read-write invariance of signed bytes, from Bruno Haible ;;; cmucl-imp 2004-09-06 diff --git a/tests/stream.pure.lisp b/tests/stream.pure.lisp index ace7840..b9e2a9b 100644 --- a/tests/stream.pure.lisp +++ b/tests/stream.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -20,14 +20,14 @@ (read-sequence buffer stream)) ;;; test for the new N-BIN method doing what it's supposed to (let* ((substrings (list "This " "is " "a " "" - "test of concatenated streams behaving " - "as ordinary streams do under READ-SEQUENCE. " - (make-string 140041 :initial-element #\%) - "For any size of read.." - (make-string 4123 :initial-element #\.) - "they should give the same results." - (make-string (expt 2 14) :initial-element #\*) - "There should be no differences.")) + "test of concatenated streams behaving " + "as ordinary streams do under READ-SEQUENCE. " + (make-string 140041 :initial-element #\%) + "For any size of read.." + (make-string 4123 :initial-element #\.) + "they should give the same results." + (make-string (expt 2 14) :initial-element #\*) + "There should be no differences.")) (substreams (mapcar #'make-string-input-stream substrings)) (concatenated-stream (apply #'make-concatenated-stream substreams)) (concatenated-string (apply #'concatenate 'string substrings)) @@ -37,17 +37,17 @@ (buffer-2 (make-string max-n-to-read))) (loop (let* ((n-to-read (random max-n-to-read)) - (n-actually-read-1 (read-sequence buffer-1 - concatenated-stream - :end n-to-read)) - (n-actually-read-2 (read-sequence buffer-2 - stream - :end n-to-read))) + (n-actually-read-1 (read-sequence buffer-1 + concatenated-stream + :end n-to-read)) + (n-actually-read-2 (read-sequence buffer-2 + stream + :end n-to-read))) ;; (format t "buffer-1=~S~%buffer-2=~S~%" buffer-1 buffer-2) (assert (= n-actually-read-1 n-actually-read-2)) (assert (string= buffer-1 buffer-2 - :end1 n-actually-read-1 - :end2 n-actually-read-2)) + :end1 n-actually-read-1 + :end2 n-actually-read-2)) (unless (= n-actually-read-1 n-to-read) (assert (< n-actually-read-1 n-to-read)) (return))))) @@ -55,24 +55,24 @@ ;;; Entomotomy PEEK-CHAR-WRONGLY-ECHOS-TO-ECHO-STREAM bug, fixed by ;;; MRD patch sbcl-devel 2002-11-02 merged ca. sbcl-0.7.9.32... (assert (string= - (with-output-to-string (out) - (peek-char #\] - (make-echo-stream - (make-string-input-stream "ab cd e df s]") out))) - ;; (Before the fix, the result had a trailing #\] in it.) - "ab cd e df s")) + (with-output-to-string (out) + (peek-char #\] + (make-echo-stream + (make-string-input-stream "ab cd e df s]") out))) + ;; (Before the fix, the result had a trailing #\] in it.) + "ab cd e df s")) ;;; ...and a missing wrinkle in the original patch, dealing with ;;; PEEK-CHAR/UNREAD-CHAR on ECHO-STREAMs, fixed by MRD patch ;;; sbcl-devel 2002-11-18, merged ca. sbcl-0.7.9.66 (assert (string= - (let* ((in-stream (make-string-input-stream "abc")) - (out-stream (make-string-output-stream)) - (echo-stream (make-echo-stream in-stream out-stream))) - (unread-char (read-char echo-stream) echo-stream) - (peek-char #\a echo-stream) - (get-output-stream-string out-stream)) - ;; (Before the fix, the LET* expression just signalled an error.) - "a")) + (let* ((in-stream (make-string-input-stream "abc")) + (out-stream (make-string-output-stream)) + (echo-stream (make-echo-stream in-stream out-stream))) + (unread-char (read-char echo-stream) echo-stream) + (peek-char #\a echo-stream) + (get-output-stream-string out-stream)) + ;; (Before the fix, the LET* expression just signalled an error.) + "a")) ;;; Reported by Fredrik Sandstrom to sbcl-devel 2005-05-17 ("Bug in ;;; peek-char"): @@ -80,20 +80,20 @@ ;;; the same character that peek-char returns, the character is ;;; removed from the input stream, as if read by read-char. (assert (equal (with-input-from-string (s "123") - (list (peek-char nil s nil #\1) (read-char s) (read-char s))) - '(#\1 #\1 #\2))) + (list (peek-char nil s nil #\1) (read-char s) (read-char s))) + '(#\1 #\1 #\2))) ;;; ... and verify that the fix does not break echo streams (assert (string= (let ((out (make-string-output-stream))) - (with-open-stream (s (make-echo-stream - (make-string-input-stream "123") - out)) - (format s "=>~{~A~}" - (list (peek-char nil s nil #\1) - (read-char s) - (read-char s))) - (get-output-stream-string out))) - "12=>112")) + (with-open-stream (s (make-echo-stream + (make-string-input-stream "123") + out)) + (format s "=>~{~A~}" + (list (peek-char nil s nil #\1) + (read-char s) + (read-char s))) + (get-output-stream-string out))) + "12=>112")) ;;; 0.7.12 doesn't advance current stream in concatenated streams ;;; correctly when searching a stream for a char to read. @@ -143,11 +143,11 @@ ;;; MAKE-STRING-OUTPUT-STREAM ;;; ;;; * Observe FILE-POSITION :START and :END, and allow setting of -;;; FILE-POSITION to an arbitrary index. +;;; FILE-POSITION to an arbitrary index. ;;; ;;; * END will always refer to the farthest position of stream so-far ;;; seen, and setting FILE-POSITION beyond the current END will extend -;;; the string/stream with uninitialized elements. +;;; the string/stream with uninitialized elements. ;;; ;;; * Rewinding the stream works with overwriting semantics. ;;; @@ -191,9 +191,9 @@ ;;; * Rewinding the stream works with overwriting semantics. ;;; #+nil (let ((str (make-array 0 - :element-type 'character - :adjustable nil - :fill-pointer t))) + :element-type 'character + :adjustable nil + :fill-pointer t))) (with-output-to-string (stream str) (princ "abcd" stream) (assert (= 4 (file-position stream))) @@ -215,9 +215,9 @@ (assert (equal "0b2d" str)))) (let ((str (make-array 0 - :element-type 'character - :adjustable nil - :fill-pointer t))) + :element-type 'character + :adjustable nil + :fill-pointer t))) (with-output-to-string (stream str) (princ "abcd" stream) (assert (= 4 (file-position stream))) @@ -244,18 +244,18 @@ ;;; MAKE-STRING-OUTPUT-STREAM and WITH-OUTPUT-TO-STRING take an ;;; :ELEMENT-TYPE keyword argument (macrolet ((frob (element-type-form) - `(progn - (let ((s (with-output-to-string - (s nil ,@(when element-type-form - `(:element-type ,element-type-form)))))) - (assert (typep s '(simple-array ,(if element-type-form - (eval element-type-form) - 'character) - (0))))) - (get-output-stream-string - (make-string-output-stream - ,@(when element-type-form - `(:element-type ,element-type-form))))))) + `(progn + (let ((s (with-output-to-string + (s nil ,@(when element-type-form + `(:element-type ,element-type-form)))))) + (assert (typep s '(simple-array ,(if element-type-form + (eval element-type-form) + 'character) + (0))))) + (get-output-stream-string + (make-string-output-stream + ,@(when element-type-form + `(:element-type ,element-type-form))))))) (frob nil) (frob 'character) (frob 'base-char) diff --git a/tests/stress-gc.lisp b/tests/stress-gc.lisp index f791ddd..000ef8e 100644 --- a/tests/stress-gc.lisp +++ b/tests/stress-gc.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -38,37 +38,37 @@ (defun stress-gc (n-passes &optional (size 3000)) (format t "~&beginning STRESS-GC N-PASSES=~W SIZE=~W~%" n-passes size) (let ((generations (make-array (isqrt size) :initial-element nil)) - ;; We allocate on the order of MOST-POSITIVE-FIXNUM things - ;; before doing a full GC. - (max-passes-to-full-gc (floor most-positive-fixnum size)) - (remaining-passes-to-full-gc 0)) + ;; We allocate on the order of MOST-POSITIVE-FIXNUM things + ;; before doing a full GC. + (max-passes-to-full-gc (floor most-positive-fixnum size)) + (remaining-passes-to-full-gc 0)) (dotimes (j-pass n-passes) #+nil (/show j-pass) (if (plusp remaining-passes-to-full-gc) - (decf remaining-passes-to-full-gc) - (progn - #+nil (/show "doing GC :FULL T") - (gc :full t) - (setf remaining-passes-to-full-gc (random max-passes-to-full-gc)))) + (decf remaining-passes-to-full-gc) + (progn + #+nil (/show "doing GC :FULL T") + (gc :full t) + (setf remaining-passes-to-full-gc (random max-passes-to-full-gc)))) (let* (;; (The (ISQRT (RANDOM (EXPT .. 2))) distribution here is - ;; intended to give a distribution of lifetimes of memory - ;; usage, with low-indexed generations tending to live - ;; for a long time.) - (i-generation (isqrt (random (expt (length generations) 2)))) - (generation-i (aref generations i-generation))) - #+nil (/show i-generation generation-i) - (when generation-i - (assert-generation i-generation generation-i)) - (when (or (null generation-i) - (plusp (random 3))) - #+nil (/show "allocating or reallocating" i-generation) - (setf generation-i - (make-array (random (1+ size))))) - (assign-generation i-generation generation-i) - (when (plusp (random 3)) - (assert-generation i-generation generation-i)) - (setf (aref generations i-generation) - generation-i)))) + ;; intended to give a distribution of lifetimes of memory + ;; usage, with low-indexed generations tending to live + ;; for a long time.) + (i-generation (isqrt (random (expt (length generations) 2)))) + (generation-i (aref generations i-generation))) + #+nil (/show i-generation generation-i) + (when generation-i + (assert-generation i-generation generation-i)) + (when (or (null generation-i) + (plusp (random 3))) + #+nil (/show "allocating or reallocating" i-generation) + (setf generation-i + (make-array (random (1+ size))))) + (assign-generation i-generation generation-i) + (when (plusp (random 3)) + (assert-generation i-generation generation-i)) + (setf (aref generations i-generation) + generation-i)))) (format t "~&done with STRESS-GC N-PASSES=~W SIZE=~W~%" n-passes size)) (defvar *expected*) @@ -77,41 +77,41 @@ (dotimes (index-within-generation (length generation)) #+nil (/show "assert-generation" index-of-generation index-within-generation) (let ((element-of-generation (aref generation index-within-generation)) - (repr (repr (+ index-within-generation index-of-generation)))) + (repr (repr (+ index-within-generation index-of-generation)))) (unless (funcall repr index-within-generation element-of-generation) - ;; KLUDGE: We bind these to special variables for the - ;; convenience of the debugger, which ca. SBCL 0.6.6 is too - ;; wimpy to inspect lexical variables. - (let ((*expected* (funcall repr index-within-generation)) - (*got* element-of-generation)) - (error "bad element #~W in generation #~D:~% expected ~S~% from ~S,~% got ~S" - index-within-generation - index-of-generation - *expected* - repr - *got*)))))) + ;; KLUDGE: We bind these to special variables for the + ;; convenience of the debugger, which ca. SBCL 0.6.6 is too + ;; wimpy to inspect lexical variables. + (let ((*expected* (funcall repr index-within-generation)) + (*got* element-of-generation)) + (error "bad element #~W in generation #~D:~% expected ~S~% from ~S,~% got ~S" + index-within-generation + index-of-generation + *expected* + repr + *got*)))))) (defun assign-generation (index-of-generation generation) (dotimes (index-within-generation (length generation)) #+nil (/show "assert-generation" index-of-generation index-within-generation) (setf (aref generation index-within-generation) - (funcall (repr (+ index-within-generation index-of-generation)) - index-within-generation)))) - + (funcall (repr (+ index-within-generation index-of-generation)) + index-within-generation)))) + (defun repr-fixnum (index &optional (value nil value-p)) (let ((fixnum (the fixnum (+ index 101)))) (if value-p - (eql fixnum value) - fixnum))) + (eql fixnum value) + fixnum))) (defun repr-function (index &optional (value nil value-p)) (let ((fixnum (mod (+ index 2) 3))) (if value-p - (eql fixnum (funcall value)) - (ecase fixnum - (0 #'repr-fixnum-zero) - (1 #'repr-fixnum-one) - (2 #'repr-fixnum-two))))) + (eql fixnum (funcall value)) + (ecase fixnum + (0 #'repr-fixnum-zero) + (1 #'repr-fixnum-one) + (2 #'repr-fixnum-two))))) (defun repr-fixnum-zero () 0) (defun repr-fixnum-one () 1) (defun repr-fixnum-two () 2) @@ -120,140 +120,139 @@ (defun repr-instance (index &optional (value nil value-p)) (let ((fixnum (mod (* index 3) 4))) (if value-p - (and (typep value 'repr-instance) - (eql (repr-instance-slot value) fixnum)) - (make-repr-instance :slot fixnum)))) + (and (typep value 'repr-instance) + (eql (repr-instance-slot value) fixnum)) + (make-repr-instance :slot fixnum)))) (defun repr-eql-hash-table (index &optional (value nil value-p)) (let ((first-fixnum (mod (* index 31) 9)) - (n-fixnums 5)) + (n-fixnums 5)) (if value-p - (and (hash-table-p value) - (= (hash-table-count value) n-fixnums) - (dotimes (i n-fixnums t) - (unless (= (gethash (+ i first-fixnum) value) i) - (return nil))) - #| - (repr-bignum index (gethash 'bignum value)) - (repr-ratio index (gethash 'ratio value)) + (and (hash-table-p value) + (= (hash-table-count value) n-fixnums) + (dotimes (i n-fixnums t) + (unless (= (gethash (+ i first-fixnum) value) i) + (return nil))) + #| + (repr-bignum index (gethash 'bignum value)) + (repr-ratio index (gethash 'ratio value)) |#) - (let ((hash-table (make-hash-table :test 'eql))) - (dotimes (i n-fixnums) - (setf (gethash (+ first-fixnum i) hash-table) i)) - #| - (setf (gethash 'bignum hash-table) (repr-bignum index) - (gethash 'ratio hash-table) (repr-ratio index)) + (let ((hash-table (make-hash-table :test 'eql))) + (dotimes (i n-fixnums) + (setf (gethash (+ first-fixnum i) hash-table) i)) + #| + (setf (gethash 'bignum hash-table) (repr-bignum index) + (gethash 'ratio hash-table) (repr-ratio index)) |# - hash-table)))) + hash-table)))) (defun repr-bignum (index &optional (value nil value-p)) (let ((bignum (+ index 10000300020))) (if value-p - (eql value bignum) - bignum))) + (eql value bignum) + bignum))) (defun repr-ratio (index &optional (value nil value-p)) (let ((ratio (/ index (1+ index)))) (if value-p - (eql value ratio) - ratio))) + (eql value ratio) + ratio))) (defun repr-single-float (index &optional (value nil value-p)) (let ((single-float (* 0.25 (float index) (1+ (float index))))) (if value-p - (eql value single-float) - single-float))) + (eql value single-float) + single-float))) (defun repr-double-float (index &optional (value nil value-p)) (let ((double-float (+ 0.25d0 (1- index) (1+ (float index))))) (if value-p - (eql value double-float) - double-float))) + (eql value double-float) + double-float))) (defun repr-simple-string (index &optional (value nil value-p)) (let ((length (mod index 14))) (if value-p - (and (stringp value) - (typep value 'simple-array) - (= (length value) length)) - (make-string length)))) + (and (stringp value) + (typep value 'simple-array) + (= (length value) length)) + (make-string length)))) (defun repr-simple-vector (index &optional (value nil value-p)) (let ((length (mod (1+ index) 16))) (if value-p - (and (simple-vector-p value) - (= (array-dimension value 0) length)) - (make-array length)))) + (and (simple-vector-p value) + (= (array-dimension value 0) length)) + (make-array length)))) (defun repr-complex-vector (index &optional (value nil value-p)) (let* ((size (mod (* 5 index) 13)) - (length (floor size 3))) + (length (floor size 3))) (if value-p - (and (vectorp value) - (not (typep value 'simple-array)) - (= (array-dimension value 0) size) - (= (length value) length)) - (make-array size :fill-pointer length)))) + (and (vectorp value) + (not (typep value 'simple-array)) + (= (array-dimension value 0) size) + (= (length value) length)) + (make-array size :fill-pointer length)))) (defun repr-symbol (index &optional (value nil value-p)) (let* ((symbols #(zero one two three four)) - (symbol (aref symbols (mod index (length symbols))))) + (symbol (aref symbols (mod index (length symbols))))) (if value-p - (eq value symbol) - symbol))) + (eq value symbol) + symbol))) (defun repr-base-char (index &optional (value nil value-p)) (let* ((base-chars #(#\z #\o #\t #\t #\f #\f #\s #\s #\e)) - (base-char (aref base-chars (mod index (length base-chars))))) + (base-char (aref base-chars (mod index (length base-chars))))) (if value-p - (eql value base-char) - base-char))) + (eql value base-char) + base-char))) (setf *reprs* (vector #'repr-fixnum - #'repr-function - #'repr-instance - #'repr-eql-hash-table + #'repr-function + #'repr-instance + #'repr-eql-hash-table #| - #'repr-equal-hash-table - #'repr-equalp-hash-table + #'repr-equal-hash-table + #'repr-equalp-hash-table |# - #'repr-bignum - #'repr-ratio - #'repr-single-float - #'repr-double-float + #'repr-bignum + #'repr-ratio + #'repr-single-float + #'repr-double-float #| - #'repr-complex-single-float - #'repr-complex-double-float - #'repr-simple-array + #'repr-complex-single-float + #'repr-complex-double-float + #'repr-simple-array |# - #'repr-simple-string + #'repr-simple-string #| - #'repr-simple-bit-vector + #'repr-simple-bit-vector |# - #'repr-simple-vector + #'repr-simple-vector #| - #'repr-simple-array-u2 - #'repr-simple-array-u4 - #'repr-simple-array-u8 - #'repr-simple-array-u16 - #'repr-simple-array-u32 - #'repr-simple-array-single-float - #'repr-simple-array-double-float - #'repr-complex-string - #'repr-complex-bit-vector + #'repr-simple-array-u2 + #'repr-simple-array-u4 + #'repr-simple-array-u8 + #'repr-simple-array-u16 + #'repr-simple-array-u32 + #'repr-simple-array-single-float + #'repr-simple-array-double-float + #'repr-complex-string + #'repr-complex-bit-vector |# - #'repr-complex-vector + #'repr-complex-vector #| - #'repr-complex-array - ;; TO DO: #'repr-funcallable-instance + #'repr-complex-array + ;; TO DO: #'repr-funcallable-instance |# - #'repr-symbol - #'repr-base-char - ;; TO DO: #'repr-sap - ;; TO DO? #'repr-unbound-marker - ;; TO DO? #'repr-weak-pointer - ;; TO DO? #'repr-instance-header - ;; TO DO? #'repr-fdefn - )) - \ No newline at end of file + #'repr-symbol + #'repr-base-char + ;; TO DO: #'repr-sap + ;; TO DO? #'repr-unbound-marker + ;; TO DO? #'repr-weak-pointer + ;; TO DO? #'repr-instance-header + ;; TO DO? #'repr-fdefn + )) diff --git a/tests/string.pure.lisp b/tests/string.pure.lisp index 1b659fd..15e7afd 100644 --- a/tests/string.pure.lisp +++ b/tests/string.pure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -18,12 +18,12 @@ (assert (string= (string-downcase "This is a test.") "this is a test.")) (assert (string= (string-capitalize "This is a test.") "This Is A Test.")) (assert (string= (string-upcase "Is this 900-Sex-hott, please?" :start 3) - "Is THIS 900-SEX-HOTT, PLEASE?")) + "Is THIS 900-SEX-HOTT, PLEASE?")) (assert (string= (string-downcase "Is this 900-Sex-hott, please?" - :start 10 :end 16) - "Is this 900-sex-hott, please?")) + :start 10 :end 16) + "Is this 900-sex-hott, please?")) (assert (string= (string-capitalize "Is this 900-Sex-hott, please?") - "Is This 900-Sex-Hott, Please?")) + "Is This 900-Sex-Hott, Please?")) ;;; The non-destructive case operations accept string designators, not ;;; just strings. @@ -54,36 +54,36 @@ (assert (not (typep (make-string 4 :element-type nil) 'simple-base-string))) (assert (subtypep (class-of (make-array 1 :element-type nil)) - (find-class 'string))) + (find-class 'string))) (assert (subtypep (class-of (make-array 2 :element-type nil :fill-pointer 1)) - (find-class 'string))) + (find-class 'string))) (assert (string= "" (make-array 0 :element-type nil))) (assert (string/= "a" (make-array 0 :element-type nil))) (assert (string= "" (make-array 5 :element-type nil :fill-pointer 0))) (assert (= (sxhash "") - (sxhash (make-array 0 :element-type nil)) - (sxhash (make-array 5 :element-type nil :fill-pointer 0)) - (sxhash (make-string 0 :element-type nil)))) + (sxhash (make-array 0 :element-type nil)) + (sxhash (make-array 5 :element-type nil :fill-pointer 0)) + (sxhash (make-string 0 :element-type nil)))) (assert (subtypep (type-of (make-array 2 :element-type nil)) 'simple-string)) (assert (subtypep (type-of (make-array 4 :element-type nil :fill-pointer t)) - 'string)) + 'string)) (assert (eq (intern "") (intern (make-array 0 :element-type nil)))) (assert (eq (intern "") - (intern (make-array 5 :element-type nil :fill-pointer 0)))) + (intern (make-array 5 :element-type nil :fill-pointer 0)))) (assert (raises-error? (make-string 5 :element-type t))) (assert (raises-error? (let () (make-string 5 :element-type t)))) ;; MISC.574 (assert (= (funcall (lambda (a) - (declare (optimize (speed 3) (safety 1) - (debug 1) (space 2)) - (fixnum a)) - (string<= (coerce "e99mo7yAJ6oU4" 'base-string) - (coerce "aaABAAbaa" 'base-string) - :start1 a)) - 9) - 9)) + (declare (optimize (speed 3) (safety 1) + (debug 1) (space 2)) + (fixnum a)) + (string<= (coerce "e99mo7yAJ6oU4" 'base-string) + (coerce "aaABAAbaa" 'base-string) + :start1 a)) + 9) + 9)) diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 03465c4..d642a69 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;; +;;; ;;;; This software is in the public domain and is provided with ;;;; absoluely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -55,17 +55,17 @@ (dotimes (i nthreads) (sb-thread:make-thread (lambda () (sb-thread:condition-wait queue mutex) - (sb-ext:quit)))) + (sb-ext:quit)))) (let ((start-time (get-internal-run-time))) (funcall function) (prog1 (- (get-internal-run-time) start-time) - (sb-thread:condition-broadcast queue))))) + (sb-thread:condition-broadcast queue))))) (defun fact (n) "A function that does work with the CPU." (if (zerop n) 1 (* n (fact (1- n))))) (let ((work (lambda () (fact 15000)))) (let ((zero (scaling-test work 0)) - (four (scaling-test work 4))) + (four (scaling-test work 4))) ;; a slightly weak assertion, but good enough for starters. (assert (< four (* 1.5 zero))))) @@ -74,7 +74,7 @@ (with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede) (format o "void loop_forever() { while(1) ; }~%")) -(sb-ext:run-program +(sb-ext:run-program "cc" (or #+linux '("-shared" "-o" "threads-foreign.so" "threads-foreign.c") (error "Missing shared library compilation options for this platform")) @@ -123,20 +123,20 @@ (lock (make-mutex :name "lock")) (n 0)) (labels ((in-new-thread () - (with-mutex (lock) - (assert (eql (mutex-value lock) *current-thread*)) - (format t "~A got mutex~%" *current-thread*) - ;; now drop it and sleep - (condition-wait queue lock) - ;; after waking we should have the lock again - (assert (eql (mutex-value lock) *current-thread*)) + (with-mutex (lock) + (assert (eql (mutex-value lock) *current-thread*)) + (format t "~A got mutex~%" *current-thread*) + ;; now drop it and sleep + (condition-wait queue lock) + ;; after waking we should have the lock again + (assert (eql (mutex-value lock) *current-thread*)) (assert (eql n 1)) (decf n)))) (make-thread #'in-new-thread) - (sleep 2) ; give it a chance to start + (sleep 2) ; give it a chance to start ;; check the lock is free while it's asleep (format t "parent thread ~A~%" *current-thread*) - (assert (eql (mutex-value lock) nil)) + (assert (eql (mutex-value lock) nil)) (with-mutex (lock) (incf n) (condition-notify queue)) @@ -145,37 +145,37 @@ (let ((queue (make-waitqueue :name "queue")) (lock (make-mutex :name "lock"))) (labels ((ours-p (value) - (sb-vm:control-stack-pointer-valid-p - (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value)))) - (in-new-thread () - (with-recursive-lock (lock) - (assert (ours-p (mutex-value lock))) - (format t "~A got mutex~%" (mutex-value lock)) - ;; now drop it and sleep - (condition-wait queue lock) - ;; after waking we should have the lock again - (format t "woken, ~A got mutex~%" (mutex-value lock)) - (assert (ours-p (mutex-value lock)))))) + (sb-vm:control-stack-pointer-valid-p + (sb-sys:int-sap (sb-kernel:get-lisp-obj-address value)))) + (in-new-thread () + (with-recursive-lock (lock) + (assert (ours-p (mutex-value lock))) + (format t "~A got mutex~%" (mutex-value lock)) + ;; now drop it and sleep + (condition-wait queue lock) + ;; after waking we should have the lock again + (format t "woken, ~A got mutex~%" (mutex-value lock)) + (assert (ours-p (mutex-value lock)))))) (make-thread #'in-new-thread) - (sleep 2) ; give it a chance to start + (sleep 2) ; give it a chance to start ;; check the lock is free while it's asleep (format t "parent thread ~A~%" *current-thread*) - (assert (eql (mutex-value lock) nil)) + (assert (eql (mutex-value lock) nil)) (with-recursive-lock (lock) (condition-notify queue)) (sleep 1))) (let ((mutex (make-mutex :name "contended"))) (labels ((run () - (let ((me *current-thread*)) - (dotimes (i 100) - (with-mutex (mutex) - (sleep .1) - (assert (eql (mutex-value mutex) me))) - (assert (not (eql (mutex-value mutex) me)))) - (format t "done ~A~%" *current-thread*)))) + (let ((me *current-thread*)) + (dotimes (i 100) + (with-mutex (mutex) + (sleep .1) + (assert (eql (mutex-value mutex) me))) + (assert (not (eql (mutex-value mutex) me)))) + (format t "done ~A~%" *current-thread*)))) (let ((kid1 (make-thread #'run)) - (kid2 (make-thread #'run))) + (kid2 (make-thread #'run))) (format t "contention ~A ~A~%" kid1 kid2)))) (defun test-interrupt (function-to-interrupt &optional quit-p) @@ -184,9 +184,9 @@ (sleep 2) (format t "interrupting child ~A~%" child) (interrupt-thread child - (lambda () - (format t "child pid ~A~%" *current-thread*) - (when quit-p (sb-ext:quit)))) + (lambda () + (format t "child pid ~A~%" *current-thread*) + (when quit-p (sb-ext:quit)))) (sleep 1) child)) @@ -200,16 +200,16 @@ (let ((child (test-interrupt (lambda () (loop (sleep 2000)))))) (terminate-thread child)) - + (let ((lock (make-mutex :name "loctite")) child) (with-mutex (lock) (setf child (test-interrupt - (lambda () - (with-mutex (lock) - (assert (eql (mutex-value lock) *current-thread*))) - (assert (not (eql (mutex-value lock) *current-thread*))) - (sleep 10)))) + (lambda () + (with-mutex (lock) + (assert (eql (mutex-value lock) *current-thread*))) + (assert (not (eql (mutex-value lock) *current-thread*))) + (sleep 10)))) ;;hold onto lock for long enough that child can't get it immediately (sleep 5) (interrupt-thread child (lambda () (format t "l ~A~%" (mutex-value lock)))) @@ -246,10 +246,10 @@ (dotimes (i 100) (sleep (random 1d0)) (interrupt-thread c - (lambda () - (princ ".") (force-output) + (lambda () + (princ ".") (force-output) (assert (eq (thread-state *current-thread*) :running)) - (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*))))) + (assert (zerop SB-KERNEL:*PSEUDO-ATOMIC-ATOMIC*))))) (terminate-thread c)) (format t "~&interrupt test done~%") @@ -286,14 +286,14 @@ (let (a-done b-done) (make-thread (lambda () - (dotimes (i 100) - (sb-ext:gc) (princ "\\") (force-output)) - (setf a-done t))) + (dotimes (i 100) + (sb-ext:gc) (princ "\\") (force-output)) + (setf a-done t))) (make-thread (lambda () - (dotimes (i 25) - (sb-ext:gc :full t) - (princ "/") (force-output)) - (setf b-done t))) + (dotimes (i 25) + (sb-ext:gc :full t) + (princ "/") (force-output)) + (setf b-done t))) (loop (when (and a-done b-done) (return)) (sleep 1))) @@ -408,6 +408,6 @@ ;; give the other thread time to die before we leave, otherwise the ;; overall exit status is 0, not 104 -(sleep 2) +(sleep 2) (sb-ext:quit :unix-status 104) diff --git a/tests/time.pure.lisp b/tests/time.pure.lisp index 475918b..da7f3b9 100644 --- a/tests/time.pure.lisp +++ b/tests/time.pure.lisp @@ -4,7 +4,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -14,16 +14,16 @@ ;;; Test for monotonicity of GET-INTERNAL-RUN-TIME. (On OpenBSD, this ;;; is not a given, because of a longstanding bug in getrusage().) (funcall (compile nil - '(lambda (n-seconds) - (declare (type fixnum n-seconds)) - (let* ((n-internal-time-units - (* n-seconds - internal-time-units-per-second)) - (time0 (get-internal-run-time)) - (time1 (+ time0 n-internal-time-units))) - (loop - (let ((time (get-internal-run-time))) - (assert (>= time time0)) - (when (>= time time1) - (return))))))) - 3) + '(lambda (n-seconds) + (declare (type fixnum n-seconds)) + (let* ((n-internal-time-units + (* n-seconds + internal-time-units-per-second)) + (time0 (get-internal-run-time)) + (time1 (+ time0 n-internal-time-units))) + (loop + (let ((time (get-internal-run-time))) + (assert (>= time time0)) + (when (>= time time1) + (return))))))) + 3) diff --git a/tests/type.after-xc.lisp b/tests/type.after-xc.lisp index 5bbf2aa..b63d944 100644 --- a/tests/type.after-xc.lisp +++ b/tests/type.after-xc.lisp @@ -7,7 +7,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -18,11 +18,11 @@ ;;; various dead bugs (assert (eql *empty-type* - (type-intersection *empty-type* - (specifier-type 'keyword)))) + (type-intersection *empty-type* + (specifier-type 'keyword)))) (assert (eql *empty-type* - (type-intersection (specifier-type 'keyword) - *empty-type*))) + (type-intersection (specifier-type 'keyword) + *empty-type*))) (assert (member-type-p (specifier-type '(or float-format null)))) (/show "done with tests/type.after-xc.lisp") diff --git a/tests/type.before-xc.lisp b/tests/type.before-xc.lisp index 90d8f1d..e7f0964 100644 --- a/tests/type.before-xc.lisp +++ b/tests/type.before-xc.lisp @@ -1,4 +1,4 @@ -;;;; tests of the type system, intended to be executed as soon as +;;;; tests of the type system, intended to be executed as soon as ;;;; the cross-compiler is built ;;;; This software is part of the SBCL system. See the README file for @@ -7,7 +7,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -17,11 +17,11 @@ (/show "beginning tests/type.before-xc.lisp") (assert (type= (specifier-type '(and fixnum (satisfies foo))) - (specifier-type '(and (satisfies foo) fixnum)))) + (specifier-type '(and (satisfies foo) fixnum)))) (assert (type= (specifier-type '(member 1 2 3)) - (specifier-type '(member 2 3 1)))) + (specifier-type '(member 2 3 1)))) (assert (type= (specifier-type '(and (member 1.0 2 3) single-float)) - (specifier-type '(member 1.0)))) + (specifier-type '(member 1.0)))) (assert (sb-xc:typep #(1 2 3) 'simple-vector)) (assert (sb-xc:typep #(1 2 3) 'vector)) @@ -40,57 +40,57 @@ (assert (not (sb-xc:typep nil '(member 1 2 3)))) (assert (type= *empty-type* - (type-intersection (specifier-type 'list) - (specifier-type 'vector)))) + (type-intersection (specifier-type 'list) + (specifier-type 'vector)))) (assert (eql *empty-type* - (type-intersection (specifier-type 'list) - (specifier-type 'vector)))) + (type-intersection (specifier-type 'list) + (specifier-type 'vector)))) (assert (type= (specifier-type 'null) - (type-intersection (specifier-type 'list) - (specifier-type '(or vector null))))) + (type-intersection (specifier-type 'list) + (specifier-type '(or vector null))))) (assert (type= (specifier-type 'null) - (type-intersection (specifier-type 'sequence) - (specifier-type 'symbol)))) + (type-intersection (specifier-type 'sequence) + (specifier-type 'symbol)))) (assert (type= (specifier-type 'cons) - (type-intersection (specifier-type 'sequence) - (specifier-type '(or cons number))))) + (type-intersection (specifier-type 'sequence) + (specifier-type '(or cons number))))) (assert (eql *empty-type* - (type-intersection (specifier-type '(satisfies keywordp)) - *empty-type*))) + (type-intersection (specifier-type '(satisfies keywordp)) + *empty-type*))) (assert (type= (specifier-type 'list) - (type-union (specifier-type 'cons) (specifier-type 'null)))) + (type-union (specifier-type 'cons) (specifier-type 'null)))) (assert (type= (specifier-type 'list) - (type-union (specifier-type 'null) (specifier-type 'cons)))) + (type-union (specifier-type 'null) (specifier-type 'cons)))) (assert (type= (specifier-type 'sequence) - (type-union (specifier-type 'list) (specifier-type 'vector)))) + (type-union (specifier-type 'list) (specifier-type 'vector)))) (assert (type= (specifier-type 'sequence) - (type-union (specifier-type 'vector) (specifier-type 'list)))) + (type-union (specifier-type 'vector) (specifier-type 'list)))) (assert (type= (specifier-type 'list) - (type-union (specifier-type 'cons) (specifier-type 'list)))) + (type-union (specifier-type 'cons) (specifier-type 'list)))) (assert (not (csubtypep (type-union (specifier-type 'list) - (specifier-type '(satisfies foo))) - (specifier-type 'list)))) + (specifier-type '(satisfies foo))) + (specifier-type 'list)))) (assert (csubtypep (specifier-type 'list) - (type-union (specifier-type 'list) - (specifier-type '(satisfies foo))))) + (type-union (specifier-type 'list) + (specifier-type '(satisfies foo))))) ;;; Identities should be identities. (dolist (type-specifier '(nil - t - null - (satisfies keywordp) - (satisfies foo) - (not fixnum) - (not null) - (and symbol (satisfies foo)) - (and (satisfies foo) string) - (or symbol sequence) - (or single-float character) - (or float (satisfies bar)) - integer (integer 0 1) - character standard-char - (member 1 2 3))) + t + null + (satisfies keywordp) + (satisfies foo) + (not fixnum) + (not null) + (and symbol (satisfies foo)) + (and (satisfies foo) string) + (or symbol sequence) + (or single-float character) + (or float (satisfies bar)) + integer (integer 0 1) + character standard-char + (member 1 2 3))) (/show type-specifier) (let ((ctype (specifier-type type-specifier))) @@ -103,7 +103,7 @@ (assert (type= ctype (type-intersection *universal-type* ctype))) (assert (type= ctype (type-intersection2 ctype *universal-type*))) (assert (type= ctype (type-intersection2 *universal-type* ctype))) - + (assert (eql *universal-type* (type-union ctype *universal-type*))) (assert (eql *universal-type* (type-union *universal-type* ctype))) (assert (eql *universal-type* (type-union2 ctype *universal-type*))) @@ -130,21 +130,21 @@ (assert-secondnil (sb-xc:subtypep t '(or (satisfies foo) (satisfies bar)))) (assert-secondnil (sb-xc:subtypep '(satisfies foo) nil)) (assert-secondnil (sb-xc:subtypep '(and (satisfies foo) (satisfies bar)) - nil)) + nil)) (assert-secondnil (sb-xc:subtypep '(or (satisfies foo) (satisfies bar)) - nil))) + nil))) ;;; tests of 2-value quantifieroids FOO/TYPE (macrolet ((2= (v1 v2 expr2) (let ((x1 (gensym)) - (x2 (gensym))) - `(multiple-value-bind (,x1 ,x2) ,expr2 - (unless (and (eql ,x1 ,v1) (eql ,x2 ,v2)) - (error "mismatch for EXPR2=~S" ',expr2)))))) + (x2 (gensym))) + `(multiple-value-bind (,x1 ,x2) ,expr2 + (unless (and (eql ,x1 ,v1) (eql ,x2 ,v2)) + (error "mismatch for EXPR2=~S" ',expr2)))))) (flet (;; SUBTYPEP running in the cross-compiler - (xsubtypep (x y) - (csubtypep (specifier-type x) - (specifier-type y)))) + (xsubtypep (x y) + (csubtypep (specifier-type x) + (specifier-type y)))) (2= t t (any/type #'xsubtypep 'fixnum '(real integer))) (2= t t (any/type #'xsubtypep 'fixnum '(real cons))) (2= nil t (any/type #'xsubtypep 'fixnum '(cons vector))) @@ -164,24 +164,24 @@ ;;; various dead bugs (assert (union-type-p (type-intersection (specifier-type 'list) - (specifier-type '(or list vector))))) + (specifier-type '(or list vector))))) (assert (type= (type-intersection (specifier-type 'list) - (specifier-type '(or list vector))) - (specifier-type 'list))) + (specifier-type '(or list vector))) + (specifier-type 'list))) (assert (array-type-p (type-intersection (specifier-type 'vector) - (specifier-type '(or list vector))))) + (specifier-type '(or list vector))))) (assert (type= (type-intersection (specifier-type 'vector) - (specifier-type '(or list vector))) - (specifier-type 'vector))) + (specifier-type '(or list vector))) + (specifier-type 'vector))) (assert (type= (type-intersection (specifier-type 'number) - (specifier-type 'integer)) - (specifier-type 'integer))) + (specifier-type 'integer)) + (specifier-type 'integer))) (assert (null (type-intersection2 (specifier-type 'symbol) - (specifier-type '(satisfies foo))))) + (specifier-type '(satisfies foo))))) (assert (intersection-type-p (specifier-type '(and symbol (satisfies foo))))) (assert (ctypep :x86 (specifier-type '(satisfies keywordp)))) (assert (type= (specifier-type '(member :x86)) - (specifier-type '(and (member :x86) (satisfies keywordp))))) + (specifier-type '(and (member :x86) (satisfies keywordp))))) (let* ((type1 (specifier-type '(member :x86))) (type2 (specifier-type '(or keyword null))) (isect (type-intersection type1 type2))) @@ -199,15 +199,15 @@ (assert (type= isect (type-intersection type1 type1 type2 type1))) (assert (type= isect (type-intersection type1 type2 type1 type2)))) (assert (csubtypep (specifier-type '(or (single-float -1.0 1.0) - (single-float 0.1))) - (specifier-type '(or (real -1 7) - (single-float 0.1) - (single-float -1.0 1.0))))) + (single-float 0.1))) + (specifier-type '(or (real -1 7) + (single-float 0.1) + (single-float -1.0 1.0))))) (assert (not (csubtypep (specifier-type '(or (real -1 7) - (single-float 0.1) - (single-float -1.0 1.0))) - (specifier-type '(or (single-float -1.0 1.0) - (single-float 0.1)))))) + (single-float 0.1) + (single-float -1.0 1.0))) + (specifier-type '(or (single-float -1.0 1.0) + (single-float 0.1)))))) (assert (sb-xc:typep #\, 'character)) (assert (sb-xc:typep #\@ 'character)) diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 248955e..6332549 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -4,7 +4,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -21,20 +21,20 @@ (defmacro assert-t-t-or-uncertain (expr) `(assert (let ((list (multiple-value-list ,expr))) - (or (equal '(nil nil) list) - (equal '(t t) list))))) + (or (equal '(nil nil) list) + (equal '(t t) list))))) (let ((types '(character - integer fixnum (integer 0 10) - single-float (single-float -1.0 1.0) (single-float 0.1) - (real 4 8) (real -1 7) (real 2 11) - null symbol keyword - (member #\a #\b #\c) (member 1 #\a) (member 3.0 3.3) + integer fixnum (integer 0 10) + single-float (single-float -1.0 1.0) (single-float 0.1) + (real 4 8) (real -1 7) (real 2 11) + null symbol keyword + (member #\a #\b #\c) (member 1 #\a) (member 3.0 3.3) (member #\a #\c #\d #\f) (integer -1 1) - unsigned-byte - (rational -1 7) (rational -2 4) - ratio - ))) + unsigned-byte + (rational -1 7) (rational -2 4) + ratio + ))) (dolist (i types) (format t "type I=~S~%" i) (dolist (j types) @@ -44,25 +44,25 @@ (assert (subtypep i `(or ,i ,i ,j))) (assert (subtypep i `(or ,j ,i))) (dolist (k types) - (format t " type K=~S~%" k) - (assert (subtypep `(or ,i ,j) `(or ,i ,j ,k))) - (assert (subtypep `(or ,i ,j) `(or ,k ,j ,i))))))) + (format t " type K=~S~%" k) + (assert (subtypep `(or ,i ,j) `(or ,i ,j ,k))) + (assert (subtypep `(or ,i ,j) `(or ,k ,j ,i))))))) ;;; gotchas that can come up in handling subtypeness as "X is a ;;; subtype of Y if each of the elements of X is a subtype of Y" (let ((subtypep-values (multiple-value-list - (subtypep '(single-float -1.0 1.0) - '(or (real -100.0 0.0) - (single-float 0.0 100.0)))))) + (subtypep '(single-float -1.0 1.0) + '(or (real -100.0 0.0) + (single-float 0.0 100.0)))))) (assert (member subtypep-values - '(;; The system isn't expected to - ;; understand the subtype relationship. - (nil nil) - ;; But if it does, that'd be neat. - (t t) - ;; (And any other return would be wrong.) - ) - :test #'equal))) + '(;; The system isn't expected to + ;; understand the subtype relationship. + (nil nil) + ;; But if it does, that'd be neat. + (t t) + ;; (And any other return would be wrong.) + ) + :test #'equal))) (defun type-evidently-= (x y) (and (subtypep x y) @@ -206,12 +206,12 @@ ;;; the definition of the component structure). Since it's a sensible ;;; thing to want anyway, let's test for it here: (assert-t-t (subtypep '(or some-undefined-type (member :no-ir2-yet :dead)) - '(or some-undefined-type (member :no-ir2-yet :dead)))) + '(or some-undefined-type (member :no-ir2-yet :dead)))) ;;; BUG 158 (failure to compile loops with vector references and ;;; increments of greater than 1) was a symptom of type system ;;; uncertainty, to wit: (assert-t-t (subtypep '(and (mod 536870911) (or (integer 0 0) (integer 2 536870912))) - '(mod 536870911))) ; aka SB-INT:INDEX. + '(mod 536870911))) ; aka SB-INT:INDEX. ;;; floating point types can be tricky. (assert-t-t (subtypep '(member 0.0) '(single-float 0.0 0.0))) (assert-t-t (subtypep '(member -0.0) '(single-float 0.0 0.0))) @@ -292,39 +292,39 @@ (assert (typep (make-structure-foo3) 'structure-foo2)) (assert (not (typep (make-structure-foo1) 'structure-foo4))) (assert (typep (nth-value 1 - (ignore-errors (structure-foo2-x - (make-structure-foo1)))) - 'type-error)) + (ignore-errors (structure-foo2-x + (make-structure-foo1)))) + 'type-error)) (assert (null (ignore-errors - (setf (structure-foo2-x (make-structure-foo1)) 11)))) + (setf (structure-foo2-x (make-structure-foo1)) 11)))) ;; structure-class tests (assert (typep (make-instance 'structure-class-foo3) - 'structure-class-foo2)) + 'structure-class-foo2)) (assert (not (typep (make-instance 'structure-class-foo1) - 'structure-class-foo4))) + 'structure-class-foo4))) (assert (null (ignore-errors - (setf (slot-value (make-instance 'structure-class-foo1) - 'x) - 11)))) + (setf (slot-value (make-instance 'structure-class-foo1) + 'x) + 11)))) ;; standard-class tests (assert (typep (make-instance 'standard-class-foo3) - 'standard-class-foo2)) + 'standard-class-foo2)) (assert (not (typep (make-instance 'standard-class-foo1) - 'standard-class-foo4))) + 'standard-class-foo4))) (assert (null (ignore-errors - (setf (slot-value (make-instance 'standard-class-foo1) 'x) - 11)))) + (setf (slot-value (make-instance 'standard-class-foo1) 'x) + 11)))) ;; condition tests (assert (typep (make-condition 'condition-foo3) - 'condition-foo2)) + 'condition-foo2)) (assert (not (typep (make-condition 'condition-foo1) - 'condition-foo4))) + 'condition-foo4))) (assert (null (ignore-errors - (setf (slot-value (make-condition 'condition-foo1) 'x) - 11)))) + (setf (slot-value (make-condition 'condition-foo1) 'x) + 11)))) (assert (subtypep 'error 't)) (assert (subtypep 'simple-condition 'condition)) (assert (subtypep 'simple-error 'simple-condition)) @@ -332,9 +332,9 @@ (assert (not (subtypep 'condition 'simple-condition))) (assert (not (subtypep 'error 'simple-error))) (assert (eq (car (sb-pcl:class-direct-superclasses - (find-class 'simple-condition))) - (find-class 'condition))) - + (find-class 'simple-condition))) + (find-class 'condition))) + #+nil ; doesn't look like a good test (let ((subclasses (mapcar #'find-class '(simple-type-error @@ -346,43 +346,43 @@ (sb-pcl:class-direct-subclasses (find-class 'simple-condition)) subclasses)))) - + ;; precedence lists - (assert (equal (sb-pcl:class-precedence-list - (find-class 'simple-condition)) - (mapcar #'find-class '(simple-condition - condition - sb-pcl::slot-object - sb-kernel:instance - t)))) + (assert (equal (sb-pcl:class-precedence-list + (find-class 'simple-condition)) + (mapcar #'find-class '(simple-condition + condition + sb-pcl::slot-object + sb-kernel:instance + t)))) ;; stream classes (assert (equal (sb-pcl:class-direct-superclasses (find-class - 'fundamental-stream)) - (mapcar #'find-class '(standard-object stream)))) + 'fundamental-stream)) + (mapcar #'find-class '(standard-object stream)))) (assert (null (set-difference - (sb-pcl:class-direct-subclasses (find-class - 'fundamental-stream)) - (mapcar #'find-class '(fundamental-binary-stream - fundamental-character-stream - fundamental-output-stream - fundamental-input-stream))))) + (sb-pcl:class-direct-subclasses (find-class + 'fundamental-stream)) + (mapcar #'find-class '(fundamental-binary-stream + fundamental-character-stream + fundamental-output-stream + fundamental-input-stream))))) (assert (equal (sb-pcl:class-precedence-list (find-class - 'fundamental-stream)) - (mapcar #'find-class '(fundamental-stream - standard-object - sb-pcl::std-object - sb-pcl::slot-object - stream - sb-kernel:instance - t)))) + 'fundamental-stream)) + (mapcar #'find-class '(fundamental-stream + standard-object + sb-pcl::std-object + sb-pcl::slot-object + stream + sb-kernel:instance + t)))) (assert (equal (sb-pcl:class-precedence-list (find-class - 'fundamental-stream)) - (mapcar #'find-class '(fundamental-stream - standard-object - sb-pcl::std-object - sb-pcl::slot-object stream - sb-kernel:instance t)))) + 'fundamental-stream)) + (mapcar #'find-class '(fundamental-stream + standard-object + sb-pcl::std-object + sb-pcl::slot-object stream + sb-kernel:instance t)))) (assert (subtypep (find-class 'stream) (find-class t))) (assert (subtypep (find-class 'fundamental-stream) 'stream)) (assert (not (subtypep 'stream 'fundamental-stream))))) @@ -412,7 +412,7 @@ (aref x 1)) (deftype bar () 'single-float) (assert (eql (foo (make-array 3 :element-type 'bar :initial-element 0.0f0)) - 0.0f0)) + 0.0f0)) ;;; bug 260a (assert-t-t diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp index 6a0351a..5e4b98d 100644 --- a/tests/type.pure.lisp +++ b/tests/type.pure.lisp @@ -4,7 +4,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -14,18 +14,18 @@ (locally (declare (notinline mapcar)) (mapcar (lambda (args) - (destructuring-bind (obj type-spec result) args - (flet ((matches-result? (x) - (eq (if x t nil) result))) - (assert (matches-result? (typep obj type-spec))) - (assert (matches-result? (sb-kernel:ctypep - obj - (sb-kernel:specifier-type - type-spec))))))) - '((nil (or null vector) t) - (nil (or number vector) nil) - (12 (or null vector) nil) - (12 (and (or number vector) real) t)))) + (destructuring-bind (obj type-spec result) args + (flet ((matches-result? (x) + (eq (if x t nil) result))) + (assert (matches-result? (typep obj type-spec))) + (assert (matches-result? (sb-kernel:ctypep + obj + (sb-kernel:specifier-type + type-spec))))))) + '((nil (or null vector) t) + (nil (or number vector) nil) + (12 (or null vector) nil) + (12 (and (or number vector) real) t)))) ;;; This test is motivated by bug #195, which previously had (THE REAL @@ -36,104 +36,104 @@ ;;; the types are equivalent in current SBCL, and EXTENDED-CHAR can ;;; unparse to NIL, since there are no EXTENDED-CHARs currently). (let ((standard-types '(;; from table 4-2 in section 4.2.3 in the - ;; CLHS. - arithmetic-error - function - simple-condition - array - generic-function - simple-error - atom - hash-table - simple-string - base-char - integer - simple-type-error - base-string - keyword - simple-vector - bignum - list - simple-warning - bit - logical-pathname - single-float - bit-vector - long-float - standard-char - broadcast-stream - method - standard-class - built-in-class - method-combination - standard-generic-function - cell-error - nil - standard-method - character - null - standard-object - class - number - storage-condition - compiled-function - package - stream - complex - package-error - stream-error - concatenated-stream - parse-error - string - condition - pathname - string-stream - cons - print-not-readable - structure-class - control-error - program-error - structure-object - division-by-zero - random-state - style-warning - double-float - ratio - symbol - echo-stream - rational - synonym-stream - end-of-file - reader-error - t - error - readtable - two-way-stream - extended-char - real - type-error - file-error - restart - unbound-slot - file-stream - sequence - unbound-variable - fixnum - serious-condition - undefined-function - float - short-float - unsigned-byte - floating-point-inexact - signed-byte - vector - floating-point-invalid-operation - simple-array - warning - floating-point-overflow - simple-base-string - floating-point-underflow - simple-bit-vector))) + ;; CLHS. + arithmetic-error + function + simple-condition + array + generic-function + simple-error + atom + hash-table + simple-string + base-char + integer + simple-type-error + base-string + keyword + simple-vector + bignum + list + simple-warning + bit + logical-pathname + single-float + bit-vector + long-float + standard-char + broadcast-stream + method + standard-class + built-in-class + method-combination + standard-generic-function + cell-error + nil + standard-method + character + null + standard-object + class + number + storage-condition + compiled-function + package + stream + complex + package-error + stream-error + concatenated-stream + parse-error + string + condition + pathname + string-stream + cons + print-not-readable + structure-class + control-error + program-error + structure-object + division-by-zero + random-state + style-warning + double-float + ratio + symbol + echo-stream + rational + synonym-stream + end-of-file + reader-error + t + error + readtable + two-way-stream + extended-char + real + type-error + file-error + restart + unbound-slot + file-stream + sequence + unbound-variable + fixnum + serious-condition + undefined-function + float + short-float + unsigned-byte + floating-point-inexact + signed-byte + vector + floating-point-invalid-operation + simple-array + warning + floating-point-overflow + simple-base-string + floating-point-underflow + simple-bit-vector))) (dolist (type standard-types) (format t "~&~S~%" type) (assert (not (sb-kernel:unknown-type-p (sb-kernel:specifier-type type)))) @@ -142,7 +142,7 @@ ;;; a bug underlying the reported bug #221: The SB-KERNEL type code ;;; signalled an error on this expression. (subtypep '(function (fixnum) (values package boolean)) - '(function (t) (values package boolean))) + '(function (t) (values package boolean))) ;;; bug reported by Valtteri Vuorik (compile nil '(lambda () (member (char "foo" 0) '(#\. #\/) :test #'char=))) @@ -176,20 +176,20 @@ (assert (subtypep t '(or real (not real)))) (assert (subtypep t '(or keyword (not keyword)))) (assert (subtypep '(and cons (not (cons symbol integer))) - '(or (cons (not symbol) *) (cons * (not integer))))) + '(or (cons (not symbol) *) (cons * (not integer))))) (assert (subtypep '(or (cons (not symbol) *) (cons * (not integer))) - '(and cons (not (cons symbol integer))))) + '(and cons (not (cons symbol integer))))) (assert (subtypep '(or (eql 0) (rational (0) 10)) - '(rational 0 10))) + '(rational 0 10))) (assert (subtypep '(rational 0 10) - '(or (eql 0) (rational (0) 10)))) + '(or (eql 0) (rational (0) 10)))) ;;; Until sbcl-0.7.13.7, union of CONS types when the CDRs were the ;;; same type gave exceedingly wrong results (assert (null (subtypep '(or (cons fixnum single-float) - (cons bignum single-float)) - '(cons single-float single-float)))) + (cons bignum single-float)) + '(cons single-float single-float)))) (assert (subtypep '(cons integer single-float) - '(or (cons fixnum single-float) (cons bignum single-float)))) + '(or (cons fixnum single-float) (cons bignum single-float)))) (assert (not (nth-value 1 (subtypep '(and null some-unknown-type) 'another-unknown-type)))) @@ -218,9 +218,9 @@ (assert (subtypep '(complex ratio) '(complex rational))) (assert (subtypep '(complex ratio) 'complex)) (assert (equal (multiple-value-list - (subtypep '(complex (integer 1 2)) - '(member #c(1 1) #c(1 2) #c(2 1) #c(2 2)))) - '(nil t))) + (subtypep '(complex (integer 1 2)) + '(member #c(1 1) #c(1 2) #c(2 1) #c(2 2)))) + '(nil t))) (assert (typep 0 '(real #.(ash -1 10000) #.(ash 1 10000)))) (assert (subtypep '(real #.(ash -1 1000) #.(ash 1 1000)) diff --git a/tests/vector.pure.lisp b/tests/vector.pure.lisp index 595d588..27ac97a 100644 --- a/tests/vector.pure.lisp +++ b/tests/vector.pure.lisp @@ -4,42 +4,42 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. (cl:in-package :cl-user) -(funcall (lambda () - (let ((simple-t (make-array 35)) - (simple-u32 (make-array 50 - :element-type '(unsigned-byte 32))) - (simple-character (make-string 44)) - (complex-t (make-array 4 :fill-pointer 3)) - (complex-u32 (make-array 88 - :adjustable t - :element-type '(unsigned-byte 32))) - (complex-character (make-array 14 - :element-type 'character - :fill-pointer t))) - (assert (= (length simple-t) 35)) - (assert (= (length simple-u32) 50)) - (assert (= (length simple-character) 44)) - (assert (= (length complex-t) 3)) - (assert (= (length complex-u32) 88)) - (assert (= (length complex-character) 14)) - (vector-push-extend #\a complex-t) - (assert (= (length complex-t) 4)) - (assert (raises-error? (vector-push-extend #\b simple-t)))))) +(funcall (lambda () + (let ((simple-t (make-array 35)) + (simple-u32 (make-array 50 + :element-type '(unsigned-byte 32))) + (simple-character (make-string 44)) + (complex-t (make-array 4 :fill-pointer 3)) + (complex-u32 (make-array 88 + :adjustable t + :element-type '(unsigned-byte 32))) + (complex-character (make-array 14 + :element-type 'character + :fill-pointer t))) + (assert (= (length simple-t) 35)) + (assert (= (length simple-u32) 50)) + (assert (= (length simple-character) 44)) + (assert (= (length complex-t) 3)) + (assert (= (length complex-u32) 88)) + (assert (= (length complex-character) 14)) + (vector-push-extend #\a complex-t) + (assert (= (length complex-t) 4)) + (assert (raises-error? (vector-push-extend #\b simple-t)))))) (multiple-value-bind (fp1 index fp2 bool) (let ((a (make-array '(5) :fill-pointer 5 :adjustable 5 - :initial-contents '(a b c d e)))) + :initial-contents '(a b c d e)))) (values (fill-pointer a) - (vector-push-extend 'x a) - (fill-pointer a) - (<= (array-total-size a) 5))) + (vector-push-extend 'x a) + (fill-pointer a) + (<= (array-total-size a) 5))) (assert (= fp1 5)) (assert (= index 5)) (assert (= fp2 6)) diff --git a/tests/vm.before-xc.lisp b/tests/vm.before-xc.lisp index 4fa4841..3fd2f2f 100644 --- a/tests/vm.before-xc.lisp +++ b/tests/vm.before-xc.lisp @@ -7,7 +7,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -17,12 +17,12 @@ (/show "beginning tests/vm.before-xc.lisp") (flet ((yes (x) - (assert - (eql (sc-number-or-lose 'immediate) - (impl-of-vm-support-routine-immediate-constant-sc x)))) + (assert + (eql (sc-number-or-lose 'immediate) + (impl-of-vm-support-routine-immediate-constant-sc x)))) (no (x) - (assert - (not (impl-of-vm-support-routine-immediate-constant-sc x))))) + (assert + (not (impl-of-vm-support-routine-immediate-constant-sc x))))) ;; target fixnums can be dealt with as immediates; target bignums ;; can not. (yes #.sb-xc:most-positive-fixnum) diff --git a/tests/walk.impure.lisp b/tests/walk.impure.lisp index 693000b..80b4915 100644 --- a/tests/walk.impure.lisp +++ b/tests/walk.impure.lisp @@ -25,7 +25,20 @@ (in-package :sb-walker) -;;;; stuff based on the tests at the end of the original CMU CL +;;;; utilities to support tests + +;;; string equality modulo deletion of TABs and SPACEs (as a crude way +;;; of washing away irrelevant differences in indentation) +(defun string-modulo-tabspace (s) + (remove-if (lambda (c) + (or (char= c #\space) + (char= c #\tab))) + s)) +(defun string=-modulo-tabspace (x y) + (string= (string-modulo-tabspace x) + (string-modulo-tabspace y))) + +;;;; tests based on stuff at the end of the original CMU CL ;;;; pcl/walk.lisp file (defmacro take-it-out-for-a-test-walk (form) @@ -33,26 +46,26 @@ (defun take-it-out-for-a-test-walk-1 (form) (let ((copy-of-form (copy-tree form)) - (result (walk-form form nil - (lambda (x y env) - (format t "~&Form: ~S ~3T Context: ~A" x y) - (when (symbolp x) - (let ((lexical (var-lexical-p x env)) - (special (var-special-p x env))) - (when lexical - (format t ";~3T") - (format t "lexically bound")) - (when special - (format t ";~3T") - (format t "declared special")) - (when (boundp x) - (format t ";~3T") - (format t "bound: ~S " (eval x))))) - x)))) + (result (walk-form form nil + (lambda (x y env) + (format t "~&Form: ~S ~3T Context: ~A" x y) + (when (symbolp x) + (let ((lexical (var-lexical-p x env)) + (special (var-special-p x env))) + (when lexical + (format t ";~3T") + (format t "lexically bound")) + (when special + (format t ";~3T") + (format t "declared special")) + (when (boundp x) + (format t ";~3T") + (format t "bound: ~S " (eval x))))) + x)))) (cond ((not (equal result copy-of-form)) - (format t "~%Warning: Result not EQUAL to copy of start.")) - ((not (eq result form)) - (format t "~%Warning: Result not EQ to copy of start."))) + (format t "~%Warning: Result not EQUAL to copy of start.")) + ((not (eq result form)) + (format t "~%Warning: Result not EQ to copy of start."))) (pprint result) nil)) @@ -64,7 +77,7 @@ (declare (ignore ignore)) ''global-bar) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (list arg1 arg2 arg3))) "Form: (LIST ARG1 ARG2 ARG3) Context: EVAL @@ -73,7 +86,7 @@ Form: ARG2 Context: EVAL Form: ARG3 Context: EVAL (LIST ARG1 ARG2 ARG3)")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5)))) "Form: (LIST (CONS 1 2) (LIST 3 4 5)) Context: EVAL @@ -86,7 +99,7 @@ Form: 4 Context: EVAL Form: 5 Context: EVAL (LIST (CONS 1 2) (LIST 3 4 5))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (progn (foo) (bar 1)))) "Form: (PROGN (FOO) (BAR 1)) Context: EVAL @@ -96,7 +109,7 @@ Form: (BAR 1) Context: EVAL Form: 'GLOBAL-BAR Context: EVAL (PROGN (FOO) (BAR 1))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (block block-name a b c))) "Form: (BLOCK BLOCK-NAME A B C) Context: EVAL @@ -105,7 +118,7 @@ Form: B Context: EVAL Form: C Context: EVAL (BLOCK BLOCK-NAME A B C)")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (block block-name (list a) b c))) "Form: (BLOCK BLOCK-NAME (LIST A) B C) Context: EVAL @@ -115,7 +128,7 @@ Form: B Context: EVAL Form: C Context: EVAL (BLOCK BLOCK-NAME (LIST A) B C)")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (catch catch-tag (list a) b c))) "Form: (CATCH CATCH-TAG (LIST A) B C) Context: EVAL @@ -129,7 +142,7 @@ Form: C Context: EVAL ;;; This is a fairly simple MACROLET case. While walking the body of the ;;; macro, X should be lexically bound. In the body of the MACROLET form ;;; itself, X should not be bound. -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (macrolet ((foo (x) (list x) ''inner)) @@ -167,7 +180,7 @@ Form: 'INNER Context: EVAL ;;; the local macro definitions in a MACROLET, but the consequences ;;; are undefined if the local macro definitions reference any ;;; local variable or function bindings that are visible in that -;;; lexical environment. +;;; lexical environment. ;;; Since the behavior is undefined, anything we do conforms.:-| ;;; This is of course less than ideal; see bug 124. #+nil @@ -180,7 +193,7 @@ Form: 'INNER Context: EVAL (foo))))) (assert (and (null res) cond))) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (flet ((foo (x) (list x y)) @@ -205,7 +218,7 @@ Form: 1 Context: EVAL (LIST X Y))) (FOO 1))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (let ((y 2)) @@ -239,7 +252,7 @@ Form: 1 Context: EVAL (LIST X Y))) (FOO 1)))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (labels ((foo (x) (bar x)) @@ -262,7 +275,7 @@ Form: 1 Context: EVAL (FOO X))) (FOO 1))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (flet ((foo (x) (foo x))) @@ -278,7 +291,7 @@ Form: 1 Context: EVAL (FOO X))) (FOO 1))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (flet ((foo (x) (foo x))) @@ -304,7 +317,7 @@ Form: 1 Context: EVAL (FOO X))) (BAR 1)))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (prog () (declare (special a b))))) "Form: (PROG () (DECLARE (SPECIAL A B))) Context: EVAL @@ -318,7 +331,7 @@ Form: (LET () Form: (TAGBODY) Context: EVAL (PROG () (DECLARE (SPECIAL A B)))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (let (a b c) (declare (special a b)) @@ -338,7 +351,7 @@ Form: C Context: EVAL; lexically bound B C)")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (let (a b c) (declare (special a) (special b)) @@ -358,7 +371,7 @@ Form: C Context: EVAL; lexically bound B C)")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (let (a b c) (declare (special a)) @@ -381,7 +394,7 @@ Form: C Context: EVAL; lexically bound B C)")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (let (a b c) (declare (special a)) @@ -411,8 +424,8 @@ Form: C Context: EVAL; lexically bound (FOO A) B C))")) - -(assert (equal + +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (eval-when () a @@ -423,7 +436,7 @@ Form: (FOO A) Context: EVAL Form: 'GLOBAL-FOO Context: EVAL (EVAL-WHEN NIL A (FOO A))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (eval-when (:execute :compile-toplevel :load-toplevel) @@ -435,7 +448,7 @@ Form: (FOO A) Context: EVAL Form: 'GLOBAL-FOO Context: EVAL (EVAL-WHEN (:EXECUTE :COMPILE-TOPLEVEL :LOAD-TOPLEVEL) A (FOO A))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (list a b)))) @@ -447,7 +460,7 @@ Form: A Context: EVAL; lexically bound Form: B Context: EVAL; lexically bound (MULTIPLE-VALUE-BIND (A B) (FOO A B) (LIST A B))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) @@ -461,14 +474,14 @@ Form: A Context: EVAL; lexically bound Form: B Context: EVAL; lexically bound (MULTIPLE-VALUE-BIND (A B) (FOO A B) (DECLARE (SPECIAL A)) (LIST A B))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (progn (function foo)))) "Form: (PROGN #'FOO) Context: EVAL Form: #'FOO Context: EVAL (PROGN #'FOO)")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (progn a b (go a)))) "Form: (PROGN A B (GO A)) Context: EVAL @@ -477,7 +490,7 @@ Form: B Context: EVAL Form: (GO A) Context: EVAL (PROGN A B (GO A))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (if a b c))) "Form: (IF A B C) Context: EVAL @@ -486,16 +499,16 @@ Form: B Context: EVAL Form: C Context: EVAL (IF A B C)")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (if a b))) "Form: (IF A B) Context: EVAL Form: A Context: EVAL Form: B Context: EVAL -Form: NIL Context: EVAL; bound: NIL +Form: NIL Context: EVAL; bound: NIL (IF A B)")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2))) "Form: ((LAMBDA (A B) (LIST A B)) 1 2) Context: EVAL @@ -507,7 +520,7 @@ Form: 1 Context: EVAL Form: 2 Context: EVAL ((LAMBDA (A B) (LIST A B)) 1 2)")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) @@ -522,7 +535,7 @@ Form: 1 Context: EVAL Form: 2 Context: EVAL ((LAMBDA (A B) (DECLARE (SPECIAL A)) (LIST A B)) 1 2)")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c)))) @@ -538,7 +551,7 @@ Form: C Context: EVAL; lexically bound (LET ((A A) (B A) (C B)) (LIST A B C))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c)))) "Form: (LET* ((A A) (B A) (C B)) @@ -553,7 +566,7 @@ Form: C Context: EVAL; lexically bound (LET* ((A A) (B A) (C B)) (LIST A B C))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (declare (special a b)) @@ -572,7 +585,7 @@ Form: C Context: EVAL; lexically bound (DECLARE (SPECIAL A B)) (LIST A B C))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (declare (special a b)) @@ -591,7 +604,7 @@ Form: C Context: EVAL; lexically bound (DECLARE (SPECIAL A B)) (LIST A B C))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (let ((a 1) (b 2)) (foo bar) @@ -618,7 +631,7 @@ Form: 'GLOBAL-FOO Context: EVAL (DECLARE (SPECIAL A)) (FOO A B)))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (multiple-value-call #'foo a b c))) "Form: (MULTIPLE-VALUE-CALL #'FOO A B C) Context: EVAL @@ -628,7 +641,7 @@ Form: B Context: EVAL Form: C Context: EVAL (MULTIPLE-VALUE-CALL #'FOO A B C)")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (multiple-value-prog1 a b c))) "Form: (MULTIPLE-VALUE-PROG1 A B C) Context: EVAL @@ -637,7 +650,7 @@ Form: B Context: EVAL Form: C Context: EVAL (MULTIPLE-VALUE-PROG1 A B C)")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (progn a b c))) "Form: (PROGN A B C) Context: EVAL @@ -646,7 +659,7 @@ Form: B Context: EVAL Form: C Context: EVAL (PROGN A B C)")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (progv vars vals a b c))) "Form: (PROGV VARS VALS A B C) Context: EVAL @@ -657,13 +670,13 @@ Form: B Context: EVAL Form: C Context: EVAL (PROGV VARS VALS A B C)")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (quote a))) "Form: 'A Context: EVAL 'A")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (return-from block-name a b c))) "Form: (RETURN-FROM BLOCK-NAME A B C) Context: EVAL @@ -672,7 +685,7 @@ Form: B Context: EVAL Form: C Context: EVAL (RETURN-FROM BLOCK-NAME A B C)")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (setq a 1))) "Form: (SETQ A 1) Context: EVAL @@ -681,7 +694,7 @@ Form: 1 Context: EVAL (SETQ A 1)")) (makunbound 'a) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3))) "Form: (SETQ A (FOO 1) B (BAR 2) C 3) Context: EVAL @@ -701,7 +714,7 @@ Form: 3 Context: EVAL (makunbound 'b) (makunbound 'c) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (tagbody a b c (go a)))) "Form: (TAGBODY A B C (GO A)) Context: EVAL @@ -711,7 +724,7 @@ Form: C Context: QUOTE Form: (GO A) Context: EVAL (TAGBODY A B C (GO A))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (the foo (foo-form a b c)))) "Form: (THE FOO (FOO-FORM A B C)) Context: EVAL @@ -721,7 +734,7 @@ Form: B Context: EVAL Form: C Context: EVAL (THE FOO (FOO-FORM A B C))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (throw tag-form a))) "Form: (THROW TAG-FORM A) Context: EVAL @@ -729,7 +742,7 @@ Form: TAG-FORM Context: EVAL Form: A Context: EVAL (THROW TAG-FORM A)")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f))) "Form: (UNWIND-PROTECT (FOO A B) D E F) Context: EVAL @@ -748,7 +761,7 @@ Form: F Context: EVAL (declare (ignore a b)) ''outer) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (flet ((flet-1 (a b) () (flet-1 a b) (list a b))) @@ -760,7 +773,7 @@ Form: F Context: EVAL (LIST A B))) (FLET-1 1 2) (FOO 1 2)) Context: EVAL -Form: NIL Context: EVAL; bound: NIL +Form: NIL Context: EVAL; bound: NIL Form: (FLET-1 A B) Context: EVAL Form: 'OUTER Context: EVAL Form: (LIST A B) Context: EVAL @@ -778,7 +791,7 @@ Form: 'GLOBAL-FOO Context: EVAL (FLET-1 1 2) (FOO 1 2))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (labels ((label-1 (a b) () (label-1 a b)(list a b))) @@ -790,7 +803,7 @@ Form: 'GLOBAL-FOO Context: EVAL (LIST A B))) (LABEL-1 1 2) (FOO 1 2)) Context: EVAL -Form: NIL Context: EVAL; bound: NIL +Form: NIL Context: EVAL; bound: NIL Form: (LABEL-1 A B) Context: EVAL Form: A Context: EVAL; lexically bound Form: B Context: EVAL; lexically bound @@ -809,7 +822,7 @@ Form: 'GLOBAL-FOO Context: EVAL (LABEL-1 1 2) (FOO 1 2))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b))) (macrolet-1 a b) @@ -831,7 +844,7 @@ Form: 'GLOBAL-FOO Context: EVAL (MACROLET-1 A B) (FOO 1 2))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a))) (foo 1)))) @@ -848,7 +861,7 @@ Form: 1 Context: EVAL `(INNER-FOO-EXPANDED ,A))) (FOO 1))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (progn (bar 1) (macrolet ((bar (a) @@ -876,7 +889,7 @@ Form: 2 Context: EVAL `(INNER-BAR-EXPANDED ,A))) (BAR 2)))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (progn (bar 1) (macrolet ((bar (s) @@ -910,7 +923,7 @@ Form: 2 Context: EVAL `(INNER-BAR-EXPANDED ,S))) (BAR 2)))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (take-it-out-for-a-test-walk (cond (a b) ((foo bar) a (foo a))))) @@ -928,21 +941,21 @@ Form: A Context: EVAL Form: (FOO A) Context: EVAL Form: 'GLOBAL-FOO Context: EVAL Form: (COND) Context: EVAL -Form: NIL Context: EVAL; bound: NIL +Form: NIL Context: EVAL; bound: NIL (COND (A B) ((FOO BAR) A (FOO A)))")) -(assert (equal +(assert (string=-modulo-tabspace (with-output-to-string (*standard-output*) (let ((the-lexical-variables ())) (walk-form '(let ((a 1) (b 2)) (lambda (x) (list a b x y))) () (lambda (form context env) - (declare (ignore context)) - (when (and (symbolp form) - (var-lexical-p form env)) - (push form the-lexical-variables)) - form)) + (declare (ignore context)) + (when (and (symbolp form) + (var-lexical-p form env)) + (push form the-lexical-variables)) + form)) (or (and (= (length the-lexical-variables) 3) (member 'a the-lexical-variables) (member 'b the-lexical-variables) @@ -950,7 +963,9 @@ Form: NIL Context: EVAL; bound: NIL (error "Walker didn't do lexical variables of a closure properly.")))) "")) -;; old PCL hung up on it +;;;; more tests + +;;; Old PCL hung up on this. (defmethod #:foo () (defun #:bar ())) diff --git a/version.lisp-expr b/version.lisp-expr index b836cb3..6b494da 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.2.42" +"0.9.2.43" -- 1.7.10.4